root/Apache-Clickable/trunk/lib/Apache/Clickable.pm

Revision 163 (checked in by miyagawa, 19 years ago)

Initial revision

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1 package Apache::Clickable;
2
3 use strict;
4 use vars qw($VERSION);
5 $VERSION = '0.01';
6
7 use Apache::Constants qw(:common);
8 use Apache::File;
9 use Carp ();
10
11 sub handler {
12     my $r = shift;
13
14     my $filtered = uc($r->dir_config('Filter')) eq 'ON';
15     $r = $r->filter_register if $filtered;
16
17     # only for text/html
18     return DECLINED unless ($r->content_type eq 'text/html' && $r->is_main);
19
20     my($fh, $status);
21     if ($filtered) {
22         ($fh, $status) = $r->filter_input;
23         undef $fh unless $status == OK;
24     } else {
25         $fh = Apache::File->new($r->filename);
26     }
27    
28     return DECLINED unless $fh;
29    
30     $r->send_http_header;
31
32     local $/;                   # slurp
33     my $input = <$fh>;
34     my $output = make_it_clickable($r, $input);
35     $r->print($output);
36     return OK;
37 }
38
39 sub make_it_clickable {
40     my($r, $input) = @_;
41     my $parser = Apache::Clickable::Parser->new(apr => $r);
42     $parser->parse($input);
43     return $parser->{output};
44 }
45
46 package Apache::Clickable::Parser;
47
48 require HTML::Parser;
49 @Apache::Clickable::Parser::ISA = qw(HTML::Parser);
50
51 use Email::Find 0.04;
52 use URI::Find;
53
54 sub new {
55     my($class, %args) = @_;
56    
57     my $self = $class->SUPER::new;
58     $self->{apr} = $args{apr};
59     $self->{currently_in_a} = 0;
60     return $self;
61 }
62  
63 sub comment {
64     my($self, $comment) = @_;
65     $self->{output} .= "<!--$comment-->";
66 }
67
68 sub declaration {
69     my($self, $declaration) = @_;
70     $self->{output} .= "<!$declaration>";
71 }
72
73 sub start {
74     my($self, $tag, $attr, $attrseq, $origtext) = @_;
75     if ($tag eq 'a') {
76         $self->{currently_in_a}++;
77     }
78     $self->{output} .= $origtext;
79 }
80
81 sub end {
82     my($self, $tag, $origtext) = @_;
83     if ($tag eq 'a') {
84         $self->{currently_in_a}--;
85     }
86     $self->{output} .= $origtext;
87 }
88
89 sub text {
90     my($self, $origtext) = @_;
91     if ($self->{currently_in_a}) {
92         $self->{output} .= $origtext;
93         return;
94     }
95
96     $self->{output} .= $self->replace_sub->($origtext);
97 }
98
99 my $sub;                        # closure
100 sub replace_sub {
101     my $self = shift;
102     unless ($sub) {
103         $sub = sub {
104             my $input = shift;
105             # replace URLs
106             my $target = $self->{apr}->dir_config('ClickableTarget') || undef;
107             find_uris($input, sub {
108                           my($uri, $orig_uri) = @_;
109                           return sprintf(qq(<a href="%s"%s>%s</a>),
110                                          $orig_uri,
111                                          ($target ? qq( target="$target") : ''),
112                                          $orig_uri);
113                       });
114    
115             # replace Emails
116             unless (uc($self->{apr}->dir_config('ClickableEmail')) eq 'OFF') {
117                 find_emails($input, sub {
118                                 my($email, $orig_email) = @_;
119                                 return sprintf(qq(<a href="mailto:%s">%s</a>),
120                                                $orig_email, $orig_email);
121                             });
122             }
123    
124             return $input;
125         };
126     }
127     return $sub;
128 }
129
130    
131
132 1;
133 __END__
134
135 =head1 NAME
136
137 Apache::Clickable - Make URLs and Emails in HTML clickable
138
139 =head1 SYNOPSIS
140
141   # in httpd.conf
142   <Location /clickable>
143   SetHandler perl-script
144   PerlHandler Apache::Clickable
145   </Location>
146
147   # filter aware
148   PerlModule Apache::Clickable
149   SetHandler perl-script
150   PerlSetVar Filter On
151   PerlHandler Apache::Clickable Apache::AntiSpam Apache::Compress
152
153 =head1 DESCRIPTION
154
155 Apache::Clickable is a filter to make URLs in HTML clickable. With
156 URI::Find and Email::Find, this module finds URL and Email in HTML
157 document, and automatically constructs hyperlinks for them.
158
159 For example,
160
161   <body>
162   Documentation is available at http://www.foobar.com/ freely.<P>
163   someone@foobar.com 
164   </body>
165
166 This HTML would be filtered to:
167    
168   <body>
169   Documentation is available at <a href="http://www.foobar.com/">http://www.foobar.com</a> freely.<P>
170   <a href="mailto:someone@foobar.com">someone@foobar.com</a>
171   </body>
172
173 This module is Filter aware, meaning that it can work within
174 Apache::Filter framework without modification.
175
176 =head1 CONFIGURATION
177
178   PerlSetVar ClickableTarget _blank
179   PerlSetVar ClickableEmail Off
180
181 =over 4
182
183 =item ClickableTarget
184
185   PerlSetVar ClickableTarget _blank
186
187 specifies target window name of hyperlinks. If set "_blank" for
188 example, it filters to:
189
190   <a href="http://www.foobar.com/" target="_blank">http://www.foobar.com/</a>
191
192 None by default.
193
194 =item ClickableEmail
195
196   PerlSetVar ClickableEmail Off
197
198 specifies whether it makes email clickable. On by default. See
199 L<Apache::AntiSpam> for more.
200
201 =back
202
203 =head1 TODO
204
205 =over 4
206
207 =item *
208
209 Configurable hyperlink construction using subclass.
210
211 =item *
212
213 Currently, this module requires HTML::Parser, not to make duplicate
214 hyperlinks. Maybe this can be done without HTML::Parser.
215
216 =back
217
218 =head1 AUTHOR
219
220 Tatsuhiko Miyagawa <miyagawa@bulknews.net>
221
222 This library is free software; you can redistribute it and/or modify
223 it under the same terms as Perl itself.
224
225 =head1 SEE ALSO
226
227 L<Apache::Filter>, L<Apache::AntiSpam>, L<URI::Find>, L<Email::Find>, L<HTML::Parser>
228
229 =cut
Note: See TracBrowser for help on using the browser.