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