File Coverage

blib/lib/Mail/Message/Field/URIs.pm
Criterion Covered Total %
statement 42 45 93.3
branch 11 18 61.1
condition 2 3 66.6
subroutine 10 11 90.9
pod 5 6 83.3
total 70 83 84.3


line stmt bran cond sub pod time code
1             # Copyrights 2001-2021 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of distribution Mail-Message. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Mail::Message::Field::URIs;
10 21     21   856 use vars '$VERSION';
  21         49  
  21         1179  
11             $VERSION = '3.011';
12              
13 21     21   147 use base 'Mail::Message::Field::Structured';
  21         46  
  21         2778  
14              
15 21     21   149 use warnings;
  21         65  
  21         672  
16 21     21   144 use strict;
  21         57  
  21         576  
17              
18 21     21   147 use URI;
  21         80  
  21         11355  
19              
20              
21              
22             sub init($)
23 3     3 0 7 { my ($self, $args) = @_;
24              
25 3         5 my ($body, @body);
26 3 50       12 if($body = delete $args->{body})
27 3 50       29 { @body = ref $body eq 'ARRAY' ? @$body : ($body);
28 3 50       8 return () unless @body;
29             }
30              
31 3         59 $self->{MMFU_uris} = [];
32              
33 3 100 66     21 if(@body > 1 || ref $body[0])
    50          
34 2         8 { $self->addURI($_) foreach @body;
35             }
36             elsif(defined $body)
37 1 50       5 { $body = "<$body>\n" unless index($body, '<') >= 0;
38 1         3 $args->{body} = $body;
39             }
40              
41 3         13 $self->SUPER::init($args);
42             }
43              
44             sub parse($)
45 1     1 1 3 { my ($self, $string) = @_;
46 1         9 my @raw = $string =~ m/\<([^>]+)\>/g; # simply ignore all but <>
47 1         6 $self->addURI($_) foreach @raw;
48 1         3 $self;
49             }
50              
51             sub produceBody()
52 3     3 1 9 { my @uris = sort map { $_->as_string } shift->URIs;
  5         27  
53 3         25 local $" = '>, <';
54 3 50       24 @uris ? "<@uris>" : undef;
55             }
56              
57             #------------------------------------------
58              
59              
60             sub addURI(@)
61 5     5 1 12 { my $self = shift;
62 5 100       21 my $uri = ref $_[0] ? shift : URI->new(@_);
63 5 50       1810 push @{$self->{MMFU_uris}}, $uri->canonical if defined $uri;
  5         28  
64 5         748 delete $self->{MMFF_body};
65 5         16 $uri;
66             }
67              
68              
69 6     6 1 1677 sub URIs() { @{shift->{MMFU_uris}} }
  6         32  
70              
71              
72             sub addAttribute($;@)
73 0     0 1   { my $self = shift;
74 0           $self->log(ERROR => 'No attributes for URI fields.');
75 0           $self;
76             }
77              
78             #------------------------------------------
79              
80              
81             1;