File Coverage

blib/lib/Mail/DKIM/KeyValueList.pm
Criterion Covered Total %
statement 101 109 92.6
branch 31 36 86.1
condition 5 8 62.5
subroutine 9 10 90.0
pod 0 7 0.0
total 146 170 85.8


line stmt bran cond sub pod time code
1             package Mail::DKIM::KeyValueList;
2 14     14   110 use strict;
  14         30  
  14         374  
3 14     14   72 use warnings;
  14         37  
  14         534  
4             our $VERSION = '1.20230212'; # VERSION
5             # ABSTRACT: Represents a Key/Value list
6              
7             # Copyright 2005-2007 Messiah College. All rights reserved.
8             # Jason Long
9              
10             # Copyright (c) 2004 Anthony D. Urso. All rights reserved.
11             # This program is free software; you can redistribute it and/or
12             # modify it under the same terms as Perl itself.
13              
14 14     14   77 use Carp;
  14         36  
  14         20133  
15              
16             sub new {
17 0     0 0 0 my $class = shift;
18 0         0 my %args = @_;
19              
20 0         0 my $self = bless \%args, $class;
21 0         0 return $self;
22             }
23              
24             sub parse {
25 1246     1246 0 2121 my $self_or_class = shift;
26 1246 50       3054 croak 'wrong number of arguments' unless ( @_ == 1 );
27 1246         2318 my ($string) = @_;
28              
29 1246 100       3877 my $self = ref($self_or_class) ? $self_or_class : $self_or_class->new;
30              
31 1246         2940 $self->{tags} = [];
32 1246         3385 $self->{tags_by_name} = {};
33 1246         5649 foreach my $raw_tag ( split /;/, $string, -1 ) {
34 8221         16264 my $tag = { raw => $raw_tag };
35 8221         12063 push @{ $self->{tags} }, $tag;
  8221         14525  
36              
37             # strip preceding and trailing whitespace
38 8221         74788 $raw_tag =~ s/^\s+|\s*$//g;
39              
40 8221 100       17402 next if ( $raw_tag eq '' );
41              
42 8207         27222 my ( $tagname, $value ) = split( /\s*=\s*/, $raw_tag, 2 );
43 8207 100       17118 unless ( defined $value ) {
44 4         51 die "syntax error\n";
45             }
46              
47 8203         14906 $tag->{name} = $tagname;
48 8203         12328 $tag->{value} = $value;
49              
50 8203         17126 $self->{tags_by_name}->{$tagname} = $tag;
51             }
52              
53 1242         3817 return $self;
54             }
55              
56             sub clone {
57 411     411 0 601 my $self = shift;
58 411         910 my $str = $self->as_string;
59 411         1489 return ref($self)->parse($str);
60             }
61              
62             sub get_tag {
63 24099     24099 0 32280 my $self = shift;
64 24099         36907 my ($tagname) = @_;
65              
66 24099 100       49171 if ( $self->{tags_by_name}->{$tagname} ) {
67 16457         40813 return $self->{tags_by_name}->{$tagname}->{value};
68             }
69 7642         17045 return undef;
70             }
71              
72             sub set_tag {
73 5904     5904 0 8250 my $self = shift;
74 5904         11692 my ( $tagname, $value ) = @_;
75              
76 5904 50       13845 if ( $tagname =~ /[;=\015\012\t ]/ ) {
77 0         0 croak 'invalid tag name';
78             }
79              
80 5904 100       10083 if ( defined $value ) {
81 2666 50       5590 if ( $value =~ /;/ ) {
82 0         0 croak 'invalid tag value';
83             }
84 2666 50       5027 if ( $value =~ /\015\012[^\t ]/ ) {
85 0         0 croak 'invalid tag value';
86             }
87              
88 2666 100       6205 if ( $self->{tags_by_name}->{$tagname} ) {
89 362         808 $self->{tags_by_name}->{$tagname}->{value} = $value;
90             my ( $rawname, $rawvalue ) =
91 362         1177 split( /=/, $self->{tags_by_name}->{$tagname}->{raw}, 2 );
92 362         1230 $self->{tags_by_name}->{$tagname}->{raw} = "$rawname=$value";
93             }
94             else {
95 2304         8469 my $tag = {
96             name => $tagname,
97             value => $value,
98             raw => " $tagname=$value"
99             };
100 2304         3648 push @{ $self->{tags} }, $tag;
  2304         5189  
101 2304         6398 $self->{tags_by_name}->{$tagname} = $tag;
102             }
103             }
104             else {
105 3238 50       6516 if ( $self->{tags_by_name}->{$tagname} ) {
106 0         0 delete $self->{tags_by_name}->{$tagname};
107             }
108 3238         4372 @{ $self->{tags} } = grep { $_->{name} ne $tagname } @{ $self->{tags} };
  3238         8214  
  4638         10467  
  3238         5889  
109             }
110             }
111              
112             sub as_string {
113 911     911 0 1532 my $self = shift;
114 911 100       1885 if ($Mail::DKIM::SORTTAGS) {
115 96         149 return join( ';', sort map { $_->{raw} } @{ $self->{tags} } );
  736         2091  
  96         203  
116             }
117 815         1226 return join( ';', map { $_->{raw} } @{ $self->{tags} } );
  6583         16579  
  815         1705  
118             }
119              
120             # Start - length of the signature's prefix
121             # Margin - how far to the right the text can go
122             # Insert - characters to insert when wrapping a line
123             # Tags - special processing for tags
124             # Default - how to handle unspecified tags
125             # PreserveNames - if set, the name= part of the tag will be preserved
126             sub wrap {
127 123     123 0 215 my $self = shift;
128 123         386 my %args = @_;
129              
130 123         249 my $TEXTWRAP_CLASS = 'Mail::DKIM::TextWrap';
131 123 100       969 return unless ( UNIVERSAL::can( $TEXTWRAP_CLASS, 'new' ) );
132              
133 3         7 my $result = '';
134             my $wrap = $TEXTWRAP_CLASS->new(
135             Output => \$result,
136             Separator => $args{Insert} || "\015\012\t",
137             Margin => $args{Margin} || 72,
138 3   50     38 cur => $args{Start} || 0,
      50        
      50        
139             );
140 3         8 my $did_first;
141 3         6 foreach my $tag ( @{ $self->{tags} } ) {
  3         11  
142 20         32 my $tagname = $tag->{name};
143 20   100     82 my $tagtype = $args{Tags}->{$tagname} || $args{Default} || '';
144              
145 20         39 $wrap->{Break} = undef;
146 20         29 $wrap->{BreakBefore} = undef;
147 20 100       65 $did_first ? $wrap->add(';') : ( $did_first = 1 );
148              
149 20         54 my ( $raw_name, $raw_value ) = split( /=/, $tag->{raw}, 2 );
150 20 100       44 unless ( $args{PreserveNames} ) {
151 6         19 $wrap->flush; #allow a break before the tag name
152 6         20 $raw_name =~ s/^\s*/ /;
153 6         29 $raw_name =~ s/\s+$//;
154             }
155 20         70 $wrap->add( $raw_name . '=' );
156              
157 20 100       56 if ( $tagtype eq 'b64' ) {
    100          
    100          
158 3         26 $raw_value =~ s/\s+//gs; #removes all whitespace
159 3         17 $wrap->flush;
160 3         11 $wrap->{Break} = qr/./;
161             }
162             elsif ( $tagtype eq 'list' ) {
163 1         9 $raw_value =~ s/\s+/ /gs; #reduces any whitespace to single space
164 1         13 $raw_value =~ s/^\s|\s$//g; #trims preceding/trailing spaces
165 1         10 $raw_value =~ s/\s*:\s*/:/g;
166 1         4 $wrap->flush;
167 1         3 $wrap->{Break} = qr/[\s]/;
168 1         4 $wrap->{BreakBefore} = qr/[:]/;
169             }
170             elsif ( $tagtype eq '' ) {
171 4         16 $raw_value =~ s/\s+/ /gs; #reduces any whitespace to single space
172 4         19 $raw_value =~ s/^\s|\s$//g; #trims preceding/trailing spaces
173 4         13 $wrap->flush;
174 4         15 $wrap->{Break} = qr/\s/;
175             }
176 20         45 $wrap->add($raw_value);
177             }
178              
179 3         12 $wrap->finish;
180 3         7 parse( $self, $result );
181 3         26 return;
182             }
183              
184             1;
185              
186             __END__