← 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/DateTime/Format/Mail.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sDateTime::Format::Mail::::BEGIN@4DateTime::Format::Mail::BEGIN@4
0000s0sDateTime::Format::Mail::::BEGIN@5DateTime::Format::Mail::BEGIN@5
0000s0sDateTime::Format::Mail::::BEGIN@6DateTime::Format::Mail::BEGIN@6
0000s0sDateTime::Format::Mail::::BEGIN@7DateTime::Format::Mail::BEGIN@7
0000s0sDateTime::Format::Mail::::BEGIN@8DateTime::Format::Mail::BEGIN@8
0000s0sDateTime::Format::Mail::::BEGIN@9DateTime::Format::Mail::BEGIN@9
0000s0sDateTime::Format::Mail::::CORE:qrDateTime::Format::Mail::CORE:qr (opcode)
0000s0sDateTime::Format::Mail::::CORE:regcompDateTime::Format::Mail::CORE:regcomp (opcode)
0000s0sDateTime::Format::Mail::::CORE:sortDateTime::Format::Mail::CORE:sort (opcode)
0000s0sDateTime::Format::Mail::::__ANON__DateTime::Format::Mail::__ANON__ (xsub)
0000s0sDateTime::Format::Mail::::__ANON__[:20]DateTime::Format::Mail::__ANON__[:20]
0000s0sDateTime::Format::Mail::::_determine_timezoneDateTime::Format::Mail::_determine_timezone
0000s0sDateTime::Format::Mail::::_get_parse_methodDateTime::Format::Mail::_get_parse_method
0000s0sDateTime::Format::Mail::::_parse_looseDateTime::Format::Mail::_parse_loose
0000s0sDateTime::Format::Mail::::_parse_strictDateTime::Format::Mail::_parse_strict
0000s0sDateTime::Format::Mail::::_set_parse_methodDateTime::Format::Mail::_set_parse_method
0000s0sDateTime::Format::Mail::::cloneDateTime::Format::Mail::clone
0000s0sDateTime::Format::Mail::::default_cutoffDateTime::Format::Mail::default_cutoff
0000s0sDateTime::Format::Mail::::fix_yearDateTime::Format::Mail::fix_year
0000s0sDateTime::Format::Mail::::format_datetimeDateTime::Format::Mail::format_datetime
0000s0sDateTime::Format::Mail::::looseDateTime::Format::Mail::loose
0000s0sDateTime::Format::Mail::::newDateTime::Format::Mail::new
0000s0sDateTime::Format::Mail::::parse_datetimeDateTime::Format::Mail::parse_datetime
0000s0sDateTime::Format::Mail::::set_year_cutoffDateTime::Format::Mail::set_year_cutoff
0000s0sDateTime::Format::Mail::::strictDateTime::Format::Mail::strict
0000s0sDateTime::Format::Mail::::year_cutoffDateTime::Format::Mail::year_cutoff
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package DateTime::Format::Mail;
2# $Id$
3$DateTime::Format::Mail::VERSION = '0.403';
4use strict;
5use 5.005;
6use Carp;
7use DateTime 1.04;
8use Params::Validate qw( validate validate_pos SCALAR );
9use vars qw( $VERSION );
10
11my %validations = (
12 year_cutoff => {
13 type => SCALAR,
14 callbacks => {
15 'greater than or equal to zero, less than 100' => sub {
16 defined $_[0]
17 and $_[0] =~ /^ \d+ $/x
18 and $_[0] >= 0
19 and $_[0] < 100
20 },
21 },
22 }
23);
24
25# Timezones for strict parser.
26my %timezones = qw(
27 EDT -0400 EST -0500 CDT -0500 CST -0600
28 MDT -0600 MST -0700 PDT -0700 PST -0800
29 GMT +0000 UT +0000
30);
31my $tz_RE = join( '|', sort keys %timezones );
32$tz_RE= qr/(?:$tz_RE)/;
33$timezones{UTC} = $timezones{UT};
34
35# Strict parser regex
36
37# Lovely regex. Mostly a translation of the BNF in 2822.
38# XXX - need more thorough tests to ensure it's *strict*.
39
40my $strict_RE = qr{
41 ^ \s* # optional
42 # [day-of-week "," ]
43 (?:
44 (?:Mon|Tue|Wed|Thu|Fri|Sat|Sun) ,
45 \s+
46 )?
47 # date => day month year
48 (\d{1,2}) # day => 1*2DIGIT
49 \s+
50 (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) # month-name
51 \s*
52 ((?:\d\d)?\d\d) # year
53 # FWS
54 \s+
55 # time
56 (\d\d):(\d\d):(\d\d) # time
57 (?:
58 \s+ (
59 [+-] \d{4} # standard form
60 | $tz_RE # obsolete form (mostly ignored)
61 | [A-IK-Za-ik-z] # including military (no 'J')
62 ) # time zone (optional)
63 )?
64 \s* $
65}ox;
66
67# Loose parser regex
68my $loose_RE = qr{
69 ^ \s* # optional
70 (?i:
71 (?:Mon|Tue|Wed|Thu|Fri|Sat|Sun|[A-Z][a-z][a-z]) ,? # Day name + comma
72 )?
73 # (empirically optional)
74 \s*
75 (\d{1,2}) # day of month
76 [-\s]*
77 (?i: (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) ) # month
78 [-\s]*
79 ((?:\d\d)?\d\d) # year
80 \s+
81 (\d?\d):(\d?\d) (?: :(\d?\d) )? # time
82 (?:
83 \s+ "? (
84 [+-] \d{4} # standard form
85 | [A-Z]+ # obsolete form (mostly ignored)
86 | GMT [+-] \d+ # empirical (converted)
87 | [A-Z]+\d+ # bizarre empirical (ignored)
88 | [a-zA-Z/]+ # linux style (ignored)
89 | [+-]{0,2} \d{3,5} # corrupted standard form
90 ) "? # time zone (optional)
91 )?
92 (?: \s+ \([^\)]+\) )? # (friendly tz name; empirical)
93 \s* \.? $
94}x;
95
96sub _set_parse_method
97{
98 my $self = shift;
99 croak "Calling object method as class method!" unless ref $self;
100 $self->{parser_method} = shift;
101 return $self;
102}
103
104sub _get_parse_method
105{
106 my $self = shift;
107 my $method = ref($self) ? $self->{parser_method} : '';
108 $method ||= '_parse_strict';
109}
110
111sub new
112{
113 my $class = shift;
114 my %args = validate( @_, {
115 loose => {
116 type => SCALAR,
117 default => 0,
118 },
119 year_cutoff => {
120 %{ $validations{year_cutoff} },
121 default => $class->default_cutoff,
122 },
123 }
124 );
125
126 my $self = bless {}, ref($class)||$class;
127 if (ref $class)
128 {
129 # If called on an object, clone
130 $self->_set_parse_method( $class->_get_parse_method );
131 $self->set_year_cutoff( $class->year_cutoff );
132 # and that's it. we don't store much info per object
133 }
134 else
135 {
136 my $parser = $args{loose} ? "loose" : "strict";
137 $self->$parser();
138 $self->set_year_cutoff( $args{year_cutoff} ) if $args{year_cutoff};
139 }
140
141 $self;
142}
143
144sub clone
145{
146 my $self = shift;
147 croak "Calling object method as class method!" unless ref $self;
148 return $self->new();
149}
150
151sub loose
152{
153 my $self = shift;
154 croak "loose() takes no arguments!" if @_;
155 return $self->_set_parse_method( '_parse_loose' );
156}
157
158sub strict
159{
160 my $self = shift;
161 croak "strict() takes no arguments!" if @_;
162 return $self->_set_parse_method( '_parse_strict' );
163}
164
165sub _parse_strict
166{
167 my $self = shift;
168 my $date = shift;
169
170 # Wed, 12 Mar 2003 13:05:00 +1100
171 my @parsed = $date =~ $strict_RE;
172 croak "Invalid format for date!" unless @parsed;
173 my %when;
174 @when{qw( day month year hour minute second time_zone)} = @parsed;
175 return \%when;
176}
177
178sub _parse_loose
179{
180 my $self = shift;
181 my $date = shift;
182
183 # Wed, 12 Mar 2003 13:05:00 +1100
184 my @parsed = $date =~ $loose_RE;
185 croak "Invalid format for date!" unless @parsed;
186 my %when;
187 @when{qw( day month year hour minute second time_zone)} = @parsed;
188 $when{month} = "\L\u$when{month}";
189 $when{second} ||= 0;
190 return \%when;
191}
192
193sub parse_datetime
194{
195 my $self = shift;
196 croak "No date specified for parse_datetime." unless @_;
197 croak "Too many arguments to parse_datetime." if @_ != 1;
198 my $date = shift;
199
200 # Wed, 12 Mar 2003 13:05:00 +1100
201 my $method = $self->_get_parse_method();
202 my %when = %{ $self->$method($date) };
203 $when{time_zone} ||= '-0000';
204
205 my %months = do { my $i = 1;
206 map { $_, $i++ } qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
207 };
208 $when{month} = $months{$when{month}}
209 or croak "Invalid month `$when{month}'.";
210
211 $when{year} = $self->fix_year( $when{year} );
212 $when{time_zone} = _determine_timezone( $when{time_zone} );
213 $when{time_zone} = 'floating' if $when{time_zone} eq '-0000';
214
215 my $date_time = DateTime->new( %when );
216
217 return $date_time;
218}
219
220sub _determine_timezone
221{
222 my $tz = shift;
223 return '-0000' unless defined $tz; # return quickly if nothing needed
224 return $tz if $tz =~ /^[+-]\d{4}$/;
225
226 $tz =~ s/ ^ [+-] (?=[+-]) //x; # for when there are two signs
227
228 if (exists $timezones{$tz}) {
229 $tz = $timezones{$tz};
230 } elsif (substr($tz, 0, 3) eq 'GMT' and length($tz) > 4) {
231 $tz = sprintf "%5.5s", substr($tz,3)."0000";
232 } elsif ( $tz =~ /^ ([+-]?) (\d+) $/x) {
233 my $p = $1||'+';
234 $tz = sprintf "%s%04d", $p, $2;
235 } else {
236 $tz = "-0000";
237 }
238
239 return $tz;
240}
241
242sub set_year_cutoff
243{
244 my $self = shift;
245 croak "Calling object method as class method!" unless ref $self;
246 validate_pos( @_, $validations{year_cutoff} );
247 croak "Wrong number of arguments (should be 1) to set_year_cutoff"
248 unless @_ == 1;
249 my $cutoff = shift;
250 $self->{year_cutoff} = $cutoff;
251 return $self;
252}
253
254# rfc2822, 4.3. Obsolete Date and Time
255# Where a two or three digit year occurs in a date, the year is to be
256# interpreted as follows: If a two digit year is encountered whose
257# value is between 00 and 49, the year is interpreted by adding 2000,
258# ending up with a value between 2000 and 2049. If a two digit year is
259# encountered with a value between 50 and 99, or any three digit year
260# is encountered, the year is interpreted by adding 1900.
261sub default_cutoff
262{
263 49;
264}
265
266sub year_cutoff
267{
268 my $self = shift;
269 croak "Too many arguments (should be 0) to year_cutoff" if @_;
270 (ref $self and $self->{year_cutoff}) or $self->default_cutoff;
271}
272
273sub fix_year
274{
275 my $self = shift;
276 my $year = shift;
277 return $year if length $year >= 4; # Return quickly if we can
278
279 my $cutoff = $self->year_cutoff;
280 $year += $year > $cutoff ? 1900 : 2000;
281 return $year;
282}
283
284sub format_datetime
285{
286 my $self = shift;
287 croak "No DateTime object specified." unless @_;
288 my $dt = $_[0]->clone;
289 $dt->set_locale('en_US');
290
291 my $rv = $dt->strftime( "%a, %e %b %Y %H:%M:%S %z" );
292 $rv =~ s/\+0000$/-0000/ if $dt->time_zone->is_floating;
293 $rv;
294}
295
2961;
297
298__END__