File Coverage

blib/lib/URI/mailto.pm
Criterion Covered Total %
statement 52 52 100.0
branch 18 20 90.0
condition 4 4 100.0
subroutine 6 6 100.0
pod 1 3 33.3
total 81 85 95.2


line stmt bran cond sub pod time code
1             package URI::mailto; # RFC 2368
2              
3 2     2   14 use strict;
  2         3  
  2         65  
4 2     2   11 use warnings;
  2         12  
  2         101  
5              
6             our $VERSION = '5.19';
7              
8 2     2   396 use parent qw(URI URI::_query);
  2         294  
  2         11  
9              
10             sub to
11             {
12 14     14 0 1536 my $self = shift;
13 14         31 my @old = $self->headers;
14 14 100       48 if (@_) {
15 3         8 my @new = @old;
16             # get rid of any other to: fields
17 3         8 for (my $i = 0; $i < @new; $i += 2) {
18 6 100 100     22 if (lc($new[$i] || '') eq "to") {
19 3         7 splice(@new, $i, 2);
20 3         4 redo;
21             }
22             }
23              
24 3         6 my $to = shift;
25 3 50       6 $to = "" unless defined $to;
26 3         6 unshift(@new, "to" => $to);
27 3         7 $self->headers(@new);
28             }
29 14 100       33 return unless defined wantarray;
30              
31 12         17 my @to;
32 12         23 while (@old) {
33 15         25 my $h = shift @old;
34 15         24 my $v = shift @old;
35 15 100       47 push(@to, $v) if lc($h) eq "to";
36             }
37 12         77 join(",", @to);
38             }
39              
40              
41             sub headers
42             {
43 20     20 0 317 my $self = shift;
44              
45             # The trick is to just treat everything as the query string...
46 20         55 my $opaque = "to=" . $self->opaque;
47 20         50 $opaque =~ s/\?/&/;
48              
49 20 100       52 if (@_) {
50 4         10 my @new = @_;
51              
52             # strip out any "to" fields
53 4         5 my @to;
54 4         9 for (my $i=0; $i < @new; $i += 2) {
55 10 100 100     35 if (lc($new[$i] || '') eq "to") {
56 4         9 push(@to, (splice(@new, $i, 2))[1]); # remove header
57 4         6 redo;
58             }
59             }
60              
61 4         11 my $new = join(",",@to);
62 4         7 $new =~ s/%/%25/g;
63 4         6 $new =~ s/\?/%3F/g;
64 4         11 $self->opaque($new);
65 4 100       11 $self->query_form(@new) if @new;
66             }
67 20 100       44 return unless defined wantarray;
68              
69             # I am lazy today...
70 16         74 URI->new("mailto:?$opaque")->query_form;
71             }
72              
73             # https://datatracker.ietf.org/doc/html/rfc6068#section-5 requires
74             # plus signs (+) not to be turned into spaces
75             sub query_form
76             {
77 17     17 1 29 my $self = shift;
78 17         60 my @fields = $self->SUPER::query_form(@_);
79 17         62 for ( my $i = 0 ; $i < @fields ; $i += 2 ) {
80 16 50       72 if ( $fields[0] eq 'to' ) {
81 16         32 $fields[1] =~ s/ /+/g;
82 16         26 last;
83             }
84             }
85 17         57 return @fields;
86             }
87              
88             1;