File Coverage

blib/lib/DateTime/Format/Mail.pm
Criterion Covered Total %
statement 114 114 100.0
branch 39 54 72.2
condition 13 17 76.4
subroutine 21 21 100.0
pod 10 10 100.0
total 197 216 91.2


line stmt bran cond sub pod time code
1             package DateTime::Format::Mail;
2             # $Id$
3             $DateTime::Format::Mail::VERSION = '0.402';
4 8     8   260032 use strict;
  8         17  
  8         293  
5 8     8   160 use 5.005;
  8         21  
  8         273  
6 8     8   35 use Carp;
  8         11  
  8         659  
7 8     8   6861 use DateTime 0.1705;
  8         818429  
  8         403  
8 8     8   100 use Params::Validate qw( validate validate_pos SCALAR );
  8         12  
  8         602  
9 8     8   44 use vars qw( $VERSION );
  8         13  
  8         11403  
10              
11             my %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.
26             my %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             );
31             my $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              
40             my $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
68             my $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              
96             sub _set_parse_method
97             {
98 15     15   20 my $self = shift;
99 15 50       49 croak "Calling object method as class method!" unless ref $self;
100 15         59 $self->{parser_method} = shift;
101 15         26 return $self;
102             }
103              
104             sub _get_parse_method
105             {
106 29557     29557   30927 my $self = shift;
107 29557 50       71820 my $method = ref($self) ? $self->{parser_method} : '';
108 29557   50     74771 $method ||= '_parse_strict';
109             }
110              
111             sub new
112             {
113 13     13 1 3934 my $class = shift;
114 13         73 my %args = validate( @_, {
115             loose => {
116             type => SCALAR,
117             default => 0,
118             },
119             year_cutoff => {
120 13         68 %{ $validations{year_cutoff} },
121             default => $class->default_cutoff,
122             },
123             }
124             );
125              
126 12   66     110 my $self = bless {}, ref($class)||$class;
127 12 100       36 if (ref $class)
128             {
129             # If called on an object, clone
130 3         7 $self->_set_parse_method( $class->_get_parse_method );
131 3         10 $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 9 100       27 my $parser = $args{loose} ? "loose" : "strict";
137 9         37 $self->$parser();
138 9 50       41 $self->set_year_cutoff( $args{year_cutoff} ) if $args{year_cutoff};
139             }
140              
141 12         49 $self;
142             }
143              
144             sub clone
145             {
146 1     1 1 736 my $self = shift;
147 1 50       6 croak "Calling object method as class method!" unless ref $self;
148 1         3 return $self->new();
149             }
150              
151             sub loose
152             {
153 4     4 1 6 my $self = shift;
154 4 50       15 croak "loose() takes no arguments!" if @_;
155 4         15 return $self->_set_parse_method( '_parse_loose' );
156             }
157              
158             sub strict
159             {
160 8     8 1 11 my $self = shift;
161 8 50       26 croak "strict() takes no arguments!" if @_;
162 8         34 return $self->_set_parse_method( '_parse_strict' );
163             }
164              
165             sub _parse_strict
166             {
167 4     4   5 my $self = shift;
168 4         5 my $date = shift;
169              
170             # Wed, 12 Mar 2003 13:05:00 +1100
171 4         51 my @parsed = $date =~ $strict_RE;
172 4 50       9 croak "Invalid format for date!" unless @parsed;
173 4         5 my %when;
174 4         29 @when{qw( day month year hour minute second time_zone)} = @parsed;
175 4         24 return \%when;
176             }
177              
178             sub _parse_loose
179             {
180 29550     29550   29612 my $self = shift;
181 29550         38157 my $date = shift;
182              
183             # Wed, 12 Mar 2003 13:05:00 +1100
184 29550         541125 my @parsed = $date =~ $loose_RE;
185 29550 100       72583 croak "Invalid format for date!" unless @parsed;
186 29528         28337 my %when;
187 29528         129363 @when{qw( day month year hour minute second time_zone)} = @parsed;
188 29528         73210 $when{month} = "\L\u$when{month}";
189 29528   100     57098 $when{second} ||= 0;
190 29528         206223 return \%when;
191             }
192              
193             sub parse_datetime
194             {
195 29554     29554 1 9736225 my $self = shift;
196 29554 50       77178 croak "No date specified for parse_datetime." unless @_;
197 29554 50       56003 croak "Too many arguments to parse_datetime." if @_ != 1;
198 29554         40862 my $date = shift;
199              
200             # Wed, 12 Mar 2003 13:05:00 +1100
201 29554         50944 my $method = $self->_get_parse_method();
202 29554         30365 my %when = %{ $self->$method($date) };
  29554         69392  
203 29532   100     101570 $when{time_zone} ||= '-0000';
204              
205 29532         27438 my %months = do { my $i = 1;
  29532         30803  
206 29532         41967 map { $_, $i++ } qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
  354384         561114  
207             };
208 29532 50       96444 $when{month} = $months{$when{month}}
209             or croak "Invalid month `$when{month}'.";
210              
211 29532         64109 $when{year} = $self->fix_year( $when{year} );
212 29532         51525 $when{time_zone} = _determine_timezone( $when{time_zone} );
213 29532 100       64587 $when{time_zone} = 'floating' if $when{time_zone} eq '-0000';
214              
215 29532         124127 my $date_time = DateTime->new( %when );
216              
217 29532         9108467 return $date_time;
218             }
219              
220             sub _determine_timezone
221             {
222 29544     29544   34547 my $tz = shift;
223 29544 50       47297 return '-0000' unless defined $tz; # return quickly if nothing needed
224 29544 100       121673 return $tz if $tz =~ /^[+-]\d{4}$/;
225              
226 74         195 $tz =~ s/ ^ [+-] (?=[+-]) //x; # for when there are two signs
227              
228 74 100 66     721 if (exists $timezones{$tz}) {
    100          
    100          
229 19         45 $tz = $timezones{$tz};
230             } elsif (substr($tz, 0, 3) eq 'GMT' and length($tz) > 4) {
231 9         51 $tz = sprintf "%5.5s", substr($tz,3)."0000";
232             } elsif ( $tz =~ /^ ([+-]?) (\d+) $/x) {
233 20   100     116 my $p = $1||'+';
234 20         172 $tz = sprintf "%s%04d", $p, $2;
235             } else {
236 26         56 $tz = "-0000";
237             }
238              
239 74         271 return $tz;
240             }
241              
242             sub set_year_cutoff
243             {
244 18     18 1 1345 my $self = shift;
245 18 50       49 croak "Calling object method as class method!" unless ref $self;
246 18         545 validate_pos( @_, $validations{year_cutoff} );
247 13 50       40 croak "Wrong number of arguments (should be 1) to set_year_cutoff"
248             unless @_ == 1;
249 13         19 my $cutoff = shift;
250 13         48 $self->{year_cutoff} = $cutoff;
251 13         27 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.
261             sub default_cutoff
262             {
263 19     19 1 482 49;
264             }
265              
266             sub year_cutoff
267             {
268 21     21 1 756 my $self = shift;
269 21 50       46 croak "Too many arguments (should be 0) to year_cutoff" if @_;
270 21 100 66     131 (ref $self and $self->{year_cutoff}) or $self->default_cutoff;
271             }
272              
273             sub fix_year
274             {
275 29548     29548 1 36712 my $self = shift;
276 29548         28910 my $year = shift;
277 29548 100       101297 return $year if length $year >= 4; # Return quickly if we can
278              
279 15         36 my $cutoff = $self->year_cutoff;
280 15 100       55 $year += $year > $cutoff ? 1900 : 2000;
281 15         48 return $year;
282             }
283              
284             sub format_datetime
285             {
286 32     32 1 42576 my $self = shift;
287 32 50       81 croak "No DateTime object specified." unless @_;
288 32         94 my $dt = $_[0]->clone;
289 32         351 $dt->set( locale => 'en_US' );
290              
291 32         8645 my $rv = $dt->strftime( "%a, %e %b %Y %H:%M:%S %z" );
292 32 100       4713 $rv =~ s/\+0000$/-0000/ if $dt->time_zone->is_floating;
293 32         366 $rv;
294             }
295              
296             1;
297              
298             __END__