← 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/AuthenticationResults/Header/Base.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::AuthenticationResults::Header::Base::::BEGIN@10Mail::AuthenticationResults::Header::Base::BEGIN@10
0000s0sMail::AuthenticationResults::Header::Base::::BEGIN@12Mail::AuthenticationResults::Header::Base::BEGIN@12
0000s0sMail::AuthenticationResults::Header::Base::::BEGIN@13Mail::AuthenticationResults::Header::Base::BEGIN@13
0000s0sMail::AuthenticationResults::Header::Base::::BEGIN@5Mail::AuthenticationResults::Header::Base::BEGIN@5
0000s0sMail::AuthenticationResults::Header::Base::::BEGIN@6Mail::AuthenticationResults::Header::Base::BEGIN@6
0000s0sMail::AuthenticationResults::Header::Base::::BEGIN@8Mail::AuthenticationResults::Header::Base::BEGIN@8
0000s0sMail::AuthenticationResults::Header::Base::::BEGIN@9Mail::AuthenticationResults::Header::Base::BEGIN@9
0000s0sMail::AuthenticationResults::Header::Base::::_ALLOWED_CHILDRENMail::AuthenticationResults::Header::Base::_ALLOWED_CHILDREN
0000s0sMail::AuthenticationResults::Header::Base::::_HAS_CHILDRENMail::AuthenticationResults::Header::Base::_HAS_CHILDREN
0000s0sMail::AuthenticationResults::Header::Base::::_HAS_KEYMail::AuthenticationResults::Header::Base::_HAS_KEY
0000s0sMail::AuthenticationResults::Header::Base::::_HAS_VALUEMail::AuthenticationResults::Header::Base::_HAS_VALUE
0000s0sMail::AuthenticationResults::Header::Base::::__ANON__Mail::AuthenticationResults::Header::Base::__ANON__ (xsub)
0000s0sMail::AuthenticationResults::Header::Base::::_as_hashrefMail::AuthenticationResults::Header::Base::_as_hashref
0000s0sMail::AuthenticationResults::Header::Base::::add_childMail::AuthenticationResults::Header::Base::add_child
0000s0sMail::AuthenticationResults::Header::Base::::add_parentMail::AuthenticationResults::Header::Base::add_parent
0000s0sMail::AuthenticationResults::Header::Base::::ancestorMail::AuthenticationResults::Header::Base::ancestor
0000s0sMail::AuthenticationResults::Header::Base::::as_jsonMail::AuthenticationResults::Header::Base::as_json
0000s0sMail::AuthenticationResults::Header::Base::::as_stringMail::AuthenticationResults::Header::Base::as_string
0000s0sMail::AuthenticationResults::Header::Base::::as_string_prefixMail::AuthenticationResults::Header::Base::as_string_prefix
0000s0sMail::AuthenticationResults::Header::Base::::build_stringMail::AuthenticationResults::Header::Base::build_string
0000s0sMail::AuthenticationResults::Header::Base::::childrenMail::AuthenticationResults::Header::Base::children
0000s0sMail::AuthenticationResults::Header::Base::::keyMail::AuthenticationResults::Header::Base::key
0000s0sMail::AuthenticationResults::Header::Base::::newMail::AuthenticationResults::Header::Base::new
0000s0sMail::AuthenticationResults::Header::Base::::orphanMail::AuthenticationResults::Header::Base::orphan
0000s0sMail::AuthenticationResults::Header::Base::::parentMail::AuthenticationResults::Header::Base::parent
0000s0sMail::AuthenticationResults::Header::Base::::remove_childMail::AuthenticationResults::Header::Base::remove_child
0000s0sMail::AuthenticationResults::Header::Base::::safe_set_valueMail::AuthenticationResults::Header::Base::safe_set_value
0000s0sMail::AuthenticationResults::Header::Base::::searchMail::AuthenticationResults::Header::Base::search
0000s0sMail::AuthenticationResults::Header::Base::::set_keyMail::AuthenticationResults::Header::Base::set_key
0000s0sMail::AuthenticationResults::Header::Base::::set_valueMail::AuthenticationResults::Header::Base::set_value
0000s0sMail::AuthenticationResults::Header::Base::::stringifyMail::AuthenticationResults::Header::Base::stringify
0000s0sMail::AuthenticationResults::Header::Base::::valueMail::AuthenticationResults::Header::Base::value
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Mail::AuthenticationResults::Header::Base;
2# ABSTRACT: Base class for modelling parts of the Authentication Results Header
3
4require 5.008;
5use strict;
6use warnings;
7our $VERSION = '2.20210112'; # VERSION
8use Scalar::Util qw{ weaken refaddr };
9use JSON;
10use Carp;
11
12use Mail::AuthenticationResults::Header::Group;
13use Mail::AuthenticationResults::FoldableHeader;
14
15
16sub _HAS_KEY{ return 0; }
17sub _HAS_VALUE{ return 0; }
18sub _HAS_CHILDREN{ return 0; }
19sub _ALLOWED_CHILDREN{ # uncoverable subroutine
20 # does not run in Base as HAS_CHILDREN returns 0
21 return 0; # uncoverable statement
22}
23
24
25sub new {
26 my ( $class ) = @_;
27 my $self = {};
28 bless $self, $class;
29 return $self;
30}
31
32
33sub set_key {
34 my ( $self, $key ) = @_;
35 croak 'Does not have key' if ! $self->_HAS_KEY();
36 croak 'Key cannot be undefined' if ! defined $key;
37 croak 'Key cannot be empty' if $key eq q{};
38 croak 'Invalid characters in key' if $key =~ /"/;
39 croak 'Invalid characters in key' if $key =~ /\n/;
40 croak 'Invalid characters in key' if $key =~ /\r/;
41 $self->{ 'key' } = $key;
42 return $self;
43}
44
45
46sub key {
47 my ( $self ) = @_;
48 croak 'Does not have key' if ! $self->_HAS_KEY();
49 return q{} if ! defined $self->{ 'key' }; #5.8
50 return $self->{ 'key' };
51}
52
53
54sub safe_set_value {
55 my ( $self, $value ) = @_;
56
57 $value = q{} if ! defined $value;
58
59 $value =~ s/\t/ /g;
60 $value =~ s/\n/ /g;
61 $value =~ s/\r/ /g;
62 $value =~ s/\(/ /g;
63 $value =~ s/\)/ /g;
64 $value =~ s/\\/ /g;
65 $value =~ s/"/ /g;
66 $value =~ s/;/ /g;
67 $value =~ s/^\s+//;
68 $value =~ s/\s+$//;
69
70 #$value =~ s/ /_/g;
71
72 $self->set_value( $value );
73 return $self;
74}
75
76
77sub set_value {
78 my ( $self, $value ) = @_;
79 croak 'Does not have value' if ! $self->_HAS_VALUE();
80 croak 'Value cannot be undefined' if ! defined $value;
81 #croak 'Value cannot be empty' if $value eq q{};
82 croak 'Invalid characters in value' if $value =~ /"/;
83 croak 'Invalid characters in value' if $value =~ /\n/;
84 croak 'Invalid characters in value' if $value =~ /\r/;
85 $self->{ 'value' } = $value;
86 return $self;
87}
88
89
90sub value {
91 my ( $self ) = @_;
92 croak 'Does not have value' if ! $self->_HAS_VALUE();
93 return q{} if ! defined $self->{ 'value' }; # 5.8
94 return $self->{ 'value' };
95}
96
97
98sub stringify {
99 my ( $self, $value ) = @_;
100 my $string = $value;
101 $string = q{} if ! defined $string; #5.8;
102
103 if ( $string =~ /[\s\t \(\);=]/ ) {
104 $string = '"' . $string . '"';
105 }
106
107 return $string;
108}
109
110
111sub children {
112 my ( $self ) = @_;
113 croak 'Does not have children' if ! $self->_HAS_CHILDREN();
114 return [] if ! defined $self->{ 'children' }; #5.8
115 return $self->{ 'children' };
116}
117
118
119sub orphan {
120 my ( $self, $parent ) = @_;
121 croak 'Child does not have a parent' if ! exists $self->{ 'parent' };
122 delete $self->{ 'parent' };
123 return;
124}
125
126
127sub add_parent {
128 my ( $self, $parent ) = @_;
129 return if ( ref $parent eq 'Mail::AuthenticationResults::Header::Group' );
130 croak 'Child already has a parent' if exists $self->{ 'parent' };
131 croak 'Cannot add parent' if ! $parent->_ALLOWED_CHILDREN( $self ); # uncoverable branch true
132 # Does not run as test is also done in add_child before add_parent is called.
133 $self->{ 'parent' } = $parent;
134 weaken $self->{ 'parent' };
135 return;
136}
137
138
139sub parent {
140 my ( $self ) = @_;
141 return $self->{ 'parent' };
142}
143
144
145sub remove_child {
146 my ( $self, $child ) = @_;
147 croak 'Does not have children' if ! $self->_HAS_CHILDREN();
148 croak 'Cannot add child' if ! $self->_ALLOWED_CHILDREN( $child );
149 croak 'Cannot add a class as its own parent' if refaddr $self == refaddr $child; # uncoverable branch true
150 # Does not run as there are no ALLOWED_CHILDREN results which permit this
151
152 my @children;
153 my $child_removed = 0;
154 foreach my $mychild ( @{ $self->{ 'children' } } ) {
155 if ( refaddr $child == refaddr $mychild ) {
156 if ( ref $self ne 'Mail::AuthenticationResults::Header::Group' ) {
157 $child->orphan();
158 }
159 $child_removed = 1;
160 }
161 else {
162 push @children, $mychild;
163 }
164 }
165 my $children = $self->{ 'children' };
166
167 croak 'Not a child of this class' if ! $child_removed;
168
169 $self->{ 'children' } = \@children;
170
171 return $self;
172}
173
174
175sub add_child {
176 my ( $self, $child ) = @_;
177 croak 'Does not have children' if ! $self->_HAS_CHILDREN();
178 croak 'Cannot add child' if ! $self->_ALLOWED_CHILDREN( $child );
179 croak 'Cannot add a class as its own parent' if refaddr $self == refaddr $child; # uncoverable branch true
180 # Does not run as there are no ALLOWED_CHILDREN results which permit this
181
182 $child->add_parent( $self );
183 push @{ $self->{ 'children' } }, $child;
184
185 return $child;
186}
187
188
189sub ancestor {
190 my ( $self ) = @_;
191
192 my $depth = 0;
193 my $ancestor = $self->parent();
194 my $eldest = $self;
195 while ( defined $ancestor ) {
196 $eldest = $ancestor;
197 $ancestor = $ancestor->parent();
198 $depth++;
199 }
200
201 return ( $eldest, $depth );
202}
203
204
205sub as_string_prefix {
206 my ( $self, $header ) = @_;
207
208 my ( $eldest, $depth ) = $self->ancestor();
209
210 my $indents = 1;
211 if ( $eldest->can( 'indent_by' ) ) {
212 $indents = $eldest->indent_by();
213 }
214
215 my $eol = "\n";
216 if ( $eldest->can( 'eol' ) ) {
217 $eol = $eldest->eol();
218 }
219
220 my $indent = ' ';
221 my $added = 0;
222 if ( $eldest->can( 'indent_on' ) ) {
223 if ( $eldest->indent_on( ref $self ) ) {
224 $header->space( $eol );
225 $header->space( ' ' x ( $indents * $depth ) );
226 $added = 1;
227 }
228 }
229 $header->space( ' ' ) if ! $added;
230
231 return $indent;
232}
233
234sub _as_hashref {
235 my ( $self ) = @_;
236
237 my $type = lc ref $self;
238 $type =~ s/^(.*::)//;
239 my $hashref = { 'type' => $type };
240
241 $hashref->{'key'} = $self->key() if $self->_HAS_KEY();
242 $hashref->{'value'} = $self->value() if $self->_HAS_VALUE();
243 if ( $self->_HAS_CHILDREN() ) {
244 my @children = map { $_->_as_hashref() } @{ $self->children() };
245 $hashref->{'children'} = \@children;
246 }
247 return $hashref;
248}
249
250
251sub as_json {
252 my ( $self ) = @_;
253 my $J = JSON->new();
254 $J->canonical();
255 return $J->encode( $self->_as_hashref() );
256}
257
258
259sub as_string {
260 my ( $self ) = @_;
261 my $header = Mail::AuthenticationResults::FoldableHeader->new();
262 $self->build_string( $header );
263 return $header->as_string();
264}
265
266
267sub build_string {
268 my ( $self, $header ) = @_;
269
270 if ( ! $self->key() ) {
271 return;
272 }
273
274 $header->string( $self->stringify( $self->key() ) );
275 if ( $self->value() ) {
276 $header->assignment( '=' );
277 $header->string( $self->stringify( $self->value() ) );
278 }
279 elsif ( $self->value() eq '0' ) {
280 $header->assignment( '=' );
281 $header->string( '0' );
282 }
283 elsif ( $self->value() eq q{} ) {
284 # special case none here
285 if ( $self->key() ne 'none' ) {
286 $header->assignment( '=' );
287 $header->string( '""' );
288 }
289 }
290 if ( $self->_HAS_CHILDREN() ) { # uncoverable branch false
291 # There are no classes which run this code without having children
292 foreach my $child ( @{$self->children()} ) {
293 $child->as_string_prefix( $header );
294 $child->build_string( $header );
295 }
296 }
297 return;
298}
299
300
301sub search {
302 my ( $self, $search ) = @_;
303
304 my $group = Mail::AuthenticationResults::Header::Group->new();
305
306 my $match = 1;
307
308 if ( exists( $search->{ 'key' } ) ) {
309 if ( $self->_HAS_KEY() ) {
310 if ( ref $search->{ 'key' } eq 'Regexp' && $self->key() =~ m/$search->{'key'}/ ) {
311 $match = $match && 1; # uncoverable statement
312 # $match is always 1 at this point, left this way for consistency
313 }
314 elsif ( lc $search->{ 'key' } eq lc $self->key() ) {
315 $match = $match && 1; # uncoverable statement
316 # $match is always 1 at this point, left this way for consistency
317 }
318 else {
319 $match = 0;
320 }
321 }
322 else {
323 $match = 0;
324 }
325 }
326
327 if ( exists( $search->{ 'value' } ) ) {
328 $search->{ 'value' } = '' if ! defined $search->{ 'value' };
329 if ( $self->_HAS_VALUE() ) {
330 if ( ref $search->{ 'value' } eq 'Regexp' && $self->value() =~ m/$search->{'value'}/ ) {
331 $match = $match && 1;
332 }
333 elsif ( lc $search->{ 'value' } eq lc $self->value() ) {
334 $match = $match && 1;
335 }
336 else {
337 $match = 0;
338 }
339 }
340 else {
341 $match = 0; # uncoverable statement
342 # There are no code paths with the current classes which end up here
343 }
344 }
345
346 if ( exists( $search->{ 'authserv_id' } ) ) {
347 if ( $self->_HAS_VALUE() ) {
348 if ( lc ref $self eq 'mail::authenticationresults::header' ) {
349 my $authserv_id = eval{ $self->value()->value() } || q{};
350 if ( ref $search->{ 'authserv_id' } eq 'Regexp' && $authserv_id =~ m/$search->{'authserv_id'}/ ) {
351 $match = $match && 1;
352 }
353 elsif ( lc $search->{ 'authserv_id' } eq lc $authserv_id ) {
354 $match = $match && 1;
355 }
356 else {
357 $match = 0;
358 }
359 }
360 else {
361 $match = 0;
362 }
363 }
364 else {
365 $match = 0; # uncoverable statement
366 # There are no code paths with the current classes which end up here
367 }
368 }
369
370 if ( exists( $search->{ 'isa' } ) ) {
371 if ( lc ref $self eq 'mail::authenticationresults::header::' . lc $search->{ 'isa' } ) {
372 $match = $match && 1;
373 }
374 elsif ( lc ref $self eq 'mail::authenticationresults::header' && lc $search->{ 'isa' } eq 'header' ) {
375 $match = $match && 1;
376 }
377 else {
378 $match = 0;
379 }
380 }
381
382 if ( exists( $search->{ 'has' } ) ) {
383 foreach my $query ( @{ $search->{ 'has' } } ) {
384 $match = 0 if ( scalar @{ $self->search( $query )->children() } == 0 );
385 }
386 }
387
388 if ( $match ) {
389 $group->add_child( $self );
390 }
391
392 if ( $self->_HAS_CHILDREN() ) {
393 foreach my $child ( @{$self->children()} ) {
394 my $childfound = $child->search( $search );
395 if ( scalar @{ $childfound->children() } ) {
396 $group->add_child( $childfound );
397 }
398 }
399 }
400
401 return $group;
402}
403
4041;
405
406__END__