← 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/Parser.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::AuthenticationResults::Parser::::BEGIN@10Mail::AuthenticationResults::Parser::BEGIN@10
0000s0sMail::AuthenticationResults::Parser::::BEGIN@11Mail::AuthenticationResults::Parser::BEGIN@11
0000s0sMail::AuthenticationResults::Parser::::BEGIN@12Mail::AuthenticationResults::Parser::BEGIN@12
0000s0sMail::AuthenticationResults::Parser::::BEGIN@13Mail::AuthenticationResults::Parser::BEGIN@13
0000s0sMail::AuthenticationResults::Parser::::BEGIN@14Mail::AuthenticationResults::Parser::BEGIN@14
0000s0sMail::AuthenticationResults::Parser::::BEGIN@15Mail::AuthenticationResults::Parser::BEGIN@15
0000s0sMail::AuthenticationResults::Parser::::BEGIN@17Mail::AuthenticationResults::Parser::BEGIN@17
0000s0sMail::AuthenticationResults::Parser::::BEGIN@18Mail::AuthenticationResults::Parser::BEGIN@18
0000s0sMail::AuthenticationResults::Parser::::BEGIN@19Mail::AuthenticationResults::Parser::BEGIN@19
0000s0sMail::AuthenticationResults::Parser::::BEGIN@20Mail::AuthenticationResults::Parser::BEGIN@20
0000s0sMail::AuthenticationResults::Parser::::BEGIN@21Mail::AuthenticationResults::Parser::BEGIN@21
0000s0sMail::AuthenticationResults::Parser::::BEGIN@5Mail::AuthenticationResults::Parser::BEGIN@5
0000s0sMail::AuthenticationResults::Parser::::BEGIN@6Mail::AuthenticationResults::Parser::BEGIN@6
0000s0sMail::AuthenticationResults::Parser::::BEGIN@8Mail::AuthenticationResults::Parser::BEGIN@8
0000s0sMail::AuthenticationResults::Parser::::__ANON__Mail::AuthenticationResults::Parser::__ANON__ (xsub)
0000s0sMail::AuthenticationResults::Parser::::_parse_authservidMail::AuthenticationResults::Parser::_parse_authservid
0000s0sMail::AuthenticationResults::Parser::::_parse_entryMail::AuthenticationResults::Parser::_parse_entry
0000s0sMail::AuthenticationResults::Parser::::newMail::AuthenticationResults::Parser::new
0000s0sMail::AuthenticationResults::Parser::::parseMail::AuthenticationResults::Parser::parse
0000s0sMail::AuthenticationResults::Parser::::parsedMail::AuthenticationResults::Parser::parsed
0000s0sMail::AuthenticationResults::Parser::::tokeniseMail::AuthenticationResults::Parser::tokenise
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::Parser;
2# ABSTRACT: Class for parsing Authentication Results Headers
3
4require 5.008;
5use strict;
6use warnings;
7our $VERSION = '2.20210112'; # VERSION
8use Carp;
9
10use Mail::AuthenticationResults::Header;
11use Mail::AuthenticationResults::Header::AuthServID;
12use Mail::AuthenticationResults::Header::Comment;
13use Mail::AuthenticationResults::Header::Entry;
14use Mail::AuthenticationResults::Header::SubEntry;
15use Mail::AuthenticationResults::Header::Version;
16
17use Mail::AuthenticationResults::Token::Assignment;
18use Mail::AuthenticationResults::Token::Comment;
19use Mail::AuthenticationResults::Token::QuotedString;
20use Mail::AuthenticationResults::Token::Separator;
21use Mail::AuthenticationResults::Token::String;
22
23
24sub new {
25 my ( $class, $auth_header ) = @_;
26 my $self = {};
27 bless $self, $class;
28
29 if ( $auth_header ) {
30 $self->parse( $auth_header );
31 }
32
33 return $self;
34}
35
36
37sub parse {
38 my ( $self, $header ) = @_;
39
40 $self->tokenise( $header );
41
42 $self->_parse_authservid();
43
44 while ( @{ $self->{ 'tokenised' } } ) {
45 $self->_parse_entry();
46 }
47
48 return $self->parsed();
49}
50
51
52sub tokenise {
53 my ( $self, $header ) = @_;
54
55 my @tokenised;
56
57 $header =~ s/\n/ /g;
58 $header =~ s/\r/ /g;
59 $header =~ s/^\s+//;
60
61 # Remove Header part if present
62 if ( $header =~ /^Authentication-Results:/i ) {
63 $header =~ s/^Authentication-Results://i;
64 }
65
66 my $args = {};
67 while ( length($header) > 0 ) {
68
69 my $token;
70 $header =~ s/^\s+//;
71
72 my $last_non_comment_type = exists( $args->{ 'last_non_comment_type' } ) ? $args->{ 'last_non_comment_type' }->is() : 'none';
73
74 if ( length( $header ) == 0 ) {
75 last;
76 }
77 elsif ( $header =~ /^\(/ ) {
78 $token = Mail::AuthenticationResults::Token::Comment->new( $header, $args );
79 }
80 elsif ( $header =~ /^;/ ) {
81 $token = Mail::AuthenticationResults::Token::Separator->new( $header, $args );
82 $args->{ 'last_non_comment_type' } = $token;
83 }
84 elsif ( $header =~ /^"/ ) {
85 $token = Mail::AuthenticationResults::Token::QuotedString->new( $header, $args );
86 $args->{ 'last_non_comment_type' } = $token;
87 }
88 elsif ( $last_non_comment_type ne 'assignment' && $header =~ /^\./ ) {
89 $token = Mail::AuthenticationResults::Token::Assignment->new( $header, $args );
90 $args->{ 'last_non_comment_type' } = $token;
91 }
92 elsif ( $last_non_comment_type eq 'assignment' && $header =~ /^\./ ) {
93 # a . after an assignment cannot be another assignment, likely an unquoted string.
94 $token = Mail::AuthenticationResults::Token::String->new( $header, $args );
95 $args->{ 'last_non_comment_type' } = $token;
96 }
97 elsif ( $header =~ /^\// ) {
98 $token = Mail::AuthenticationResults::Token::Assignment->new( $header, $args );
99 $args->{ 'last_non_comment_type' } = $token;
100 }
101 elsif ( $header =~ /^=/ ) {
102 $token = Mail::AuthenticationResults::Token::Assignment->new( $header, $args );
103 $args->{ 'last_non_comment_type' } = $token;
104 }
105 else {
106 $token = Mail::AuthenticationResults::Token::String->new( $header, $args );
107 $args->{ 'last_non_comment_type' } = $token;
108 }
109
110 $header = $token->remainder();
111 push @tokenised, $token;
112 }
113
114 croak 'Nothing to parse' if ! @tokenised;
115
116 $self->{ 'tokenised' } = \@tokenised;
117
118 return;
119}
120
121sub _parse_authservid {
122 my ( $self ) = @_;
123 my $tokenised = $self->{ 'tokenised' };
124 my $token;
125
126 my $authserv_id = Mail::AuthenticationResults::Header::AuthServID->new();
127
128 # Find the ServID
129 while ( @$tokenised ) {
130 $token = shift @$tokenised;
131 if ( $token->is() eq 'string' ) {
132 $authserv_id->set_value( $token->value() );
133 last;
134 }
135 elsif ( $token->is() eq 'comment' ) {
136 $authserv_id->add_child( Mail::AuthenticationResults::Header::Comment->new()->set_value( $token->value() ) );
137 }
138 else {
139 # assignment or separator, both are bogus
140 croak 'Invalid AuthServ-ID';
141 }
142 }
143
144 my $expecting = 'key';
145 my $key;
146
147 TOKEN:
148 while ( @$tokenised ) {
149 $token = shift @$tokenised;
150
151 if ( $token->is() eq 'assignment' ) {
152 if ( $expecting eq 'assignment' ) {
153 if ( $token->value() eq '=' ) {
154 $expecting = 'value';
155 }
156 else {
157 croak 'unexpected token';
158 }
159 }
160 else {
161 croak 'not expecting an assignment';
162 }
163 }
164 elsif ( $token->is() eq 'comment' ) {
165 $authserv_id->add_child( Mail::AuthenticationResults::Header::Comment->new()->set_value( $token->value() ) );
166 }
167 elsif ( $token->is() eq 'separator' ) {
168 last TOKEN;
169 }
170 if ( $token->is() eq 'string' ) {
171 if ( $expecting eq 'key' ) {
172 $key = $token;
173 $expecting = 'assignment';
174 }
175 elsif ( $expecting eq 'value' ) {
176 $authserv_id->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( $key->value() )->set_value( $token->value() ) );
177 $expecting = 'key';
178 undef $key;
179 }
180 else {
181 croak 'not expecting a string';
182 }
183 }
184
185 }
186 if ( $expecting ne 'key' ) {
187 if ( $key->value() =~ /^[0-9]+$/ ) {
188 # Looks like a version
189 $authserv_id->add_child( Mail::AuthenticationResults::Header::Version->new()->set_value( $key->value() ) );
190 }
191 else {
192 # Probably bogus, but who knows!
193 $authserv_id->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( $key->value() ) );
194 }
195 }
196
197 $self->{ 'header' } = Mail::AuthenticationResults::Header->new()->set_value( $authserv_id );
198 $self->{ 'tokenised' } = $tokenised;
199
200 return;
201}
202
203sub _parse_entry {
204 my ( $self ) = @_;
205 my $tokenised = $self->{ 'tokenised' };
206
207 my $entry = Mail::AuthenticationResults::Header::Entry->new();
208 my $working_on = $entry;
209
210 my $expecting = 'key';
211 my $is_subentry = 0;
212 TOKEN:
213 while ( @$tokenised ) {
214 my $token = shift @$tokenised;
215
216 if ( $token->is() eq 'assignment' ) {
217 if ( $expecting eq 'assignment' ) {
218 if ( $token->value() eq '=' ) {
219 $expecting = 'value';
220 }
221 elsif ( $token->value() eq '.' ) {
222 $expecting = 'keymod';
223 }
224 elsif ( $token->value() eq '/' ) {
225 $expecting = 'version';
226 }
227 }
228 else {
229 croak 'not expecting an assignment';
230 }
231 }
232 elsif ( $token->is() eq 'comment' ) {
233 $working_on->add_child( Mail::AuthenticationResults::Header::Comment->new()->set_value( $token->value() ) );
234 }
235 elsif ( $token->is() eq 'separator' ) {
236 last TOKEN;
237 }
238 if ( $token->is() eq 'string' ) {
239 if ( $expecting eq 'key' ) {
240 if ( ! $is_subentry ) {
241 if ( $token->value() eq 'none' ) {
242 # Special case the none
243 $expecting = 'no_more_after_none';
244 }
245 else {
246 $entry->set_key( $token->value() );
247 $expecting = 'assignment';
248 }
249 }
250 else {
251 $working_on = Mail::AuthenticationResults::Header::SubEntry->new()->set_key( $token->value() );
252 $expecting = 'assignment';
253 }
254 }
255 elsif ( $expecting eq 'keymod' ) {
256 $working_on->set_key( $working_on->key() . '.' . $token->value() );
257 $expecting = 'assignment';
258 }
259 elsif ( $expecting eq 'version' ) {
260 if ( $token->value() =~ /^[0-9]+$/ ) {
261 # Looks like a version
262 $working_on->add_child( Mail::AuthenticationResults::Header::Version->new()->set_value( $token->value() ) );
263 }
264 else {
265 croak 'bad version token';
266 }
267 $expecting = 'assignment';
268 }
269 elsif ( $expecting eq 'value' ) {
270 if ( ! $is_subentry ) {
271 $entry->set_value( $token->value() );
272 $is_subentry = 1;
273 }
274 else {
275 $entry->add_child( $working_on->set_value( $token->value() ) );
276 }
277 $expecting = 'key';
278 }
279 else {
280 croak 'not expecting a string';
281 }
282 }
283
284 }
285
286 if ( $expecting eq 'no_more_after_none' ) {
287 $self->{ 'tokenised' } = $tokenised;
288 # We may have comment entries, if so add those to the header object
289 foreach my $child ( @{ $entry->children() } ) {
290 delete $child->{ 'parent' };
291 $self->{ 'header' }->add_child( $child );
292 }
293 return;
294 }
295
296 if ( $expecting ne 'key' ) {
297 if ( $is_subentry ) {
298 $entry->add_child( $working_on );
299 }
300 }
301
302 $self->{ 'header' }->add_child( $entry );
303 $self->{ 'tokenised' } = $tokenised;
304
305 return;
306}
307
308
309sub parsed {
310 my ( $self ) = @_;
311 return $self->{ 'header' };
312}
313
3141;
315
316__END__