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


line stmt bran cond sub pod time code
1             package DTL::Fast::Filter::Urlize;
2 3     3   1809 use strict; use utf8; use warnings FATAL => 'all';
  3     3   6  
  3     3   70  
  3         13  
  3         5  
  3         17  
  3         68  
  3         5  
  3         103  
3 3     3   12 use parent 'DTL::Fast::Filter';
  3         6  
  3         17  
4              
5             $DTL::Fast::FILTER_HANDLERS{'urlize'} = __PACKAGE__;
6              
7 3     3   180 use DTL::Fast::Utils qw(unescape);
  3         6  
  3         1720  
8              
9             our $DOMAINS_RE = qr/com|org|net|gov|mil|biz|info|mobi|name|aero|jobs|museum|travel|ru|рф|[a-z]{2,3}/;
10              
11             our $URL_RE = qr
12             {
13             (?:(?:http|ftp|https)\://)? # protocol
14             (?:\w+\:\w+\@)? # username and password
15             (?:(?:www|ftp)\.)? # domain prefixes
16             (?:[-\w]+\.)+ # domain name
17             (?:$DOMAINS_RE) # top level domain
18             (?:\:\d{1,5})? # port number
19             (?:/[-\w~._]*)*? # directories and files
20             (?:\?[^\s#]+?)? # query string no spaces or sharp
21             (?:\#[^\s]+?)? # anchor
22             }x;
23              
24             our $EMAIL_RE = qr
25             {
26             (?:[-\w_~\.]+\@) # user name
27             (?:[-\w]+\.)+ # domain name
28             (?:$DOMAINS_RE) # top level domain
29             }x;
30              
31             #@Override
32             sub filter
33             {
34 18     18 0 28 my $self = shift; # self
35 18         21 my $filter_manager = shift; # filter_manager
36 18         28 my $value = shift; # value
37 18         22 shift; #context
38            
39 18         4992 $value =~ s
40             {
41             (?:($EMAIL_RE)|($URL_RE))
42             ($|\s|\.|,|!) # after link
43             }{
44 20         57 $self->wrap_email($1,$3).$self->wrap_url($2,$3)
45             }gxesi;
46            
47 18         118 $filter_manager->{'safe'} = 1;
48            
49 18         85 return $value;
50             }
51              
52             sub wrap_url
53             {
54 20     20 0 27 my $self = shift;
55 20         42 my $text = shift;
56 20 100       54 return '' if not $text;
57 18   50     56 my $appendix = shift // '';
58            
59 18         26 my $uri = $text;
60 18 100       75 $uri = 'http://'.$uri if
61             $uri !~ m{^(http|ftp|https)://}i;
62            
63 18   50     73 return sprintf '%s%s'
64             , $uri // 'undef'
65             , DTL::Fast::html_protect(unescape($self->normalize_text($text)))
66             , $appendix
67             ;
68             }
69              
70             sub wrap_email
71             {
72 20     20 0 25 my $self = shift;
73 20         40 my $text = shift;
74 20 100       80 return '' if not $text;
75 2   50     10 my $appendix = shift // '';
76            
77 2         5 my $uri = $text;
78            
79 2         10 return sprintf '%s%s'
80             , $uri
81             , DTL::Fast::html_protect(unescape($self->normalize_text($text)))
82             , $appendix
83             ;
84             }
85              
86             sub normalize_text
87             {
88 10     10 0 13 shift;
89 10         185 return shift;
90             }
91              
92             1;