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