← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:50 2015

Filename/usr/share/perl5/Mail/Address.pm
StatementsExecuted 9 statements in 1.32ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11113µs30µsMail::Address::::BEGIN@6Mail::Address::BEGIN@6
1117µs32µsMail::Address::::BEGIN@11Mail::Address::BEGIN@11
1116µs16µsMail::Address::::BEGIN@9Mail::Address::BEGIN@9
0000s0sMail::Address::::VersionMail::Address::Version
0000s0sMail::Address::::_completeMail::Address::_complete
0000s0sMail::Address::::_extract_nameMail::Address::_extract_name
0000s0sMail::Address::::_find_nextMail::Address::_find_next
0000s0sMail::Address::::_tokeniseMail::Address::_tokenise
0000s0sMail::Address::::addressMail::Address::address
0000s0sMail::Address::::commentMail::Address::comment
0000s0sMail::Address::::formatMail::Address::format
0000s0sMail::Address::::hostMail::Address::host
0000s0sMail::Address::::nameMail::Address::name
0000s0sMail::Address::::newMail::Address::new
0000s0sMail::Address::::parseMail::Address::parse
0000s0sMail::Address::::phraseMail::Address::phrase
0000s0sMail::Address::::set_or_getMail::Address::set_or_get
0000s0sMail::Address::::userMail::Address::user
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-2014 by [Mark Overmeer <perl@overmeer.net>].
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.01.
5package Mail::Address;
6232µs247µs
# spent 30µs (13+17) within Mail::Address::BEGIN@6 which was called: # once (13µs+17µs) by C4::Letters::BEGIN@23 at line 6
use vars '$VERSION';
# spent 30µs making 1 call to Mail::Address::BEGIN@6 # spent 17µs making 1 call to vars::import
71400ns$VERSION = '2.13';
8
9222µs226µs
# spent 16µs (6+10) within Mail::Address::BEGIN@9 which was called: # once (6µs+10µs) by C4::Letters::BEGIN@23 at line 9
use strict;
# spent 16µs making 1 call to Mail::Address::BEGIN@9 # spent 10µs making 1 call to strict::import
10
1121.26ms258µs
# spent 32µs (7+26) within Mail::Address::BEGIN@11 which was called: # once (7µs+26µs) by C4::Letters::BEGIN@23 at line 11
use Carp;
# spent 32µs making 1 call to Mail::Address::BEGIN@11 # spent 26µs making 1 call to Exporter::import
12
13# use locale; removed in version 1.78, because it causes taint problems
14
15sub Version { our $VERSION }
16
- -
19# given a comment, attempt to extract a person's name
20sub _extract_name
21{ # This function can be called as method as well
22 my $self = @_ && ref $_[0] ? shift : undef;
23
24 local $_ = shift
25 or return '';
26
27 # Using encodings, too hard. See Mail::Message::Field::Full.
28 return '' if m/\=\?.*?\?\=/;
29
30 # trim whitespace
31 s/^\s+//;
32 s/\s+$//;
33 s/\s+/ /;
34
35 # Disregard numeric names (e.g. 123456.1234@compuserve.com)
36 return "" if /^[\d ]+$/;
37
38 s/^\((.*)\)$/$1/; # remove outermost parenthesis
39 s/^"(.*)"$/$1/; # remove outer quotation marks
40 s/\(.*?\)//g; # remove minimal embedded comments
41 s/\\//g; # remove all escapes
42 s/^"(.*)"$/$1/; # remove internal quotation marks
43 s/^([^\s]+) ?, ?(.*)$/$2 $1/; # reverse "Last, First M." if applicable
44 s/,.*//;
45
46 # Change casing only when the name contains only upper or only
47 # lower cased characters.
48 unless( m/[A-Z]/ && m/[a-z]/ )
49 { # Set the case of the name to first char upper rest lower
50 s/\b(\w+)/\L\u$1/igo; # Upcase first letter on name
51 s/\bMc(\w)/Mc\u$1/igo; # Scottish names such as 'McLeod'
52 s/\bo'(\w)/O'\u$1/igo; # Irish names such as 'O'Malley, O'Reilly'
53 s/\b(x*(ix)?v*(iv)?i*)\b/\U$1/igo; # Roman numerals, eg 'Level III Support'
54 }
55
56 # some cleanup
57 s/\[[^\]]*\]//g;
58 s/(^[\s'"]+|[\s'"]+$)//g;
59 s/\s{2,}/ /g;
60
61 $_;
62}
63
64sub _tokenise
65{ local $_ = join ',', @_;
66 my (@words,$snippet,$field);
67
68 s/\A\s+//;
69 s/[\r\n]+/ /g;
70
71 while ($_ ne '')
72 { $field = '';
73 if(s/^\s*\(/(/ ) # (...)
74 { my $depth = 0;
75
76 PAREN: while(s/^(\(([^\(\)\\]|\\.)*)//)
77 { $field .= $1;
78 $depth++;
79 while(s/^(([^\(\)\\]|\\.)*\)\s*)//)
80 { $field .= $1;
81 last PAREN unless --$depth;
82 $field .= $1 if s/^(([^\(\)\\]|\\.)+)//;
83 }
84 }
85
86 carp "Unmatched () '$field' '$_'"
87 if $depth;
88
89 $field =~ s/\s+\Z//;
90 push @words, $field;
91
92 next;
93 }
94
95 if( s/^("(?:[^"\\]+|\\.)*")\s*// # "..."
96 || s/^(\[(?:[^\]\\]+|\\.)*\])\s*// # [...]
97 || s/^([^\s()<>\@,;:\\".[\]]+)\s*//
98 || s/^([()<>\@,;:\\".[\]])\s*//
99 )
100 { push @words, $1;
101 next;
102 }
103
104 croak "Unrecognised line: $_";
105 }
106
107 push @words, ",";
108 \@words;
109}
110
111sub _find_next
112{ my ($idx, $tokens, $len) = @_;
113
114 while($idx < $len)
115 { my $c = $tokens->[$idx];
116 return $c if $c eq ',' || $c eq ';' || $c eq '<';
117 $idx++;
118 }
119
120 "";
121}
122
123sub _complete
124{ my ($class, $phrase, $address, $comment) = @_;
125
126 @$phrase || @$comment || @$address
127 or return undef;
128
129 my $o = $class->new(join(" ",@$phrase), join("",@$address), join(" ",@$comment));
130 @$phrase = @$address = @$comment = ();
131 $o;
132}
133
134
135sub new(@)
136{ my $class = shift;
137 bless [@_], $class;
138}
139
140
141sub parse(@)
142{ my $class = shift;
143 my @line = grep {defined} @_;
144 my $line = join '', @line;
145
146 my (@phrase, @comment, @address, @objs);
147 my ($depth, $idx) = (0, 0);
148
149 my $tokens = _tokenise @line;
150 my $len = @$tokens;
151 my $next = _find_next $idx, $tokens, $len;
152
153 local $_;
154 for(my $idx = 0; $idx < $len; $idx++)
155 { $_ = $tokens->[$idx];
156
157 if(substr($_,0,1) eq '(') { push @comment, $_ }
158 elsif($_ eq '<') { $depth++ }
159 elsif($_ eq '>') { $depth-- if $depth }
160 elsif($_ eq ',' || $_ eq ';')
161 { warn "Unmatched '<>' in $line" if $depth;
162 my $o = $class->_complete(\@phrase, \@address, \@comment);
163 push @objs, $o if defined $o;
164 $depth = 0;
165 $next = _find_next $idx+1, $tokens, $len;
166 }
167 elsif($depth) { push @address, $_ }
168 elsif($next eq '<') { push @phrase, $_ }
169 elsif( /^[.\@:;]$/ || !@address || $address[-1] =~ /^[.\@:;]$/ )
170 { push @address, $_ }
171 else
172 { warn "Unmatched '<>' in $line" if $depth;
173 my $o = $class->_complete(\@phrase, \@address, \@comment);
174 push @objs, $o if defined $o;
175 $depth = 0;
176 push @address, $_;
177 }
178 }
179 @objs;
180}
181
182
183sub phrase { shift->set_or_get(0, @_) }
184sub address { shift->set_or_get(1, @_) }
185sub comment { shift->set_or_get(2, @_) }
186
187sub set_or_get($)
188{ my ($self, $i) = (shift, shift);
189 @_ or return $self->[$i];
190
191 my $val = $self->[$i];
192 $self->[$i] = shift if @_;
193 $val;
194}
195
196
1971200nsmy $atext = '[\-\w !#$%&\'*+/=?^`{|}~]';
198sub format
199{ my @addrs;
200
201 foreach (@_)
202 { my ($phrase, $email, $comment) = @$_;
203 my @addr;
204
205 if(defined $phrase && length $phrase)
206 { push @addr
207 , $phrase =~ /^(?:\s*$atext\s*)+$/o ? $phrase
208 : $phrase =~ /(?<!\\)"/ ? $phrase
209 : qq("$phrase");
210
211 push @addr, "<$email>"
212 if defined $email && length $email;
213 }
214 elsif(defined $email && length $email)
215 { push @addr, $email;
216 }
217
218 if(defined $comment && $comment =~ /\S/)
219 { $comment =~ s/^\s*\(?/(/;
220 $comment =~ s/\)?\s*$/)/;
221 }
222
223 push @addr, $comment
224 if defined $comment && length $comment;
225
226 push @addrs, join(" ", @addr)
227 if @addr;
228 }
229
230 join ", ", @addrs;
231}
232
233
234sub name
235{ my $self = shift;
236 my $phrase = $self->phrase;
237 my $addr = $self->address;
238
239 $phrase = $self->comment
240 unless defined $phrase && length $phrase;
241
242 my $name = $self->_extract_name($phrase);
243
244 # first.last@domain address
245 if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/)
246 { ($name = $1) =~ s/[\._]+/ /g;
247 $name = _extract_name $name;
248 }
249
250 if($name eq '' && $addr =~ m#/g=#i) # X400 style address
251 { my ($f) = $addr =~ m#g=([^/]*)#i;
252 my ($l) = $addr =~ m#s=([^/]*)#i;
253 $name = _extract_name "$f $l";
254 }
255
256 length $name ? $name : undef;
257}
258
259
260sub host
261{ my $addr = shift->address || '';
262 my $i = rindex $addr, '@';
263 $i >= 0 ? substr($addr, $i+1) : undef;
264}
265
266
267sub user
268{ my $addr = shift->address || '';
269 my $i = rindex $addr, '@';
270 $i >= 0 ? substr($addr,0,$i) : $addr;
271}
272
27312µs1;
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.