| 1 |
|
| 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 |
$VERSION=do{my @r=(q$Revision: 1.19 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
|
| 15 |
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 |
APR => 4, APRIL => 4, ARL => 4,
|
| 97 |
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 |
AHST => [-1, 10, 0], ## Alaska-Hawaii Standard
|
| 161 |
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 |
#EASTERN
|
| 179 |
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 |
#GDT => [+1, 2, 0], ## German Daylight
|
| 189 |
#GM
|
| 190 |
GMT => [+1, 0, 0], ## Greenwich Mean 733, 822
|
| 191 |
#GST => [-1, 3, 0], ## Greenland Standard
|
| 192 |
GST => [+1, 1, 0], ## German Standard
|
| 193 |
#GST => [+1, 10, 0], ## Guam Standard
|
| 194 |
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 |
#JT => [+1, 9, 0], ## Japan Central Standard
|
| 205 |
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 |
#LON
|
| 211 |
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 |
MOUNTAIN => [-1, 7, 0], ## (maybe) (NA)Mountain Standard 733, 822
|
| 220 |
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 |
NZS => [+1, 12, 0], ## (maybe) New Zealand Standard
|
| 230 |
NZST => [+1, 12, 0], ## New Zealand Standard
|
| 231 |
PDT => [-1, 7, 0], ## (NA)Pacific Daylight 733, 822
|
| 232 |
#PM
|
| 233 |
PST => [-1, 8, 0], ## (NA)Pacific Standard 733, 822
|
| 234 |
#SAMST
|
| 235 |
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 |
UNDEFINED => [-1, 0, 0], ## undefined
|
| 241 |
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 |
$self->{date_time} = 0;
|
| 287 |
$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 |
$option{format_parameters} ||= {};
|
| 648 |
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 |
&Message::Util::sprintxf ($option{format_template}, {
|
| 676 |
comment => $c,
|
| 677 |
fmt2str => ($option{format_macros} || \%FMT2STR),
|
| 678 |
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 |
%{ $option{format_parameters} },
|
| 686 |
});
|
| 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 |
} elsif ($zone =~ /^GMT([+-])([0-9][0-9]?)([0-9][0-9])?/i) {
|
| 708 |
@azone = ("${1}1", 0+$2, 0+$3);
|
| 709 |
} elsif ($zone =~ /([+-])([0-9][0-9])([0-9][0-9])/) {
|
| 710 |
@azone = ("${1}1", $2, $3);
|
| 711 |
} elsif ($zone =~ /([+-])([0-9])([0-9][0-9])/) {
|
| 712 |
@azone = ("${1}1", $2, $3);
|
| 713 |
} 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 |
$Date: 2002/11/13 08:08:51 $
|
| 783 |
|
| 784 |
=cut
|
| 785 |
|
| 786 |
1;
|
Parent Directory
| 
Revision Log