File Coverage

blib/lib/DTL/Fast/Filter/Urlize.pm

Criterion	Covered	Total	%
statement	38	38	100.0
branch	6	6	100.0
condition	3	6	50.0
subroutine	9	9	100.0
pod	0	4	0.0
total	56	63	88.8

package DTL::Fast::Filter::Urlize;
use strict; use utf8; use warnings FATAL => 'all';
use parent 'DTL::Fast::Filter';

$DTL::Fast::FILTER_HANDLERS{'urlize'} = __PACKAGE__;

use DTL::Fast::Utils qw(unescape);

our $DOMAINS_RE = qr/com|org|net|gov|mil|biz|info|mobi|name|aero|jobs|museum|travel|ru|рф|[a-z]{2,3}/;

our $URL_RE = qr
{
    (?:(?:http|ftp|https)\://)?  # protocol
    (?:\w+\:\w+\@)?              # username and password
    (?:(?:www|ftp)\.)?           # domain prefixes
    (?:[-\w]+\.)+                # domain name
    (?:$DOMAINS_RE)              # top level domain
    (?:\:\d{1,5})?               # port number
    (?:/[-\w~._]*)*?             # directories and files
    (?:\?[^\s#]+?)?              # query string no spaces or sharp
    (?:\#[^\s]+?)?               # anchor
}x;

our $EMAIL_RE = qr
{
    (?:[-\w_~\.]+\@)             # user name
    (?:[-\w]+\.)+                # domain name
    (?:$DOMAINS_RE)              # top level domain
}x;

#@Override
sub filter
{
    my $self = shift;  # self
    my $filter_manager = shift;  # filter_manager
    my $value = shift;  # value
    shift;    #context

    $value =~ s
    {
        (?:($EMAIL_RE)|($URL_RE))
        ($|\s|\.|,|!)                   # after link
    }{
        $self->wrap_email($1,$3).$self->wrap_url($2,$3)
    }gxesi;

    $filter_manager->{'safe'} = 1;

    return $value;
}

sub wrap_url
{
    my $self = shift;
    my $text = shift;
    return '' if not $text;
    my $appendix = shift // '';

    my $uri = $text;
    $uri = 'http://'.$uri if
        $uri !~ m{^(http|ftp|https)://}i;

    return sprintf '%s%s'
        , $uri // 'undef'
        , DTL::Fast::html_protect(unescape($self->normalize_text($text)))
        , $appendix
        ;
}

sub wrap_email
{
    my $self = shift;
    my $text = shift;
    return '' if not $text;
    my $appendix = shift // '';

    my $uri = $text;

    return sprintf '%s%s'
        , $uri
        , DTL::Fast::html_protect(unescape($self->normalize_text($text)))
        , $appendix
        ;
}

sub normalize_text
{
    shift;
    return shift;
}

1;