File Coverage

lib/Mail/DMARC/Report/URI.pm
Criterion Covered Total %
statement 36 40 90.0
branch 16 22 72.7
condition 4 6 66.6
subroutine 7 7 100.0
pod 0 3 0.0
total 63 78 80.7


line stmt bran cond sub pod time code
1             package Mail::DMARC::Report::URI;
2 13     13   887 use strict;
  13         25  
  13         419  
3 13     13   67 use warnings;
  13         25  
  13         523  
4              
5             our $VERSION = '1.20211209';
6              
7 13     13   69 use Carp;
  13         25  
  13         779  
8 13     13   8466 use URI;
  13         66313  
  13         5933  
9              
10             sub new {
11 25     25 0 636 my $class = shift;
12 25         159 return bless {}, $class;
13             }
14              
15             sub parse {
16 52     52 0 2795 my $self = shift;
17 52 50       131 my $str = shift or croak "URI string is required!";
18              
19 52         110 my @valids = ();
20 52         176 foreach my $raw ( split /,/, $str ) {
21             # warn "raw: $raw\n";
22 55         175 my ( $u, $size_f ) = split /!/, $raw;
23 55         154 my $bytes = $self->get_size_limit($size_f);
24 55 50       303 my $uri = URI->new($u) or do {
25 0         0 carp "can't parse URI from $u";
26 0         0 next;
27             };
28 55 50       56607 my $scheme = $uri->scheme or next;
29 55 100 66     1407 if ( $scheme eq 'mailto' && lc substr( $u, 0, 7 ) eq 'mailto:' ) {
30 40         176 push @valids, { max_bytes => $bytes, uri => $uri };
31 40         125 next;
32             }
33 15 100 66     107 if ( $scheme =~ /^http(s)?/x && lc substr( $u, 0, 4 ) eq 'http' ) {
34 7         29 push @valids, { max_bytes => $bytes, uri => $uri };
35 7         21 next;
36             }
37              
38             # print "invalid URI scheme: $scheme in $u\n";
39             # 12.1 Discovery - URI schemes found in "rua" tag that are not implemented by
40             # a Mail Receiver MUST be ignored.
41             }
42 52         185 return \@valids;
43             }
44              
45             sub get_size_limit {
46 61     61 0 3467 my ( $self, $size ) = @_;
47 61 100       177 return 0 if !defined $size; # no limit
48 10 100       55 return $size if $size =~ /^\d+$/; # no units, raw byte count
49              
50             # 6.3 Formal Definition
51             # units are considered to be powers of two; a kilobyte is 2^10, a megabyte is 2^20,
52 9         29 my $unit = lc chop $size;
53 9 100       25 return $size * ( 2**10 ) if 'k' eq $unit;
54 8 100       34 return $size * ( 2**20 ) if 'm' eq $unit;
55 1 50       8 return $size * ( 2**30 ) if 'g' eq $unit;
56 0 0         return $size * ( 2**40 ) if 't' eq $unit;
57 0           croak "unrecognized unit ($unit) in size ($size)";
58             }
59              
60             1;
61              
62             __END__