File Coverage

blib/lib/Text/Hatena/AutoLink.pm

Criterion	Covered	Total	%
statement	18	54	33.3
branch	0	10	0.0
condition	0	9	0.0
subroutine	6	13	46.1
pod			n/a
total	24	86	27.9

package Text::Hatena::AutoLink;
use strict;
use warnings;
use Carp;
use Regexp::Assemble;
use base qw(Class::Data::Inheritable);
use vars qw($VERSION);

__PACKAGE__->mk_classdata('syntax');
__PACKAGE__->syntax({});

$VERSION = '0.20';

my $ra;
my $syntax = {
    '\[\](.+?)\[\]' => \&unbracket,
    '(?:\[)?(ftp:\/\/[A-Za-z0-9~\/._\?\&=\-%#\+:\;,\@\']+)(?:\])?' => \&http,
    '(?:\[)?(https?:\/\/[A-Za-z0-9~\/._\?\&=\-%#\+:\;,\@\']+)(?:\])?' => \&http,
    '\[(https?:\/\/[A-Za-z0-9~\/._\?\&=\-%#\+:\;,\@\']+(?:jpg|jpeg|gif|png|bmp)):image(:[hw]\d+)?\]' => \&http_image,
    '\[(https?:\/\/[A-Za-z0-9~\/._\?\&=\-%#\+:\;,\@\']+):title=([^\]]+)\]' => \&http_title,
    '(?:\[)?mailto:(\w[\w\.-]+\@\w[\w\.\-]*\w)(?:\])?' => \&mailto,
};

sub parse {
    my $class = shift;
    my $text = shift;
    my $html = '';
    my $ra = $class->ra;
    while ($text && $ra->match($text)) {
        $html .= substr($text, 0, $ra->mbegin->[0]) if $ra->mbegin->[0];
        my $handler = $class->syntax->{$ra->matched} || $syntax->{$ra->matched};
        $html .= $handler->($ra->mvar());
        $text = substr($text, $ra->mend->[0]);
    }
    $html .= $text if $text;
    return $html;
}

sub ra {
    my $class = shift;
    unless ($ra) {
        $ra = Regexp::Assemble->new(
            flags => 'i',
            track => 1,
            reduce => 1,
        );
        $ra->add(keys %$syntax, keys %{$class->syntax});
    }
    return $ra;
}

sub unbracket {
    my $mvar = shift;
    return $mvar->[1];
}

sub http {
    my $mvar = shift;
    my $url = $mvar->[0];
    return sprintf('%s', $url, $url);
}

sub http_image {
    my $mvar = shift;
    my $url = $mvar->[1];
    my $size = '';
    if ($mvar->[2] && $mvar->[2] =~ /^:([hw])(\d+)$/o) {
        my $hw = $1 eq 'h' ? 'height' : 'width';
        $size = sprintf(qq|$hw="%d" |, $2);
    }
    return sprintf('',
                   $url, $url, $url, $size);
}

sub http_title {
    my $mvar = shift;
    my $url = $mvar->[1];
    my $title = $mvar->[2];
    return sprintf('%s', $url, $title);
}

sub mailto {
    my $mvar = shift;
    my $addr = $mvar->[1];
    return sprintf('mailto:%s', $addr, $addr);
}

1;

__END__