← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:14 2021

Filename/usr/local/lib/perl5/site_perl/Mail/DKIM/KeyValueList.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::KeyValueList::::BEGIN@14Mail::DKIM::KeyValueList::BEGIN@14
0000s0sMail::DKIM::KeyValueList::::BEGIN@2Mail::DKIM::KeyValueList::BEGIN@2
0000s0sMail::DKIM::KeyValueList::::BEGIN@3Mail::DKIM::KeyValueList::BEGIN@3
0000s0sMail::DKIM::KeyValueList::::as_stringMail::DKIM::KeyValueList::as_string
0000s0sMail::DKIM::KeyValueList::::cloneMail::DKIM::KeyValueList::clone
0000s0sMail::DKIM::KeyValueList::::get_tagMail::DKIM::KeyValueList::get_tag
0000s0sMail::DKIM::KeyValueList::::newMail::DKIM::KeyValueList::new
0000s0sMail::DKIM::KeyValueList::::parseMail::DKIM::KeyValueList::parse
0000s0sMail::DKIM::KeyValueList::::set_tagMail::DKIM::KeyValueList::set_tag
0000s0sMail::DKIM::KeyValueList::::wrapMail::DKIM::KeyValueList::wrap
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Mail::DKIM::KeyValueList;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: Represents a Key/Value list
6
7# Copyright 2005-2007 Messiah College. All rights reserved.
8# Jason Long <jlong@messiah.edu>
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
14use Carp;
15
16sub new {
17 my $class = shift;
18 my %args = @_;
19
20 my $self = bless \%args, $class;
21 return $self;
22}
23
24sub parse {
25 my $self_or_class = shift;
26 croak 'wrong number of arguments' unless ( @_ == 1 );
27 my ($string) = @_;
28
29 my $self = ref($self_or_class) ? $self_or_class : $self_or_class->new;
30
31 $self->{tags} = [];
32 $self->{tags_by_name} = {};
33 foreach my $raw_tag ( split /;/, $string, -1 ) {
34 my $tag = { raw => $raw_tag };
35 push @{ $self->{tags} }, $tag;
36
37 # strip preceding and trailing whitespace
38 $raw_tag =~ s/^\s+|\s*$//g;
39
40 next if ( $raw_tag eq '' );
41
42 my ( $tagname, $value ) = split( /\s*=\s*/, $raw_tag, 2 );
43 unless ( defined $value ) {
44 die "syntax error\n";
45 }
46
47 $tag->{name} = $tagname;
48 $tag->{value} = $value;
49
50 $self->{tags_by_name}->{$tagname} = $tag;
51 }
52
53 return $self;
54}
55
56sub clone {
57 my $self = shift;
58 my $str = $self->as_string;
59 return ref($self)->parse($str);
60}
61
62sub get_tag {
63 my $self = shift;
64 my ($tagname) = @_;
65
66 if ( $self->{tags_by_name}->{$tagname} ) {
67 return $self->{tags_by_name}->{$tagname}->{value};
68 }
69 return undef;
70}
71
72sub set_tag {
73 my $self = shift;
74 my ( $tagname, $value ) = @_;
75
76 if ( $tagname =~ /[;=\015\012\t ]/ ) {
77 croak 'invalid tag name';
78 }
79
80 if ( defined $value ) {
81 if ( $value =~ /;/ ) {
82 croak 'invalid tag value';
83 }
84 if ( $value =~ /\015\012[^\t ]/ ) {
85 croak 'invalid tag value';
86 }
87
88 if ( $self->{tags_by_name}->{$tagname} ) {
89 $self->{tags_by_name}->{$tagname}->{value} = $value;
90 my ( $rawname, $rawvalue ) =
91 split( /=/, $self->{tags_by_name}->{$tagname}->{raw}, 2 );
92 $self->{tags_by_name}->{$tagname}->{raw} = "$rawname=$value";
93 }
94 else {
95 my $tag = {
96 name => $tagname,
97 value => $value,
98 raw => " $tagname=$value"
99 };
100 push @{ $self->{tags} }, $tag;
101 $self->{tags_by_name}->{$tagname} = $tag;
102 }
103 }
104 else {
105 if ( $self->{tags_by_name}->{$tagname} ) {
106 delete $self->{tags_by_name}->{$tagname};
107 }
108 @{ $self->{tags} } = grep { $_->{name} ne $tagname } @{ $self->{tags} };
109 }
110}
111
112sub as_string {
113 my $self = shift;
114 if ($Mail::DKIM::SORTTAGS) {
115 return join( ';', sort map { $_->{raw} } @{ $self->{tags} } );
116 }
117 return join( ';', map { $_->{raw} } @{ $self->{tags} } );
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
126sub wrap {
127 my $self = shift;
128 my %args = @_;
129
130 my $TEXTWRAP_CLASS = 'Mail::DKIM::TextWrap';
131 return unless ( UNIVERSAL::can( $TEXTWRAP_CLASS, 'new' ) );
132
133 my $result = '';
134 my $wrap = $TEXTWRAP_CLASS->new(
135 Output => \$result,
136 Separator => $args{Insert} || "\015\012\t",
137 Margin => $args{Margin} || 72,
138 cur => $args{Start} || 0,
139 );
140 my $did_first;
141 foreach my $tag ( @{ $self->{tags} } ) {
142 my $tagname = $tag->{name};
143 my $tagtype = $args{Tags}->{$tagname} || $args{Default} || '';
144
145 $wrap->{Break} = undef;
146 $wrap->{BreakBefore} = undef;
147 $did_first ? $wrap->add(';') : ( $did_first = 1 );
148
149 my ( $raw_name, $raw_value ) = split( /=/, $tag->{raw}, 2 );
150 unless ( $args{PreserveNames} ) {
151 $wrap->flush; #allow a break before the tag name
152 $raw_name =~ s/^\s*/ /;
153 $raw_name =~ s/\s+$//;
154 }
155 $wrap->add( $raw_name . '=' );
156
157 if ( $tagtype eq 'b64' ) {
158 $raw_value =~ s/\s+//gs; #removes all whitespace
159 $wrap->flush;
160 $wrap->{Break} = qr/./;
161 }
162 elsif ( $tagtype eq 'list' ) {
163 $raw_value =~ s/\s+/ /gs; #reduces any whitespace to single space
164 $raw_value =~ s/^\s|\s$//g; #trims preceding/trailing spaces
165 $raw_value =~ s/\s*:\s*/:/g;
166 $wrap->flush;
167 $wrap->{Break} = qr/[\s]/;
168 $wrap->{BreakBefore} = qr/[:]/;
169 }
170 elsif ( $tagtype eq '' ) {
171 $raw_value =~ s/\s+/ /gs; #reduces any whitespace to single space
172 $raw_value =~ s/^\s|\s$//g; #trims preceding/trailing spaces
173 $wrap->flush;
174 $wrap->{Break} = qr/\s/;
175 }
176 $wrap->add($raw_value);
177 }
178
179 $wrap->finish;
180 parse( $self, $result );
181 return;
182}
183
1841;
185
186__END__