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

Filename/usr/local/lib/perl5/site_perl/Mail/Field.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::Field::::AUTOLOADMail::Field::AUTOLOAD
0000s0sMail::Field::::BEGIN@10Mail::Field::BEGIN@10
0000s0sMail::Field::::BEGIN@14Mail::Field::BEGIN@14
0000s0sMail::Field::::BEGIN@145Mail::Field::BEGIN@145
0000s0sMail::Field::::BEGIN@16Mail::Field::BEGIN@16
0000s0sMail::Field::::BEGIN@17Mail::Field::BEGIN@17
0000s0sMail::Field::::BEGIN@99Mail::Field::BEGIN@99
0000s0sMail::Field::::CORE:closedirMail::Field::CORE:closedir (opcode)
0000s0sMail::Field::::CORE:ftdirMail::Field::CORE:ftdir (opcode)
0000s0sMail::Field::::CORE:matchMail::Field::CORE:match (opcode)
0000s0sMail::Field::::CORE:open_dirMail::Field::CORE:open_dir (opcode)
0000s0sMail::Field::::CORE:readdirMail::Field::CORE:readdir (opcode)
0000s0sMail::Field::::CORE:substMail::Field::CORE:subst (opcode)
0000s0sMail::Field::::CORE:substcontMail::Field::CORE:substcont (opcode)
0000s0sMail::Field::::DESTROYMail::Field::DESTROY
0000s0sMail::Field::::__ANON__Mail::Field::__ANON__ (xsub)
0000s0sMail::Field::::__ANON__[:104]Mail::Field::__ANON__[:104]
0000s0sMail::Field::::__ANON__[:147]Mail::Field::__ANON__[:147]
0000s0sMail::Field::::_buildMail::Field::_build
0000s0sMail::Field::::_header_pkg_nameMail::Field::_header_pkg_name
0000s0sMail::Field::::_require_dirMail::Field::_require_dir
0000s0sMail::Field::::combineMail::Field::combine
0000s0sMail::Field::::createMail::Field::create
0000s0sMail::Field::::extractMail::Field::extract
0000s0sMail::Field::::importMail::Field::import
0000s0sMail::Field::::newMail::Field::new
0000s0sMail::Field::::parseMail::Field::parse
0000s0sMail::Field::::registerMail::Field::register
0000s0sMail::Field::::setMail::Field::set
0000s0sMail::Field::::stringifyMail::Field::stringify
0000s0sMail::Field::::tagMail::Field::tag
0000s0sMail::Field::::textMail::Field::text
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# Copyrights 1995-2019 by [Mark Overmeer <markov@cpan.org>].
2# For other contributors see ChangeLog.
3# See the manual pages for details on the licensing terms.
4# Pod stripped from pm file by OODoc 2.02.
5# This code is part of the bundle MailTools. Meta-POD processed with
6# OODoc into POD and HTML manual-pages. See README.md for Copyright.
7# Licensed under the same terms as Perl itself.
8
9package Mail::Field;
10use vars '$VERSION';
11$VERSION = '2.21';
12
13
14use strict;
15
16use Carp;
17use Mail::Field::Generic;
18
19
20sub _header_pkg_name
21{ my $header = lc shift;
22 $header =~ s/((\b|_)\w)/\U$1/g;
23
24 if(length($header) > 8)
25 { my @header = split /[-_]+/, $header;
26 my $chars = int((7 + @header) / @header) || 1;
27 $header = substr join('', map {substr $_,0,$chars} @header), 0, 8;
28 }
29 else
30 { $header =~ s/[-_]+//g;
31 }
32
33 'Mail::Field::' . $header;
34}
35
36sub _require_dir
37{ my($class, $dir, $dir_sep) = @_;
38
39 local *DIR;
40 opendir DIR, $dir
41 or return;
42
43 my @inc;
44 foreach my $f (readdir DIR)
45 { $f =~ /^([\w\-]+)/ or next;
46 my $p = $1;
47 my $n = "$dir$dir_sep$p";
48
49 if(-d $n )
50 { _require_dir("${class}::$f", $n, $dir_sep);
51 }
52 else
53 { $p =~ s/-/_/go;
54 eval "require ${class}::$p";
# spent 0s executing statements in 18 string evals (merged) # spent 0s executing statements in 18 string evals (merged) # spent 0s executing statements in 18 string evals (merged)
55
56 # added next warning in 2.14, may be ignored for ancient code
57 warn $@ if $@;
58 }
59 }
60 closedir DIR;
61}
62
63sub import
64{ my $class = shift;
65
66 if(@_)
67 { local $_;
68 eval "require " . _header_pkg_name($_) || die $@
69 for @_;
70 return;
71 }
72
73 my ($dir, $dir_sep);
74 foreach my $f (grep defined $INC{$_}, keys %INC)
75 { next if $f !~ /^Mail(\W)Field\W/i;
76 $dir_sep = $1;
77# $dir = ($INC{$f} =~ /(.*Mail\W+Field)/i)[0] . $dir_sep;
78 ($dir = $INC{$f}) =~ s/(Mail\W+Field).*/$1$dir_sep/;
79 last;
80 }
81
82 _require_dir('Mail::Field', $dir, $dir_sep);
83}
84
85# register a header class, this creates a new method in Mail::Field
86# which will call new on that class
87sub register
88{ my $thing = shift;
89 my $method = lc shift;
90 my $class = shift || ref($thing) || $thing;
91
92 $method =~ tr/-/_/;
93 $class = _header_pkg_name $method
94 if $class eq "Mail::Field";
95
96 croak "Re-register of $method"
97 if Mail::Field->can($method);
98
99 no strict 'refs';
100 *{$method} = sub {
101 shift;
102 $class->can('stringify') or eval "require $class" or die $@;
103 $class->_build(@_);
104 };
105}
106
107# the *real* constructor
108# if called with one argument then the `parse' method will be called
109# otherwise the `create' method is called
110
111sub _build
112{ my $self = bless {}, shift;
113 @_==1 ? $self->parse(@_) : $self->create(@_);
114}
115
116#-------------
117
118sub new
119{ my $class = shift;
120 my $field = lc shift;
121 $field =~ tr/-/_/;
122 $class->$field(@_);
123}
124
125
126sub combine {confess "Combine not implemented" }
127
128our $AUTOLOAD;
129sub AUTOLOAD
130{ my $method = $AUTOLOAD;
131 $method =~ s/.*:://;
132
133 $method =~ /^[^A-Z\x00-\x1f\x80-\xff :]+$/
134 or croak "Undefined subroutine &$AUTOLOAD called";
135
136 my $class = _header_pkg_name $method;
137
138 unless(eval "require $class")
139 { my $tag = $method;
140 $tag =~ s/_/-/g;
141 $tag = join '-',
142 map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) }
143 split /\-/, $tag;
144
145 no strict;
146 @{"${class}::ISA"} = qw(Mail::Field::Generic);
147 *{"${class}::tag"} = sub { $tag };
148 }
149
150 Mail::Field->can($method)
151 or $class->register($method);
152
153 goto &$AUTOLOAD;
154}
155
156
157# Of course, the functionality should have been in the Mail::Header class
158sub extract
159{ my ($class, $tag, $head) = (shift, shift, shift);
160
161 my $method = lc $tag;
162 $method =~ tr/-/_/;
163
164 if(@_==0 && wantarray)
165 { my @ret;
166 my $text; # need real copy!
167 foreach $text ($head->get($tag))
168 { chomp $text;
169 push @ret, $class->$method($text);
170 }
171 return @ret;
172 }
173
174 my $idx = shift || 0;
175 my $text = $head->get($tag,$idx)
176 or return undef;
177
178 chomp $text;
179 $class->$method($text);
180}
181
182#-------------
183
184# before 2.00, this method could be called as class method, however
185# not all extensions supported that.
186sub create
187{ my ($self, %arg) = @_;
188 %$self = ();
189 $self->set(\%arg);
190}
191
192
193# before 2.00, this method could be called as class method, however
194# not all extensions supported that.
195sub parse
196{ my $class = ref shift;
197 confess "parse() not implemented";
198}
199
200#-------------
201
202sub stringify { confess "stringify() not implemented" }
203
204
205sub tag
206{ my $thing = shift;
207 my $tag = ref($thing) || $thing;
208 $tag =~ s/.*:://;
209 $tag =~ s/_/-/g;
210
211 join '-',
212 map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) }
213 split /\-/, $tag;
214}
215
216
217sub set(@) { confess "set() not implemented" }
218
219# prevent the calling of AUTOLOAD for DESTROY :-)
220sub DESTROY {}
221
222#-------------
223
224sub text
225{ my $self = shift;
226 @_ ? $self->parse(@_) : $self->stringify;
227}
228
229#-------------
230
2311;