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-2022 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.03.
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   615 use vars '$VERSION';
  21         40  
  21         947  
11             $VERSION = '3.012';
12              
13 21     21   111 use base 'Mail::Message::Field::Structured';
  21         36  
  21         2109  
14              
15 21     21   120 use warnings;
  21         42  
  21         488  
16 21     21   89 use strict;
  21         38  
  21         499  
17              
18 21     21   102 use URI;
  21         33  
  21         9267  
19              
20              
21              
22             sub init($)
23 3     3 0 5 { my ($self, $args) = @_;
24              
25 3         6 my ($body, @body);
26 3 50       9 if($body = delete $args->{body})
27 3 50       22 { @body = ref $body eq 'ARRAY' ? @$body : ($body);
28 3 50       6 return () unless @body;
29             }
30              
31 3         50 $self->{MMFU_uris} = [];
32              
33 3 100 66     15 if(@body > 1 || ref $body[0])
    50          
34 2         6 { $self->addURI($_) foreach @body;
35             }
36             elsif(defined $body)
37 1 50       4 { $body = "<$body>\n" unless index($body, '<') >= 0;
38 1         2 $args->{body} = $body;
39             }
40              
41 3         9 $self->SUPER::init($args);
42             }
43              
44             sub parse($)
45 1     1 1 2 { my ($self, $string) = @_;
46 1         7 my @raw = $string =~ m/\<([^>]+)\>/g; # simply ignore all but <>
47 1         4 $self->addURI($_) foreach @raw;
48 1         3 $self;
49             }
50              
51             sub produceBody()
52 3     3 1 6 { my @uris = sort map { $_->as_string } shift->URIs;
  5         21  
53 3         21 local $" = '>, <';
54 3 50       18 @uris ? "<@uris>" : undef;
55             }
56              
57             #------------------------------------------
58              
59              
60             sub addURI(@)
61 5     5 1 7 { my $self = shift;
62 5 100       14 my $uri = ref $_[0] ? shift : URI->new(@_);
63 5 50       1977 push @{$self->{MMFU_uris}}, $uri->canonical if defined $uri;
  5         24  
64 5         591 delete $self->{MMFF_body};
65 5         12 $uri;
66             }
67              
68              
69 6     6 1 1395 sub URIs() { @{shift->{MMFU_uris}} }
  6         26  
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;