1package Text::Hatena::AutoLink;
2use strict;
3use warnings;
4use Carp;
5use Regexp::Assemble;
6use base qw(Class::Data::Inheritable);
7use vars qw($VERSION);
8
9__PACKAGE__->mk_classdata('syntax');
10__PACKAGE__->syntax({});
11
12$VERSION = '0.20';
13
14my $ra;
15my $syntax = {
16    '\[\](.+?)\[\]' => \&unbracket,
17    '(?:\[)?(ftp:\/\/[A-Za-z0-9~\/._\?\&=\-%#\+:\;,\@\']+)(?:\])?' => \&http,
18    '(?:\[)?(https?:\/\/[A-Za-z0-9~\/._\?\&=\-%#\+:\;,\@\']+)(?:\])?' => \&http,
19    '\[(https?:\/\/[A-Za-z0-9~\/._\?\&=\-%#\+:\;,\@\']+(?:jpg|jpeg|gif|png|bmp)):image(:[hw]\d+)?\]' => \&http_image,
20    '\[(https?:\/\/[A-Za-z0-9~\/._\?\&=\-%#\+:\;,\@\']+):title=([^\]]+)\]' => \&http_title,
21    '(?:\[)?mailto:(\w[\w\.-]+\@\w[\w\.\-]*\w)(?:\])?' => \&mailto,
22};
23
24sub parse {
25    my $class = shift;
26    my $text = shift;
27    my $html = '';
28    my $ra = $class->ra;
29    while ($text && $ra->match($text)) {
30        $html .= substr($text, 0, $ra->mbegin->[0]) if $ra->mbegin->[0];
31        my $handler = $class->syntax->{$ra->matched} || $syntax->{$ra->matched};
32        $html .= $handler->($ra->mvar());
33        $text = substr($text, $ra->mend->[0]);
34    }
35    $html .= $text if $text;
36    return $html;
37}
38
39sub ra {
40    my $class = shift;
41    unless ($ra) {
42        $ra = Regexp::Assemble->new(
43            flags => 'i',
44            track => 1,
45            reduce => 1,
46        );
47        $ra->add(keys %$syntax, keys %{$class->syntax});
48    }
49    return $ra;
50}
51
52sub unbracket {
53    my $mvar = shift;
54    return $mvar->[1];
55}
56
57sub http {
58    my $mvar = shift;
59    my $url = $mvar->[0];
60    return sprintf('<a href="%s">%s</a>', $url, $url);
61}
62
63sub http_image {
64    my $mvar = shift;
65    my $url = $mvar->[1];
66    my $size = '';
67    if ($mvar->[2] && $mvar->[2] =~ /^:([hw])(\d+)$/o) {
68        my $hw = $1 eq 'h' ? 'height' : 'width';
69        $size = sprintf(qq|$hw="%d" |, $2);
70    }
71    return sprintf('<a href="%s"><img src="%s" alt="%s" %s/></a>',
72                   $url, $url, $url, $size);
73}
74
75sub http_title {
76    my $mvar = shift;
77    my $url = $mvar->[1];
78    my $title = $mvar->[2];
79    return sprintf('<a href="%s">%s</a>', $url, $title);
80}
81
82sub mailto {
83    my $mvar = shift;
84    my $addr = $mvar->[1];
85    return sprintf('<a href="mailto:%s">mailto:%s</a>', $addr, $addr);
86}
87
881;
89
90__END__
91
92=head1 NAME
93
94Text::AutoLink - Perl extension for making hyperlinks in text automatically.
95
96=head1 SYNOPSIS
97
98  use Text::Hatena::AutoLink;
99
100  my $parser = Text::Hatena::AutoLink->new;
101  my $html = $parser->parse($text);
102
103=head1 DESCRIPTION
104
105Text::Hatena::AutoLink makes many hyperlinks in text automatically.
106Urls will be changed into hyperlinks.
107
108=over 4
109
110=item Incompatibility at version 0.20
111
112All codes were rewritten at version 0.20 and some functions were removed.
113API for parsing text were changed too. Please be careful to upgrade your
114Text::Hatena::AutoLink to version 0.20+.
115
116=back
117
118=head1 METHODS
119
120Here are common methods of Text::Hatena::AutoLink.
121
122=over 4
123
124=item parse
125
126  my $html = $parser->parse($text);
127
128parses text and make links. It returns html.
129
130=back
131
132=head1 Text::Hatena::AutoLink Syntax
133
134Text::Hatena::AutoLink supports some simple syntaxes.
135
136  http://www.hatena.ne.jp/
137  [http://www.hatena.ne.jp/:title=Hatena]
138  [http://www.hatena.ne.jp/images/top/h1.gif:image]
139  [http://www.hatena.ne.jp/images/top/h1.gif:image:w300]
140  mailto:someone@example.com
141
142These lines all become into hyperlinks.
143
144  []http://dont.link.to.me/[]
145
146You can avoid being hyperlinked with 2 pair brackets like the above line.
147
148=head1 SEE ALSO
149
150L<Text::Hatena>
151
152=head1 AUTHOR
153
154Junya Kondo, E<lt>jkondo@hatena.ne.jpE<gt>
155
156=head1 COPYRIGHT AND LICENSE
157
158Copyright (C) Hatena Inc. All Rights Reserved.
159
160This library is free software; you may redistribute it and/or modify
161it under the same terms as Perl itself.
162
163=cut
164