/[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.20 - (hide annotations) (download)
Sat Dec 28 08:45:50 2002 UTC (21 years, 11 months ago) by wakaba
Branch: MAIN
CVS Tags: before-dis2-200411, manakai-release-0-3-2, manakai-release-0-3-1, manakai-release-0-4-0, manakai-200612, HEAD
Branch point for: branch-suikawiki-1, experimental-xml-parser-200401
Changes since 1.19: +6 -4 lines
*** empty log message ***

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

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24