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;