← 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:15 2021

Filename/usr/local/lib/perl5/site_perl/Mail/DKIM/Policy.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::Policy::::BEGIN@14Mail::DKIM::Policy::BEGIN@14
0000s0sMail::DKIM::Policy::::BEGIN@2Mail::DKIM::Policy::BEGIN@2
0000s0sMail::DKIM::Policy::::BEGIN@3Mail::DKIM::Policy::BEGIN@3
0000s0sMail::DKIM::Policy::::__ANON__Mail::DKIM::Policy::__ANON__ (xsub)
0000s0sMail::DKIM::Policy::::__ANON__[:32]Mail::DKIM::Policy::__ANON__[:32]
0000s0sMail::DKIM::Policy::::__ANON__[:69]Mail::DKIM::Policy::__ANON__[:69]
0000s0sMail::DKIM::Policy::::applyMail::DKIM::Policy::apply
0000s0sMail::DKIM::Policy::::as_stringMail::DKIM::Policy::as_string
0000s0sMail::DKIM::Policy::::fetchMail::DKIM::Policy::fetch
0000s0sMail::DKIM::Policy::::fetch_asyncMail::DKIM::Policy::fetch_async
0000s0sMail::DKIM::Policy::::is_implied_default_policyMail::DKIM::Policy::is_implied_default_policy
0000s0sMail::DKIM::Policy::::locationMail::DKIM::Policy::location
0000s0sMail::DKIM::Policy::::parseMail::DKIM::Policy::parse
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::Policy;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: abstract base class for originator "signing" policies
6
7# Copyright 2005-2007 Messiah College.
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 Mail::DKIM::DNS;
15
16
17sub fetch {
18 my $class = shift;
19 my $waiter = $class->fetch_async(@_);
20 return $waiter->();
21}
22
23sub fetch_async {
24 my $class = shift;
25 my %prms = @_;
26
27 ( $prms{'Protocol'} eq 'dns' )
28 or die "invalid protocol '$prms{Protocol}'\n";
29
30 my $host = $class->get_lookup_name( \%prms );
31 my %callbacks = %{ $prms{Callbacks} || {} };
32 my $on_success = $callbacks{Success} || sub { $_[0] };
33 $callbacks{Success} = sub {
34 my @resp = @_;
35 unless (@resp) {
36
37 # no requested resource records or NXDOMAIN,
38 # use default policy
39 return $on_success->( $class->default );
40 }
41
42 my $strn;
43 foreach my $rr (@resp) {
44 next unless $rr->type eq 'TXT';
45
46 # join with no intervening spaces, RFC 5617
47 if ( Net::DNS->VERSION >= 0.69 ) {
48
49 # must call txtdata() in a list context
50 $strn = join '', $rr->txtdata;
51 }
52 else {
53 # char_str_list method is 'historical'
54 $strn = join '', $rr->char_str_list;
55 }
56 }
57
58 unless ($strn) {
59
60 # empty record found in DNS, use default policy
61 return $on_success->( $class->default );
62 }
63
64 my $self = $class->parse(
65 String => $strn,
66 Domain => $prms{Domain},
67 );
68 return $on_success->($self);
69 };
70
71 #
72 # perform DNS query for domain policy...
73 #
74 my $waiter =
75 Mail::DKIM::DNS::query_async( $host, 'TXT', Callbacks => \%callbacks, );
76 return $waiter;
77}
78
79sub parse {
80 my $class = shift;
81 my %prms = @_;
82
83 my $text = $prms{'String'};
84 my %tags;
85 foreach my $tag ( split /;/, $text ) {
86
87 # strip whitespace
88 $tag =~ s/^\s+|\s+$//g;
89
90 my ( $tagname, $value ) = split /=/, $tag, 2;
91 unless ( defined $value ) {
92 die "policy syntax error\n";
93 }
94
95 $tagname =~ s/\s+$//;
96 $value =~ s/^\s+//;
97 $tags{$tagname} = $value;
98 }
99
100 $prms{tags} = \%tags;
101 return bless \%prms, $class;
102}
103
104
105sub apply {
106 my $self = shift;
107 my ($dkim) = @_;
108
109 my $first_party;
110 foreach my $signature ( $dkim->signatures ) {
111 next if $signature->result ne 'pass';
112
113 my $oa = $dkim->message_sender->address;
114 if ( $signature->identity_matches($oa) ) {
115
116 # found a first party signature
117 $first_party = 1;
118 last;
119 }
120 }
121
122 return 'accept' if $first_party;
123 return 'reject' if ( $self->signall && !$self->testing );
124 return 'neutral';
125}
126
127
128sub as_string {
129 my $self = shift;
130
131 return join(
132 '; ', map { "$_=" . $self->{tags}->{$_} }
133 keys %{ $self->{tags} }
134 );
135}
136
137
138sub is_implied_default_policy {
139 my $self = shift;
140 my $default_policy = ref($self)->default;
141 return ( $self == $default_policy );
142}
143
144
145sub location {
146 my $self = shift;
147 return $self->{Domain};
148}
149
150
1511;
152
153__END__