/[suikacvs]/messaging/manakai/lib/Message/Field/Date.pm
Suika

Contents of /messaging/manakai/lib/Message/Field/Date.pm

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.16 - (hide annotations) (download)
Sat Aug 3 23:32:04 2002 UTC (22 years, 3 months ago) by wakaba
Branch: MAIN
Changes since 1.15: +6 -3 lines 
2002-08-04  Wakaba <w@suika.fam.cx>

	* Warning.pm: New module.
	* CSV.pm (_delete_empty): Don't remove reference
	if the length of its stringified value is zero.
	* Domain.pm: Parse and output port number if enabled by option.
	* Date.pm (overload '==', '<=', '>='): Added.
1 wakaba 1.1
2     =head1 NAME
3    
4 wakaba 1.9 Message::Field::Date --- Perl module for various styles of
5     date-time used in Internet messages and so on
6 wakaba 1.1
7     =cut
8    
9     package Message::Field::Date;
10     use strict;
11 wakaba 1.9 use vars qw(%DEFAULT @ISA %MONTH %REG $VERSION %ZONE);
12 wakaba 1.16 $VERSION=do{my @r=(q$Revision: 1.15 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13 wakaba 1.9 require Message::Field::Structured;
14     push @ISA, qw(Message::Field::Structured);
15 wakaba 1.1 use Time::Local 'timegm_nocheck';
16 wakaba 1.16 use overload '==' => sub { $_[0]->{date_time} == $_[1] },
17     '<=' => sub { $_[0]->{date_time} <= $_[1] },
18     '>=' => sub { $_[0]->{date_time} >= $_[1] },
19     '0+' => sub { $_[0]->{date_time} },
20 wakaba 1.10 fallback => 1;
21 wakaba 1.1
22 wakaba 1.9 %REG = %Message::Util::REG;
23 wakaba 1.14 ## RFC 822/2822 Internet Message Format
24 wakaba 1.9 $REG{M_dt_rfc822} = qr!(?:[A-Za-z]+ ## Day of week
25     [\x09\x20,]*)? ([0-9]+) ## Day
26     [\x09\x20/-]* ([A-Za-z]+) ## Month
27     [\x09\x20/-]* ([0-9]+) ## Year
28     [\x09\x20:Tt-]+ ([0-9]+) ## Hour
29     [\x09\x20:]+ ([0-9]+) ## Minute
30     [\x09\x20:]* ([0-9]+)? ## Second
31     ([\x09\x20 0-9A-Za-z+-]+)!x; ## Zone
32 wakaba 1.14 ## RFC 3339 Internet Date/Time Format (A profile of ISO 8601)
33     $REG{M_dt_rfc3339} = qr! ([0-9]{4,}) ## Year
34 wakaba 1.9 [\x09\x20.:/-]+ ([0-9]+) ## Month
35     [\x09\x20.:/-]+ ([0-9]+) ## Day
36     (?:[\x09\x20.:Tt-]+ ([0-9]+) ## Hour
37     [\x09\x20.:]+ ([0-9]+) ## Minute
38     (?:[\x09\x20.:]+ ([0-9]+) ## Second
39     (?:[\x09\x20.:]+ ([0-9]+))?)?)? ## frac.
40     ([\x09\x20 0-9A-Za-z:.+-]*) !x; ## Zone.
41 wakaba 1.14 ## RFC 733 ARPA Internet Message Format
42 wakaba 1.9 $REG{M_dt_rfc733} = qr!(?:[A-Za-z]+ ## Day of week
43     [\x09\x20,]*)? ([0-9]+) ## Day
44     [\x09\x20/-]* ([A-Za-z]+) ## Month
45     [\x09\x20/-]* ([0-9]+) ## Year
46     [\x09\x20:Tt-]+ ([0-9][0-9]) ## Hour
47     [\x09\x20:]* ([0-9][0-9]) ## Minute
48     [\x09\x20:]* ([0-9][0-9])? ## Second
49     ([\x09\x20 0-9A-Za-z+-]+)!x; ## Zone
50 wakaba 1.14 ## RFC 724 ARPA Internet Message Format (slash-date)
51 wakaba 1.9 $REG{M_dt_rfc724} = qr!(?:[A-Za-z]+ ## Day of week
52     [\x09\x20,]*)? ([0-9][0-9]?) ## Month
53     [\x09\x20/]+ ([0-9][0-9]?) ## Day
54     [\x09\x20/]+ ([0-9]{2,}) ## Year
55     [\x09\x20:Tt-]+ ([0-9][0-9]) ## Hour
56     [\x09\x20:]* ([0-9][0-9]) ## Minute
57     [\x09\x20:]* ([0-9][0-9])? ## Second
58     ([\x09\x20 0-9A-Za-z+-]+)!x; ## Zone
59 wakaba 1.1
60 wakaba 1.9 =head1 CONSTRUCTORS
61    
62     The following methods construct new objects:
63    
64     =over 4
65    
66     =cut
67    
68     ## Initialize of this class -- called by constructors
69 wakaba 1.1 %DEFAULT = (
70 wakaba 1.9 -_MEMBERS => [qw|date_time secfrac|],
71     -_METHODS => [qw|unix_time second_fraction
72     comment_add comment_count comment_item comment_delete|],
73     -date_format => 'string', ## 'unix' / 1*ALPHA
74     #field_param_name
75     #field_name
76     #format
77     #hook_encode_string
78     #hook_decode_string
79     -output_comment => 1,
80 wakaba 1.11 -fmt2str => {
81 wakaba 1.9 CC => sub { sprintf $_[2]->{_fmt}, ## Support AD only
82     (($_[1]->{$_[2]->{_prefix}.'tm'}->[5] + 1899) / 100) + 1 },
83     YYYY => sub { $_[2]->{_fmt} =~ tr/2/4/;
84     sprintf $_[2]->{_fmt},
85     $_[1]->{$_[2]->{_prefix}.'tm'}->[5] + 1900 },
86     YY => sub { sprintf $_[2]->{_fmt},
87     substr ($_[1]->{$_[2]->{_prefix}.'tm'}->[5], -2) },
88     MM => sub { sprintf $_[2]->{_fmt},
89     $_[1]->{$_[2]->{_prefix}.'tm'}->[4] + 1 },
90     Mon => sub { qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)
91     [$_[1]->{$_[2]->{_prefix}.'tm'}->[4]] },
92     Month => sub { qw(January February March April May June
93     July August September October November December)
94     [$_[1]->{$_[2]->{_prefix}.'tm'}->[4]] },
95     DD => sub { sprintf $_[2]->{_fmt}, $_[1]->{$_[2]->{_prefix}.'tm'}->[3] },
96     Wdy => sub { qw(Sun Mon Tue Wed Thu Fri Sat)
97     [$_[1]->{$_[2]->{_prefix}.'tm'}->[6]] },
98     Weekday => sub { qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday)
99     [$_[1]->{$_[2]->{_prefix}.'tm'}->[6]] },
100     shun => sub {
101     my @alphabet = split /:/, $_[2]->{alphabet} || 'abcc';
102     my $day = $_[1]->{$_[2]->{_prefix}.'tm'}->[3];
103     $day <= 10? $alphabet[0]: ## 1 - 10 joujun
104     $day <= 20? $alphabet[1]: ## 11 - 20 chuujun
105     $alphabet[2]; ## 21 - 31 gejun
106     },
107     HH => sub { sprintf $_[2]->{_fmt}, $_[1]->{$_[2]->{_prefix}.'tm'}->[2] },
108     TT => sub { sprintf $_[2]->{_fmt}, $_[1]->{$_[2]->{_prefix}.'tm'}->[1] },
109     SS => sub { sprintf $_[2]->{_fmt}, $_[1]->{$_[2]->{_prefix}.'tm'}->[0] },
110     unix => sub { $_[1]->{$_[2]->{_prefix}.'unix'} },
111     frac => sub { $_[0]->{secfrac} },
112     zsign => sub { $_[1]->{zone}->[0] > 0 ? '+' : '-' },
113     zHH => sub { sprintf $_[2]->{_fmt}, $_[1]->{zone}->[1] },
114     zTT => sub { sprintf $_[2]->{_fmt}, $_[1]->{zone}->[2] },
115     },
116     -use_comment => 1,
117     -use_military_zone => +1, ## +1 / -1 / 0
118 wakaba 1.13 #zone => [+1, 0, 0],
119 wakaba 1.9 -zone_default_string => '-0000',
120 wakaba 1.1 );
121    
122     %MONTH = (
123     JAN => 1, JANUARY => 1,
124     FEB => 2, FEBRUARY => 2,
125     MAR => 3, MARCH => 3,
126     APR => 4, APRIL => 4,
127     MAY => 5,
128     JUN => 6, JUNE => 6,
129     JUL => 7, JULY => 7,
130     AUG => 8, AUGUST => 8,
131 wakaba 1.8 SEP => 9, SEPTEMBER => 9, SEPT => 9,
132 wakaba 1.1 OCT => 10, OCTOBER => 10,
133     NOV => 11, NOVEMBER => 11,
134     DEC => 12, DECEMBER => 12,
135     );
136    
137 wakaba 1.9 %ZONE = ( ## NA = Northern America
138     ADT => [-1, 3, 0], ## (NA)Atlantic Daylight 733
139     CHST => [-1, 10, 0], ## Alaska-Hawaii Standard
140     AST => [-1, 4, 0], ## (NA)Atlantic Standard 733
141     AT => [-1, 2, 0], ## Azores
142     BDT => [-1, 10, 0], ## 733
143     BST => [-1, 11, 0], ## 733
144     #BST => [+1, 1, 0], ## British Summer
145     #BST => [-1, 3, 0], ## Brazil Standard
146     BT => [+1, 3, 0], ## Baghdad
147     CADT => [+1, 10, 30], ## Central Australian Daylight
148     CAST => [+1, 9, 30], ## Central Australian Standard
149     CAT => [-1, 10, 0], ## Central Alaska
150     CCT => [+1, 8, 0], ## China Coast
151     CDT => [-1, 5, 0], ## (NA)Central Daylight 733, 822
152     CET => [+1, 1, 0], ## Central European
153     CEST => [+1, 2, 0], ## Central European Daylight
154     CST => [-1, 6, 0], ## (NA)Central Standard 733, 822
155     EADT => [+1, 11, 0], ## Eastern Australian Daylight
156     EADT => [+1, 10, 0], ## Eastern Australian Standard
157     ECT => [+1, 1, 0], ## Central European (French)
158     EDT => [-1, 4, 0], ## (NA)Eastern Daylight 733, 822
159     EEST => [+1, 3, 0], ## Eastern European Summer
160     EET => [+1, 2, 0], ## Eastern Europe 1947
161     EST => [-1, 5, 0], ## (NA)Eastern Standard 733, 822
162     EWT => [-1, 4, 0], ## U.S. Eastern War Time
163     FST => [+1, 2, 0], ## French Summer
164     FWT => [+1, 1, 0], ## French Winter
165     GDT => [+1, 1, 0], ## 724
166     GMT => [+1, 0, 0], ## Greenwich Mean 733, 822
167     #GST => [-1, 3, 0], ## Greenland Standard
168     GST => [+1, 10, 0], ## Guam Standard
169     HDT => [-1, 9, 0], ## Hawaii Daylight 733
170     HKT => [+1, 8, 0], ## Hong Kong
171     HST => [-1, 10, 0], ## Hawaii Standard 733
172     IDLE => [+1, 12, 0], ## International Date Line East
173     IDLW => [-1, 12, 0], ## International Date Line West
174 wakaba 1.2 IDT => [+1, 3, 0],
175 wakaba 1.9 IST => [+1, 2, 0], ## Israel standard
176     #IST => [+1, 5, 30], ## Indian standard
177     IT => [+1, 3, 30], ## Iran
178     JST => [+1, 9, 0], ## Japan Central Standard
179     JT => [+1, 7, 30], ## Java
180     KDT => [+1, 10, 0], ## Korean Daylight
181     KST => [+1, 9, 0], ## Korean Standard
182 wakaba 1.14 LCL => [-1, 0, 0], ## (unknown zone used by LSMTP)
183     LOCAL => [-1, 0, 0], ## local time zone
184     LT => [-1, 0, 0], ## Luna Time [RFC 1607]
185 wakaba 1.9 MDT => [-1, 6, 0], ## (NA)Mountain Daylight 733, 822
186     MET => [+1, 0, 0], ## Middle European
187     METDST => [+1, 2, 0],
188     MEST => [+1, 2, 0], ## Middle European Summer
189     MEWT => [+1, 0, 0], ## Middle European Winter
190     MEZ => [+1, 0, 0], ## Central European (German)
191     MST => [-1, 7, 0], ## (NA)Mountain Standard 733, 822
192 wakaba 1.14 MT => [-1, 0, 0], ## Mars Time [RFC 1607]
193 wakaba 1.9 NDT => [-1, 2, 30], ## Newfoundland Daylight
194     NFT => [-1, 3, 30], ## Newfoundland Standard
195     NST => [-1, 3, 30], ## Newfoundland Standard 733
196     #NST => [-1, 6, 30], ## North Sumatra
197     NT => [-1, 11, 0], ## Nome
198     NZD => [+1, 13, 0], ## New Zealand Daylight
199     NZT => [+1, 12, 0], ## New Zealand
200     NZDT => [+1, 13, 0], ## New Zealand Daylight
201     NZST => [+1, 12, 0], ## New Zealand Standard
202     PDT => [-1, 7, 0], ## (NA)Pacific Daylight 733, 822
203     PST => [-1, 8, 0], ## (NA)Pacific Standard 733, 822
204     SET => [+1, 1, 0], ## Seychelles
205     SST => [+1, 2, 0], ## Swedish Summer
206     #SST => [+1, 7, 0], ## South Sumatra
207     SWT => [+1, 1, 0], ## Swedish Winter
208     UKR => [+1, 2, 0], ## Ukraine
209 wakaba 1.14 UT => [+1, 0, 0], ## Universal Time 822
210     UTC => [+1, 0, 0], ## Coordinated Universal Time
211 wakaba 1.9 WADT => [+1, 8, 0], ## West Australian Daylight
212     WAT => [-1, 0, 0], ## West Africa
213     WET => [+1, 0, 0], ## Western European
214     WST => [+1, 8, 0], ## West Australian Standard
215     YDT => [-1, 8, 0], ## Yukon Daylight 733
216     YST => [-1, 9, 0], ## Yukon Standard 733
217     Z => [+1, 0, 0], ## 822, ISO 8601
218     ZP4 => [+1, 4, 0], ## Z+4
219     ZP5 => [+1, 5, 0], ## Z+5
220     ZP6 => [+1, 6, 0], ## Z+6
221 wakaba 1.1 );
222    
223 wakaba 1.9 ## -use_military_zone => +1 / -1 / 0
224     ## Whether military zone names are understood or not.
225     ## +1 Admits them and treats as standard value. (eg. "A" = +0100)
226     ## -1 Admits them but treats as negative value. (eg. "A" = -0100)
227     ## 0 They are ignored and zone is set as -0000. (eg. "A" = -0000)
228     ## Because of typo in BNF comment of RFCs 733 and 822,
229     ## quite a few implemention use these values incorrectly.
230     ## As a result, these zone names carry no worthful information.
231     ## RFC 2822 recommends these names be taken as '-0000' (i.e.
232     ## unknown zone).
233 wakaba 1.1
234 wakaba 1.9 sub _set_military_zone_name ($) {
235 wakaba 1.1 my $self = shift;
236 wakaba 1.9 my $mode = $self->{option}->{use_military_zone};
237 wakaba 1.1 my $i = 0;
238 wakaba 1.9 if ($mode == 0) {
239     for my $letter ('A'..'Y') {$ZONE{$letter} = [-1, 0, 0]} return;
240 wakaba 1.1 }
241     for my $letter ('Z', 'A'..'I', 'K'..'M') {
242     $ZONE{$letter} = [+1*$mode, $i++, 0];
243     } $i = 1;
244     for my $letter ('N'..'Y') {
245     $ZONE{$letter} = [-1*$mode, $i++, 0];
246     }
247     }
248    
249 wakaba 1.9 sub _init ($;%) {
250     my $self = shift;
251     my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
252     my %option = @_;
253     $self->SUPER::_init (%$DEFAULT, %option);
254     $self->{date_time} = $option{unix} if defined $option{unix};
255     $self->{secfrac} = $option{frac} if defined $option{frac};
256 wakaba 1.13 unless (ref $self->{option}->{zone}) {
257     my $zone = $self->{option}->{zone} || ''; #$main::ENV{TZ} || '';
258     ## Since _zone_string_to_array does not provide full support
259     ## of parsing TZ format (eg. daytime), not seeing it might be
260     ## better way.
261     if (length $zone) {
262     $self->{option}->{zone} = [ $self->_zone_string_to_array ($zone) ];
263     } else {
264     my $time = time;
265     my $ltime = timegm_nocheck (localtime ($time));
266     my $o = int ( ($ltime - $time) / 60);
267     my @zone;
268     $zone[2] = $o % 60; $o = int ( $o / 60 );
269     $zone[1] = $o % 24;
270     $zone[0] = $o >= 0 ? +1 : -1;
271     $self->{option}->{zone} = \@zone;
272     }
273     }
274 wakaba 1.9
275     my $format = $self->{option}->{format};
276 wakaba 1.14 if ($format =~ /mail-rfc2822/) {
277 wakaba 1.9 $self->{option}->{use_military_zone} = 0;
278     }
279    
280     $self->_set_military_zone_name;
281     }
282    
283     =item $date = Message::Field::Date->new ([%options])
284 wakaba 1.1
285 wakaba 1.9 Constructs a new object. You might pass some options as parameters
286     to the constructor.
287 wakaba 1.1
288     =cut
289    
290 wakaba 1.9 ## Inherited
291 wakaba 1.1
292 wakaba 1.9 =item $date = Message::Field::Date->parse ($field-body, [%options])
293 wakaba 1.1
294 wakaba 1.9 Constructs a new object with given field body. You might pass
295     some options as parameters to the constructor.
296 wakaba 1.1
297     =cut
298    
299     sub parse ($$;%) {
300 wakaba 1.9 my $class = shift;
301     my $self = bless {}, $class;
302     my $body = shift;
303     $self->_init (@_);
304     ($body, @{$self->{comment}})
305     = $self->Message::Util::delete_comment_to_array ($body)
306     if $self->{option}->{use_comment};
307     $body =~ s/^$REG{WSP}+//; $body =~ s/$REG{WSP}+$//;
308     if ($self->{option}->{date_format} eq 'unix') {
309     $self->{date_time} = int ($body);
310 wakaba 1.13 } elsif (!$body) {
311     return $self;
312 wakaba 1.9 } elsif ($body =~ /^$REG{M_dt_rfc822}$/x) {
313 wakaba 1.1 my ($day, $month, $year, $hour, $minute, $second, $zone)
314     = ($1, uc $2, $3, $4, $5, $6, uc $7);
315     $month = $MONTH{$month} || 1;
316 wakaba 1.9 $year = $self->_obvious_year ($year) if length($year)<4;
317 wakaba 1.1 my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
318     eval '$self->{date_time} = timegm_nocheck
319     ($second, $minute-($zone_sign*$zone_minute), $hour-($zone_sign*$zone_hour),
320     $day, $month-1, $year);';
321 wakaba 1.2 $self->{secfrac} = '';
322     $self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
323 wakaba 1.14 } elsif ($body =~ /^$REG{M_dt_rfc3339}$/x) {
324 wakaba 1.9 my ($year,$month,$day,$hour,$minute,$second,$secfrac,$zone)
325     = ($1, $2, $3, $4, $5, $6, $7, $8);
326     my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
327 wakaba 1.2 eval '$self->{date_time} = timegm_nocheck
328     ($second, $minute-($zone_sign*$zone_minute), $hour-($zone_sign*$zone_hour),
329     $day, $month-1, $year);';
330     $self->{secfrac} = $secfrac;
331 wakaba 1.1 $self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
332 wakaba 1.9 } elsif ($body =~ /^$REG{M_dt_rfc733}$/x) {
333 wakaba 1.1 my ($day, $month, $year, $hour, $minute, $second, $zone)
334     = ($1, uc $2, $3, $4, $5, $6, uc $7);
335     $month = $MONTH{$month} || 1;
336 wakaba 1.9 $year = $self->_obvious_year ($year) if length($year)<4;
337 wakaba 1.1 my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
338     eval '$self->{date_time} = timegm_nocheck
339     ($second, $minute-($zone_sign*$zone_minute), $hour-($zone_sign*$zone_hour),
340     $day, $month-1, $year);';
341 wakaba 1.2 $self->{secfrac} = '';
342     $self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
343 wakaba 1.9 } elsif ($body =~ /^$REG{M_dt_rfc724}$/x) {
344 wakaba 1.2 my ($month, $day, $year, $hour, $minute, $second, $zone)
345     = ($1, $2, $3, $4, $5, $6, uc $7);
346 wakaba 1.9 $year = $self->_obvious_year ($year) if length($year)<4;
347 wakaba 1.2 my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
348     eval '$self->{date_time} = timegm_nocheck
349     ($second, $minute-($zone_sign*$zone_minute), $hour-($zone_sign*$zone_hour),
350     $day, $month-1, $year);';
351     $self->{secfrac} = '';
352 wakaba 1.1 $self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
353 wakaba 1.9 #} elsif ($body =~ /^[0-9]+$/) {
354     # $self->{date_time} = $&;
355 wakaba 1.1 } else {
356 wakaba 1.9 ## From HTTP::Date (revision 1.40) by Gisle Aas
357     #$body =~ s/^\s+//; # kill leading space
358     $body =~ s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday
359     my ($day, $month, $year, $hour, $minute, $second);
360     my ($secfrac, $zone, $ampm) = ('', $self->{option}->{zone_default_string});
361    
362     # Then we are able to check for most of the formats with this regexp
363     (($day,$month,$year,$hour,$minute,$second,$zone) =
364     $body =~ m"^
365     (\d\d?) # day
366     (?:\s+|[-\/])
367     (\w+) # month
368     (?:\s+|[-\/])
369     (\d+) # year
370     (?:
371     (?:\s+|:) # separator before clock
372     (\d\d?):(\d\d) # hour:min
373     (?::(\d\d))? # optional seconds
374     )? # optional clock
375     \s*
376     ([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone
377     $"x)
378    
379     ||
380    
381     # Try the ctime and asctime format
382     (($month, $day, $hour, $minute, $second, $zone, $year) =
383     $body =~ m"^
384     (\w{1,3}) # month
385     \s+
386     (\d\d?) # day
387     \s+
388     (\d\d?):(\d\d) # hour:min
389     (?::(\d\d))? # optional seconds
390     \s+
391     (?:([A-Za-z]+)\s+)? # optional timezone
392     (\d+) # year
393     $"x)
394    
395     ||
396    
397     # Then the Unix 'ls -l' date format
398     (($month, $day, $year, $hour, $minute, $second) =
399     $body =~ m"^
400     (\w{3}) # month
401     \s+
402     (\d\d?) # day
403     \s+
404     (?:
405     (\d\d\d\d) | # year
406     (\d{1,2}):(\d{2}) # hour:min
407     (?::(\d\d))? # optional seconds
408     )
409     $"x)
410    
411     ||
412    
413     # ISO 8601 format '1996-02-29 12:00:00 -0100' and variants
414     (($year, $month, $day, $hour, $minute, $second, $secfrac, $zone) =
415     $body =~ m"^
416     (\d{4}) # year
417     [-\/]?
418     (\d\d?) # numerical month
419     [-\/]?
420     (\d\d?) # day
421     (?:
422     (?:\s+|[-:Tt]) # separator before clock
423     (\d\d?):?(\d\d) # hour:min
424     (?:
425     :?
426     (\d\d)
427     (?:\.?(\d+))? ## optional second frac.
428     )? # optional seconds
429     )? # optional clock
430     \s*
431     ([-+]?\d\d?:?(:?\d\d)?
432     |Z|z)? # timezone (Z is 'zero meridian', i.e. GMT)
433    
434     $"x)
435    
436     ||
437    
438     # ISO 8601 like format '96-02-29 2:0:0 -0100' and variants
439     (($year, $month, $day, $hour, $minute, $second, $secfrac, $zone) =
440     $body =~ m"^
441     (\d+) # year
442     [-/]
443     (\d\d?) # numerical month
444     [-/]
445     (\d\d?) # day
446     (?:
447     (?:\s+|[-:Tt]) # separator before clock
448     (\d\d?):(\d+) # hour:min
449     (?:
450     :
451     (\d+)
452     (?:\.(\d+)) ## optional second frac.
453     )? # optional seconds
454     )? # optional clock
455     \s*
456     ([-+]?\d+(:\d+)?
457     |Z|z)? # timezone (Z is 'zero meridian', i.e. GMT)
458    
459     $"x)
460    
461     ||
462    
463     # Windows 'dir' 11-12-96 03:52PM
464     (($month, $day, $year, $hour, $minute, $ampm) =
465     $body =~ m"^
466     (\d{2}) # numerical month
467     -
468     (\d{2}) # day
469     -
470     (\d{2}) # year
471     \s+
472     (\d\d?):(\d\d)([APap][Mm]) # hour:min AM or PM
473     $"x)
474    
475     #||
476     #return; # unrecognized format
477     ;
478    
479     $day ||= 1;
480     # Translate month name to number
481 wakaba 1.12 $month ||= 1;
482 wakaba 1.9 $month = $MONTH{uc $month}
483 wakaba 1.12 || int ($month);
484 wakaba 1.9
485     # If the year is missing, we assume first date before the current,
486     # because of the formats we support such dates are mostly present
487     # on "ls -l" listings.
488     unless (defined $year) {
489     my $cur_mon;
490     ($cur_mon, $year) = (localtime)[4, 5];
491     $year += 1900; $cur_mon++;
492     $year-- if $month > $cur_mon;
493     } elsif (length($year) < 3) {
494     $year = $self->_obvious_year ($year);
495     }
496    
497     # Make sure clock elements are defined
498     $hour = 0 unless defined($hour);
499     $minute = 0 unless defined($minute);
500     $second = 0 unless defined($second);
501    
502     # Compensate for AM/PM
503     if ($ampm) {
504     $ampm = uc $ampm;
505     $hour = 0 if $hour == 12 && $ampm eq 'AM';
506     $hour += 12 if $ampm eq 'PM' && $hour != 12;
507     }
508    
509     my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
510     eval '$self->{date_time} = timegm_nocheck
511     ($second, $minute-($zone_sign*$zone_minute), $hour-($zone_sign*$zone_hour),
512     $day, $month-1, $year);';
513     $self->{secfrac} = $secfrac;
514     $self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
515 wakaba 1.1 }
516     $self;
517     }
518    
519 wakaba 1.10 sub zone ($;$) {
520     my $self = shift;
521     my $newzone = shift;
522 wakaba 1.12 if (ref $newzone) {
523     $self->{option}->{zone} = $newzone;
524     } elsif (length $newzone) {
525 wakaba 1.10 $self->{option}->{zone} = [$self->_zone_string_to_array ($newzone)];
526     }
527     $self->{option}->{zone};
528     }
529    
530 wakaba 1.9 ## Find "obvious" year
531     sub _obvious_year ($$) {
532     my $self = shift;
533     my $year = shift;
534     if ($self->{option}->{format} =~ /mail|news/) {
535     ## RFC 2822
536     if ( 0 <=$year && $year < 50) {$year += 2000}
537     elsif (50 < $year && $year < 1000) {$year += 1900}
538     } else {
539     ## RFC 2616
540     my $cur_yr = (localtime)[5] + 1900;
541     my $m = $cur_yr % 100;
542     my $tmp = $year;
543     $year += $cur_yr - $m;
544     $m -= $tmp;
545     $year += ($m > 0) ? 100 : -100 if abs($m) > 50;
546     }
547     $year;
548     }
549    
550     =back
551    
552     =head1 METHODS
553    
554     =over 4
555    
556    
557 wakaba 1.4 =head2 $self->unix_time ([$new_time])
558    
559     Returns or set the unix-time (seconds from the Epoch).
560    
561     =cut
562    
563     sub unix_time ($;$) {
564     my $self = shift;
565     my $new_time = shift;
566     if (defined $new_time) {
567 wakaba 1.6 $self->{date_time} = $new_time + 0;
568 wakaba 1.4 }
569     $self->{date_time};
570     }
571    
572 wakaba 1.10 sub set_datetime ($@) {
573     my $self = shift;
574     my ($year,$month,$day,$hour,$minute,$second,%misc) = @_;
575     my ($zone_sign, $zone_hour, $zone_minute)
576     = $self->_zone_string_to_array ($misc{zone});
577     eval '$self->{date_time} = timegm_nocheck
578     ($second, $minute-($zone_sign*$zone_minute), $hour-($zone_sign*$zone_hour),
579     $day, $month-1, $year);';
580     $self->{secfrac} = $misc{secfrac};
581     $self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
582     }
583    
584 wakaba 1.2 =head2 $self->second_fraction ([$new_fraction])
585    
586     Returns or set the decimal fraction of a second.
587     Value is a string containing of only [0-9]
588     or empty string.
589    
590 wakaba 1.15 Note that this implemention is temporary and in the near future
591     it can be changed.
592    
593 wakaba 1.2 =cut
594    
595     sub second_fraction ($;$) {
596     my $self = shift;
597     my $new_fraction = shift;
598     if (defined $new_fraction) {
599     $self->{secfrac} = $new_fraction unless $new_fraction =~ /[^0-9]/;
600     }
601     $self->{secfrac};
602     }
603    
604 wakaba 1.9 =item $field-body = $date->stringify ()
605 wakaba 1.1
606     Returns C<field-body> as a string.
607    
608     =cut
609    
610 wakaba 1.2 sub stringify ($;%) {
611 wakaba 1.1 my $self = shift;
612 wakaba 1.9 my %o = @_;
613     my %option = %{$self->{option}};
614     for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
615     unless ($option{format_template}) {
616 wakaba 1.14 if ($option{format} =~ /mail-rfc2822|news-usefor|mail-rfc822\+rfc1123|news-son-of-rfc1036|mime/) {
617 wakaba 1.9 $option{format_template} = '%Wdy(local);, %DD(local); %Mon(local); %YYYY(local); %HH(local);:%TT(local);:%SS(local); %zsign;%zHH;%zTT;';
618     } elsif ($option{format} =~ /http/) {
619     $option{format_template} = '%Wdy;, %DD; %Mon; %YYYY; %HH;:%TT;:%SS; GMT';
620 wakaba 1.14 } elsif ($option{format} =~ /mail-rfc822|news-rfc1036/) {
621 wakaba 1.9 $option{format_template} = '%Wdy(local);, %DD(local); %Mon(local); %YY(local); (%YYYY(local);) %HH(local);:%TT(local);:%SS(local); %zsign;%zHH;%zTT;';
622 wakaba 1.14 } elsif ($option{format} =~ /news-rfc850/) {
623 wakaba 1.9 $option{format_template} = '%Weekday;, %DD;-%Mon;-%YY; %HH;:%TT;:%SS; GMT';
624     } elsif ($option{format} =~ /asctime/) {
625     $option{format_template} = '%Wdy; %Mon; %DD(pad=>SP); %HH;:%MM;:%SS; %YYYY;';
626     #} elsif ($option{format} =~ /date\(1\)/) {
627     # $option{format_template} = '%Wdy; %Mon; %DD(pad=>SP); %HH;:%MM;:%SS; GMT %YYYY;';
628 wakaba 1.14 } elsif ($option{format} =~ /un[i*]x/) { ## ;-)
629 wakaba 1.9 $option{format_template} = '%unix;';
630 wakaba 1.14 } else { ## RFC 3339 (IETF's ISO 8601)
631 wakaba 1.9 $option{format_template} = '%YYYY(local);-%MM(local);-%DD(local);T%HH(local);:%TT(local);:%SS(local);%frac(prefix=>.);%zsign;%zHH;:%zTT;';
632     }
633 wakaba 1.2 }
634 wakaba 1.9 $self->_date2str (\%option)
635     . (($option{output_comment} && @{$self->{comment}} > 0)?
636     ' ' . $self->_comment_stringify: '');
637     }
638     *as_string = \&stringify;
639     *as_plain_string = \&stringify;
640 wakaba 1.10 ## You should use stringify instead of as_rfc2822_time
641     sub as_rfc2822_time ($@) {
642     shift->stringify (-format => 'mail-rfc2822', @_);
643     }
644 wakaba 1.9
645 wakaba 1.12 sub _date2str ($\%\%) {
646 wakaba 1.9 my $self = shift;
647     my $option = shift;
648 wakaba 1.12 my $gparam = shift;
649 wakaba 1.11 my $template = $option->{format_template};
650     my $time = $self->{date_time};
651     $time = $option->{date_time} if defined $option->{date_time};
652     my $zone = $option->{zone};
653 wakaba 1.12 if (ref $zone) { }
654 wakaba 1.9 elsif (length $zone) {$zone = [$self->_zone_string_to_array ($zone)]}
655     my $l_time = $time + $zone->[0] * ($zone->[1] * 60 + $zone->[2]) * 60;
656     my %time = (unix => $time,
657     tm => [gmtime ($time)],
658     l_unix => $l_time,
659     l_tm => [gmtime ($l_time)],
660     zone => $zone);
661     $template =~ s{%([A-Za-z0-9_]+)(?:\(([A-Za-z0-9,.:\x09\x20=>_-]*)\))?;}{
662     my ($f, $a) = ($1, $2);
663 wakaba 1.11 my $function = $option->{fmt2str}->{$f};
664 wakaba 1.9 if (ref $function) {
665     my %a;
666     for (split /[\x09\x20]*,[\x09\x20]*/, $a) {
667     if (/^([^=]+)=>(.+)$/) {$a{$1} = $2}
668     else {$a{$_} = 1}
669     }
670     $a{_prefix} = $a{local}? 'l_': '';
671     $a{_fmt} = $a{pad} eq 'SP'? '%2d':
672     $a{pad} eq 'none'? '%d':
673     '%02d';
674 wakaba 1.12 my $r = &$function ($self, \%time, \%a, $gparam);
675 wakaba 1.9 length $r? $a{prefix}.$r.$a{suffix}: '';
676     } elsif (length $function) {
677     $function;
678     } else {
679     "[$f: undef]";
680     }
681     }gex;
682     $template;
683 wakaba 1.1 }
684    
685 wakaba 1.2
686 wakaba 1.1
687     sub _zone_string_to_array ($$;$) {
688     my $self = shift;
689     my $zone = shift;
690 wakaba 1.12 return (+1, 0, 0) unless defined $zone;
691 wakaba 1.1 my $format = shift;
692     my @azone = [+1, 0, 0];
693 wakaba 1.9 $zone =~ tr/\x09\x20//d;
694 wakaba 1.13 if ($zone =~ /^[^0-9+-]+(?:([+-]?)([0-9]{1,2}))(?::([0-9]{1,2}))?/) {
695     ## $ENV{TZ} format, but is not fully supported
696     my ($s, $h, $m) = ($1, $2, $3);
697     $s ||= '+'; $s =~ tr/+-/-+/;
698     @azone = ("${s}1", 0+$h, 0+$m);
699     } elsif ($zone =~ /([+-])([0-9][0-9])([0-9][0-9])/) {
700 wakaba 1.9 @azone = ("${1}1", $2, $3);
701     } elsif ($zone =~ /([+-]?)([0-9]+)(?:[:.-]([0-9]+))?/) {
702 wakaba 1.13 @azone = ("${1}1", $2, 0+$3);
703 wakaba 1.1 } else { $zone =~ tr/-//d;
704     if (ref $ZONE{$zone}) {@azone = @{$ZONE{$zone}}}
705     elsif ($zone) {@azone = (-1, 0, 0)}
706     }
707     # }
708     @azone;
709     }
710    
711 wakaba 1.9 =item $option-value = $date->option ($option-name)
712    
713     Gets option value.
714    
715     =item $date->option ($option-name, $option-value, ...)
716    
717     Set option value(s). You can pass multiple option name-value pair
718     as parameter when setting.
719    
720     =item $clone = $date->clone ()
721    
722     Returns a copy of the object.
723    
724     =cut
725    
726     ## option, clone, method_available: Inherited
727    
728 wakaba 1.1 =head1 EXAMPLE
729    
730 wakaba 1.2 use Message::Field::Date;
731 wakaba 1.1
732 wakaba 1.9 print Message::Field::Date->new (unix => time,
733     -zone => '+0900'),"\n"; ## Thu, 16 May 2002 17:53:44 +0900
734     print Message::Field::Date->new (unix => time,
735     -format_template => ## Century: 21, Year: 02, Month: 05
736     'Century: %CC;, Year: %YY;, Month: %MM;'),"\n";
737    
738 wakaba 1.2 my $field_body = '04 Feb 2002 00:12:33 CST';
739     my $field = Message::Field::Date->parse ($field_body);
740 wakaba 1.1
741 wakaba 1.9 print "RFC 2822:\t", $field->stringify (-format => 'mail-rfc2822'), "\n";
742     print "HTTP preferred:\t", $field->stringify (-format => 'http-1.1'), "\n";
743     print "ISO 8601:\t", $field->stringify (-format => 'mail-cpim'), "\n";
744     ## RFC 2822: Mon, 04 Feb 2002 00:12:33 -0600
745     ## HTTP preferred: Mon, 04 Feb 2002 06:12:33 GMT
746     ## ISO 8601: 2002-02-04T00:12:33-06:00
747 wakaba 1.1
748     =head1 LICENSE
749    
750     Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
751    
752     This program is free software; you can redistribute it and/or modify
753     it under the terms of the GNU General Public License as published by
754     the Free Software Foundation; either version 2 of the License, or
755     (at your option) any later version.
756    
757     This program is distributed in the hope that it will be useful,
758     but WITHOUT ANY WARRANTY; without even the implied warranty of
759     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
760     GNU General Public License for more details.
761    
762     You should have received a copy of the GNU General Public License
763     along with this program; see the file COPYING. If not, write to
764     the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
765     Boston, MA 02111-1307, USA.
766    
767     =head1 CHANGE
768    
769     See F<ChangeLog>.
770 wakaba 1.16 $Date: 2002/08/01 06:42:38 $
771 wakaba 1.1
772     =cut
773    
774     1;
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24