Message/Field/Date.pm


=head1 NAME

Message::Field::Date Perl module

=head1 DESCRIPTION

Perl module for RFC 822/2822 date style C<field>s.

=cut

package Message::Field::Date;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(%DEFAULT %MONTH %REG $VERSION %ZONE);
$VERSION = '1.00';

use Time::Local 'timegm_nocheck';
use overload '""' => sub {shift->stringify};

$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*\x29/;
$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;

$REG{WSP} = qr/[\x20\x09]+/;
$REG{FWS} = qr/[\x20\x09]*/;
$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
$REG{M_rfc2822_date_time} = qr/([0-9]+)$REG{FWS}([A-Za-z]+)$REG{FWS}([0-9]+)$REG{WSP}+([0-9]+)$REG{FWS}:$REG{FWS}([0-9]+)(?:$REG{FWS}:$REG{FWS}([0-9]+))?$REG{FWS}([A-Za-z]+|[+-]$REG{WSP}*[0-9]+)/;
$REG{M_rfc733_date_time} = qr/([0-9]{1,2})$REG{FWS}(?:-$REG{FWS})?([A-Za-z]+)$REG{FWS}(?:-$REG{FWS})?([0-9]+)$REG{WSP}+([0-9][0-9])$REG{FWS}(?::$REG{FWS})?([0-9][0-9])(?:$REG{FWS}(?::$REG{FWS})?([0-9][0-9]))?$REG{FWS}((?:-$REG{FWS})?[A-Za-z]+|[+-]$REG{WSP}*[0-9]+)/;
$REG{M_rfc724_slash_date} = qr#([0-9]+)$REG{FWS}/$REG{FWS}([0-9]+)$REG{FWS}/$REG{FWS}([0-9]+)$REG{WSP}+([0-9][0-9])$REG{FWS}(?::$REG{FWS})?([0-9][0-9])(?:$REG{FWS}(?::$REG{FWS})?([0-9][0-9]))?$REG{FWS}((?:-$REG{FWS})?[A-Za-z]+|[+-]$REG{WSP}*[0-9]+)#;
$REG{M_asctime} = qr/[A-Za-z]+$REG{FWS}([A-Za-z]+)$REG{FWS}([0-9]+)$REG{WSP}+([0-9]+)$REG{FWS}:$REG{FWS}([0-9]+)$REG{FWS}:$REG{FWS}([0-9]+)$REG{WSP}+([0-9]+)/;
$REG{M_iso8601_date_time} = qr/([0-9]+)-([0-9]+)-([0-9]+)[Tt]([0-9]+):([0-9]+):([0-9]+)(?:.([0-9]+))?(?:[Zz]|([+-])([0-9]+):([0-9]+))/;

%DEFAULT = (
  format        => 'rfc2822',
  output_day_of_week    => 1,
  output_zone_string    => 0,
  zone  => [+1, 0, 0],
  zone_letter   => +1,
);

## format       rfc733  [RFC733]
##              rfc2822 [RFC822] + [RFC1123], [RFC2822]

%MONTH = (
  JAN   => 1,   JANUARY => 1,
  FEB   => 2,   FEBRUARY        => 2,
  MAR   => 3,   MARCH   => 3,
  APR   => 4,   APRIL   => 4,
  MAY   => 5,
  JUN   => 6,   JUNE    => 6,
  JUL   => 7,   JULY    => 7,
  AUG   => 8,   AUGUST  => 8,
  SEP   => 9,   SEPTEMBER       => 9,
  OCT   => 10,  OCTOBER => 10,
  NOV   => 11,  NOVEMBER        => 11,
  DEC   => 12,  DECEMBER        => 12,
);

%ZONE = (
  ADT   => [-1,  3,  0],        ## 733
  AST   => [-1,  4,  0],        ## 733
  BDT   => [-1, 10,  0],        ## 733
  BST   => [-1, 11,  0],        ## 733
  #BST  => [+1,  1,  0],
  CDT   => [-1,  5,  0],        ## 733, 822, 2822
  CET   => [+1,  1,  0],
  CST   => [-1,  6,  0],        ## 733, 822, 2822
  EDT   => [-1,  4,  0],        ## 733, 822, 2822
  EET   => [+1,  2,  0],        ## 1947
  EST   => [-1,  5,  0],        ## 733, 822, 2822
  GDT   => [+1,  1,  0],        ## 724
  GMT   => [+1,  0,  0],        ## 733, 822, 2822
  HDT   => [-1,  9,  0],        ## 733
  HKT   => [+1,  8,  0],
  HST   => [-1, 10,  0],        ## 733
  IDT   => [+1,  3,  0],
  IST   => [+1,  2,  0],        ## Israel standard time
  #IST  => [+1,  5, 30],        ## Indian standard time
  JST   => [+1,  9,  0],
  MDT   => [-1,  6,  0],        ## 733, 822, 2822
  MET   => [+1,  0,  0],
  METDST        => [+2,  0,  0],
  MST   => [-1,  7,  0],        ## 733, 822, 2822
  NST   => [-1,  3, 30],        ## 733
  PDT   => [-1,  7,  0],        ## 733, 822, 2822
  PST   => [-1,  8,  0],        ## 733, 822, 2822
  YDT   => [-1,  8,  0],        ## 733
  YST   => [-1,  9,  0],        ## 733
  UT    => [+1,  0,  0],        ## 822, 2822
);

=head2 $self->_option_zone_letter (-1/0/+1)

Set convertion rule between one letter zone name
(military format) and time.

C<+1> set it as standard value.  (For exmaple, 'A' means
'+0100'.)  C<-1> reverses their sign, for example, 'A'
means '-0100'.  BNF comment of RFC 733 and 822 has typo
so quite a few implemention takes these values incorrectly.
As a result, these zone names carry no worthful information.
RFC 2822 recommends these names be taken as '-0000' (i.e.
unknown zone).  C<-2> means it.

=cut

sub _option_zone_letter ($$) {
  my $self = shift;
  my $mode = shift;
  my $i = 0;
  if ($mode == -2) {
    for my $letter ('A'..'Z') {$ZONE{$letter} = [-1, 0, 0]} return $self;
  }
  for my $letter ('Z', 'A'..'I', 'K'..'M') {
    $ZONE{$letter} = [+1*$mode, $i++, 0];
  }  $i = 1;
  for my $letter ('N'..'Y') {
    $ZONE{$letter} = [-1*$mode, $i++, 0];
  }
  $self;
}

=head2 Message::Field::Date->new ()

Return empty Message::Field::Date object.

=cut

sub new ($;%) {
  my $class = shift;
  my %option = @_;
  $option{date_time} ||= time; $option{date_time} = 0 if $option{unknown};
  my $self = bless {option => {@_}, date_time => $option{date_time}}, $class;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self->_option_zone_letter ($self->{option}->{zone_letter});
  $self;
}

=head2 Message::Field::Date->parse ($unfolded_field_body)

Parse date style C<field-body>.

=cut

sub parse ($$;%) {
  my $class = shift;  my $field_body = shift;
  my $self = bless {option => {@_}}, $class;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self->_option_zone_letter ($self->{option}->{zone_letter});
  $field_body = $self->delete_comment ($field_body);
  if ($field_body =~ /$REG{M_rfc2822_date_time}/) {
    my ($day, $month, $year, $hour, $minute, $second, $zone)
     = ($1, uc $2, $3, $4, $5, $6, uc $7);
    $month = $MONTH{$month} || 1;
    if    ( 0 < $year && $year <   49) {$year += 2000}
    elsif (50 < $year && $year < 1000) {$year += 1900}
    my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
    eval '$self->{date_time} = timegm_nocheck 
      ($second, $minute-($zone_sign*$zone_minute), $hour-($zone_sign*$zone_hour), 
       $day, $month-1, $year);';
    $self->{secfrac} = '';
    $self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
  } elsif ($field_body =~ /$REG{M_iso8601_date_time}/) {
    my ($year,$month,$day,$hour,$minute,$second,$secfrac,
        $zone_sign,$zone_hour,$zone_minute)
     = ($1, $2, $3, $4, $5, $6, $7, "${8}1", $9, $10);
    eval '$self->{date_time} = timegm_nocheck 
      ($second, $minute-($zone_sign*$zone_minute), $hour-($zone_sign*$zone_hour), 
       $day, $month-1, $year);';
    $self->{secfrac} = $secfrac;
    $self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
  } elsif ($field_body =~ /$REG{M_rfc733_date_time}/) {
    my ($day, $month, $year, $hour, $minute, $second, $zone)
     = ($1, uc $2, $3, $4, $5, $6, uc $7);
    $month = $MONTH{$month} || 1;
    if    ( 0 < $year && $year <   49) {$year += 2000}
    elsif (50 < $year && $year < 1000) {$year += 1900}
    my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
    eval '$self->{date_time} = timegm_nocheck 
      ($second, $minute-($zone_sign*$zone_minute), $hour-($zone_sign*$zone_hour), 
       $day, $month-1, $year);';
    $self->{secfrac} = '';
    $self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
  } elsif ($field_body =~ /$REG{M_asctime}/) {
    my ($month, $day, $hour, $minute, $second, $year) = (uc $1, $2, $3, $4, $5, $6);
    $month = $MONTH{$month} || 1;
    if    ( 0 < $year && $year <   49) {$year += 2000}
    elsif (50 < $year && $year < 1000) {$year += 1900}
    eval '$self->{date_time} = timegm_nocheck 
      ($second, $minute, $hour, $day, $month-1, $year);';
    $self->{secfrac} = '';
    $self->{option}->{zone} = [-1, 0, 0];
  } elsif ($field_body =~ /$REG{M_rfc724_slash_date}/) {
    my ($month, $day, $year, $hour, $minute, $second, $zone)
     = ($1, $2, $3, $4, $5, $6, uc $7);
    if    ( 0 < $year && $year <   49) {$year += 2000}
    elsif (50 < $year && $year < 1000) {$year += 1900}
    my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
    eval '$self->{date_time} = timegm_nocheck 
      ($second, $minute-($zone_sign*$zone_minute), $hour-($zone_sign*$zone_hour), 
       $day, $month-1, $year);';
    $self->{secfrac} = '';
    $self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
  } else {
    $self->{date_time} = 0;
    $self->{secfrac} = '';
  }
  $self;
}

=head2 $self->second_fraction ([$new_fraction])

Returns or set the decimal fraction of a second.
Value is a string containing of only [0-9]
or empty string.

=cut

sub second_fraction ($;$) {
  my $self = shift;
  my $new_fraction = shift;
  if (defined $new_fraction) {
    $self->{secfrac} = $new_fraction unless $new_fraction =~ /[^0-9]/;
  }
  $self->{secfrac};
}

=head2 $self->stringify ()

Returns C<field-body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %option = @_;
  $option{format} ||= $self->{option}->{format} || $DEFAULT{format};
  if ($option{format} eq 'iso8601') {
    $self->as_iso8601_time (%option);
  } elsif ($option{format} eq 'http') {
    $self->as_http_time (%option);
  } elsif ($option{format} eq 'unix') {
    $self->as_unix_time (%option);
  } else { #if ($option{format} eq 'rfc2822') {
    $self->as_rfc2822_time (%option);
  }
}

sub as_plain_string ($;%) {
  my $self = shift;
  $self->stringify (@_);
}

=head2 $self->as_unix_time ([%options])

Returns date-time value as the unixtime format
(seconds counted from the Epoch, 1970-01-01 00:00:00).

=cut

sub as_unix_time ($;%) {
  my $self = shift;
  $self->{date_time};
}

=head2 $self->as_rfc2822_time ([%options])

Returns C<date-time> value as RFC 2822 format.
(It is also known as RFC 822 format modified by RFC 1123)

Option C<output_day_of_week> enables to output
C<day-of-week> string.  (Default C<+1>)

If option C<output_zone_string> > 0, use timezone
name C<GMT> instead of numeric representation.
This option is intended to be used for C<HTTP-date>
with option C<zone>.  (Default C<-1>)

Option C<zone> specifies output time zone with
RFC 2822 numeric representation such as C<+0000>.
Unless this option, time zone of input data 
(when C<parsed> method is used) or default value
C<+0000> is used.

=cut

sub as_rfc2822_time ($;%) {
  my $self = shift;
  my %option = @_;
  my $time = $self->{date_time};
  my @zone = [+1, 0, 0];
  if (ref $option{zone}) {@zone = @{$option{zone}}}
  elsif ($option{zone}) {@zone = $self->_zone_string_to_array ($option{zone})}
  elsif (ref $self->{option}->{zone}) {@zone = @{$self->{option}->{zone}}}
  elsif ($self->{option}->{zone}) 
    {@zone = $self->{option}->_zone_string_to_array ($self->{option}->{zone})}
  $option{output_day_of_week} ||= $self->{option}->{output_day_of_week} 
                              || $DEFAULT{output_day_of_week};
  $option{output_zone_string} ||= $self->{option}->{output_zone_string} 
                              || $DEFAULT{output_zone_string};
  
  $time += $zone[0] * ($zone[1] * 60 + $zone[2]) * 60;
  my ($sec,$min,$hour,$day,$month,$year,$day_of_week) = gmtime ($time);
  $month = (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$month];
  $year += 1900 if $year < 1900;
  $day_of_week = (qw(Sun Mon Tue Wed Thr Fri Sat))[$day_of_week] .', ';
  
  ($option{output_day_of_week}>0? $day_of_week: '').
  sprintf('%02d %s %s %02d:%02d:%02d %s',
   $day,$month,$year,$hour,$min,$sec,
   ($option{output_zone_string}>0 && $zone[0]>0 && $zone[1]+$zone[2]==0? 
    'GMT': sprintf('%s%02d%02d',$zone[0]>0?'+':'-',@zone[1,2]))
  );
}

=head2 $self->as_http_time ([%options])

Returns C<date-time> value as HTTP preferred format.
This method is same as 
C<$self->as_rfc2822_time (output_zone_string => 1, zone => '+0000')>.

=cut

sub as_http_time ($;%) {
  my $self = shift;
  my %option = @_;
  $option{output_zone_string} = 1;
  $option{zone} = [+1, 0, 0];
  $self->as_rfc2822_time (%option);
}

=head2 $self->as_iso8601_time ([%options])

Returns C<date-time> value as ISO 8601 format.

If option C<output_zone_string> > 0, use timezone
name C<Z> instead of numeric representation.
This option is intended to be used for C<HTTP-date>
with option C<zone>.  (Default C<-1>)

Option C<zone> specifies output time zone with
RFC 2822 numeric representation such as C<+0000>.
Unless this option, time zone of input data 
(when C<parsed> method is used) or default value
C<+0000> is used.

=cut

sub as_iso8601_time ($;%) {
  my $self = shift;
  my %option = @_;
  my $time = $self->{date_time};
  $option{output_zone_string} ||= $self->{option}->{output_zone_string} 
                              || $DEFAULT{output_zone_string};
  my @zone = [+1, 0, 0];
  if (ref $option{zone}) {@zone = @{$option{zone}}}
  elsif ($option{zone}) {@zone = $self->_zone_string_to_array ($option{zone})}
  elsif (ref $self->{option}->{zone}) {@zone = @{$self->{option}->{zone}}}
  elsif ($self->{option}->{zone}) {@zone = $self->{option}->_zone_string_to_array ($self->{option}->{zone})}
  
  $time += $zone[0] * ($zone[1] * 60 + $zone[2]) * 60;
  my ($sec,$min,$hour,$day,$month,$year,$day_of_week) = gmtime ($time);
  $year += 1900 if $year < 1900;
  
  sprintf('%04d-%02d-%02dT%02d:%02d:%02d%s%s',
   $year,$month,$day,$hour,$min,$sec,
   ($self->{secfrac}? '.'.$self->{secfrac}: ''),
   ($option{output_zone_string}>0 && $zone[0]>0 && $zone[1]+$zone[2]==0? 
    'Z': sprintf('%s%02d:%02d',$zone[0]>0?'+':'-',@zone[1,2]))
  );
}

=head2 $self->delete_comment ($field_body)

Remove all C<comment> in given strictured C<field-body>.
This method is intended for internal use.

=cut

sub delete_comment ($$) {
  my $self = shift;
  my $body = shift;
  $body =~ s{($REG{quoted_string})|$REG{comment}}{
    my $o = $1;  $o? $o : ' ';
  }gex;
  $body;
}

sub _zone_string_to_array ($$;$) {
  my $self = shift;
  my $zone = shift;
  my $format = shift;
  my @azone = [+1, 0, 0];
  ## if $format eq rfc2822
    if ($zone =~ /([+-])$REG{FWS}([0-9][0-9])([0-9][0-9])/) {
      @azone = ("${1}1", $2, $3);
    } else { $zone =~ tr/-//d;
      if (ref $ZONE{$zone}) {@azone = @{$ZONE{$zone}}}
      elsif ($zone) {@azone = (-1, 0, 0)}
    }
  # }
  @azone;
}

=head1 EXAMPLE

  use Message::Field::Date;
  
  my $field_body = '04 Feb 2002 00:12:33 CST';
  my $field = Message::Field::Date->parse ($field_body);
  
  print "Un*xtime:\t", $field->as_unix_time, "\n";
  print "RFC 2822:\t", $field->as_rfc2822_time, "\n";
  print "HTTP preferred:\t", $field->as_http_time, "\n";
  print "ISO 8601:\t", $field->as_iso8601_time, "\n";

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::Date Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for RFC 822/2822 date style C<field>s.
9
10			=cut
11
12			package Message::Field::Date;
13			require 5.6.0;
14			use strict;
15			use re 'eval';
16			use vars qw(%DEFAULT %MONTH %REG $VERSION %ZONE);
17			$VERSION = '1.00';
18
19			use Time::Local 'timegm_nocheck';
20			use overload '""' => sub {shift->stringify};
21
22			$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*\x29/;
23			$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
24
25			$REG{WSP} = qr/[\x20\x09]+/;
26			$REG{FWS} = qr/[\x20\x09]*/;
27			$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
28			$REG{M_rfc2822_date_time} = qr/([0-9]+)$REG{FWS}([A-Za-z]+)$REG{FWS}([0-9]+)$REG{WSP}+([0-9]+)$REG{FWS}:$REG{FWS}([0-9]+)(?:$REG{FWS}:$REG{FWS}([0-9]+))?$REG{FWS}([A-Za-z]+\|[+-]$REG{WSP}*[0-9]+)/;
29			$REG{M_rfc733_date_time} = qr/([0-9]{1,2})$REG{FWS}(?:-$REG{FWS})?([A-Za-z]+)$REG{FWS}(?:-$REG{FWS})?([0-9]+)$REG{WSP}+([0-9][0-9])$REG{FWS}(?::$REG{FWS})?([0-9][0-9])(?:$REG{FWS}(?::$REG{FWS})?([0-9][0-9]))?$REG{FWS}((?:-$REG{FWS})?[A-Za-z]+\|[+-]$REG{WSP}*[0-9]+)/;
30	wakaba	1.2	$REG{M_rfc724_slash_date} = qr#([0-9]+)$REG{FWS}/$REG{FWS}([0-9]+)$REG{FWS}/$REG{FWS}([0-9]+)$REG{WSP}+([0-9][0-9])$REG{FWS}(?::$REG{FWS})?([0-9][0-9])(?:$REG{FWS}(?::$REG{FWS})?([0-9][0-9]))?$REG{FWS}((?:-$REG{FWS})?[A-Za-z]+\|[+-]$REG{WSP}*[0-9]+)#;
31			$REG{M_asctime} = qr/[A-Za-z]+$REG{FWS}([A-Za-z]+)$REG{FWS}([0-9]+)$REG{WSP}+([0-9]+)$REG{FWS}:$REG{FWS}([0-9]+)$REG{FWS}:$REG{FWS}([0-9]+)$REG{WSP}+([0-9]+)/;
32			$REG{M_iso8601_date_time} = qr/([0-9]+)-([0-9]+)-([0-9]+)[Tt]([0-9]+):([0-9]+):([0-9]+)(?:.([0-9]+))?(?:[Zz]\|([+-])([0-9]+):([0-9]+))/;
33	wakaba	1.1
34			%DEFAULT = (
35			format => 'rfc2822',
36			output_day_of_week => 1,
37	wakaba	1.2	output_zone_string => 0,
38	wakaba	1.1	zone => [+1, 0, 0],
39			zone_letter => +1,
40			);
41
42			## format rfc733 [RFC733]
43			## rfc2822 [RFC822] + [RFC1123], [RFC2822]
44
45			%MONTH = (
46			JAN => 1, JANUARY => 1,
47			FEB => 2, FEBRUARY => 2,
48			MAR => 3, MARCH => 3,
49			APR => 4, APRIL => 4,
50			MAY => 5,
51			JUN => 6, JUNE => 6,
52			JUL => 7, JULY => 7,
53			AUG => 8, AUGUST => 8,
54			SEP => 9, SEPTEMBER => 9,
55			OCT => 10, OCTOBER => 10,
56			NOV => 11, NOVEMBER => 11,
57			DEC => 12, DECEMBER => 12,
58			);
59
60			%ZONE = (
61			ADT => [-1, 3, 0], ## 733
62			AST => [-1, 4, 0], ## 733
63			BDT => [-1, 10, 0], ## 733
64			BST => [-1, 11, 0], ## 733
65	wakaba	1.2	#BST => [+1, 1, 0],
66	wakaba	1.1	CDT => [-1, 5, 0], ## 733, 822, 2822
67	wakaba	1.2	CET => [+1, 1, 0],
68	wakaba	1.1	CST => [-1, 6, 0], ## 733, 822, 2822
69			EDT => [-1, 4, 0], ## 733, 822, 2822
70	wakaba	1.2	EET => [+1, 2, 0], ## 1947
71	wakaba	1.1	EST => [-1, 5, 0], ## 733, 822, 2822
72	wakaba	1.2	GDT => [+1, 1, 0], ## 724
73	wakaba	1.1	GMT => [+1, 0, 0], ## 733, 822, 2822
74			HDT => [-1, 9, 0], ## 733
75	wakaba	1.2	HKT => [+1, 8, 0],
76	wakaba	1.1	HST => [-1, 10, 0], ## 733
77	wakaba	1.2	IDT => [+1, 3, 0],
78			IST => [+1, 2, 0], ## Israel standard time
79			#IST => [+1, 5, 30], ## Indian standard time
80			JST => [+1, 9, 0],
81	wakaba	1.1	MDT => [-1, 6, 0], ## 733, 822, 2822
82	wakaba	1.2	MET => [+1, 0, 0],
83			METDST => [+2, 0, 0],
84	wakaba	1.1	MST => [-1, 7, 0], ## 733, 822, 2822
85			NST => [-1, 3, 30], ## 733
86			PDT => [-1, 7, 0], ## 733, 822, 2822
87			PST => [-1, 8, 0], ## 733, 822, 2822
88			YDT => [-1, 8, 0], ## 733
89			YST => [-1, 9, 0], ## 733
90			UT => [+1, 0, 0], ## 822, 2822
91			);
92
93			=head2 $self->_option_zone_letter (-1/0/+1)
94
95			Set convertion rule between one letter zone name
96			(military format) and time.
97
98			C<+1> set it as standard value. (For exmaple, 'A' means
99			'+0100'.) C<-1> reverses their sign, for example, 'A'
100			means '-0100'. BNF comment of RFC 733 and 822 has typo
101			so quite a few implemention takes these values incorrectly.
102			As a result, these zone names carry no worthful information.
103			RFC 2822 recommends these names be taken as '-0000' (i.e.
104			unknown zone). C<-2> means it.
105
106			=cut
107
108			sub _option_zone_letter ($$) {
109			my $self = shift;
110			my $mode = shift;
111			my $i = 0;
112			if ($mode == -2) {
113			for my $letter ('A'..'Z') {$ZONE{$letter} = [-1, 0, 0]} return $self;
114			}
115			for my $letter ('Z', 'A'..'I', 'K'..'M') {
116			$ZONE{$letter} = [+1*$mode, $i++, 0];
117			} $i = 1;
118			for my $letter ('N'..'Y') {
119			$ZONE{$letter} = [-1*$mode, $i++, 0];
120			}
121			$self;
122			}
123
124			=head2 Message::Field::Date->new ()
125
126			Return empty Message::Field::Date object.
127
128			=cut
129
130	wakaba	1.3	sub new ($;%) {
131	wakaba	1.1	my $class = shift;
132	wakaba	1.3	my %option = @_;
133			$option{date_time} \|\|= time; $option{date_time} = 0 if $option{unknown};
134			my $self = bless {option => {@_}, date_time => $option{date_time}}, $class;
135	wakaba	1.1	for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
136			$self->_option_zone_letter ($self->{option}->{zone_letter});
137			$self;
138			}
139
140			=head2 Message::Field::Date->parse ($unfolded_field_body)
141
142			Parse date style C<field-body>.
143
144			=cut
145
146			sub parse ($$;%) {
147			my $class = shift; my $field_body = shift;
148			my $self = bless {option => {@_}}, $class;
149			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
150			$self->_option_zone_letter ($self->{option}->{zone_letter});
151			$field_body = $self->delete_comment ($field_body);
152			if ($field_body =~ /$REG{M_rfc2822_date_time}/) {
153			my ($day, $month, $year, $hour, $minute, $second, $zone)
154			= ($1, uc $2, $3, $4, $5, $6, uc $7);
155			$month = $MONTH{$month} \|\| 1;
156			if ( 0 < $year && $year < 49) {$year += 2000}
157			elsif (50 < $year && $year < 1000) {$year += 1900}
158			my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
159			eval '$self->{date_time} = timegm_nocheck
160			($second, $minute-($zone_sign$zone_minute), $hour-($zone_sign$zone_hour),
161			$day, $month-1, $year);';
162	wakaba	1.2	$self->{secfrac} = '';
163			$self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
164			} elsif ($field_body =~ /$REG{M_iso8601_date_time}/) {
165			my ($year,$month,$day,$hour,$minute,$second,$secfrac,
166			$zone_sign,$zone_hour,$zone_minute)
167			= ($1, $2, $3, $4, $5, $6, $7, "${8}1", $9, $10);
168			eval '$self->{date_time} = timegm_nocheck
169			($second, $minute-($zone_sign$zone_minute), $hour-($zone_sign$zone_hour),
170			$day, $month-1, $year);';
171			$self->{secfrac} = $secfrac;
172	wakaba	1.1	$self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
173			} elsif ($field_body =~ /$REG{M_rfc733_date_time}/) {
174			my ($day, $month, $year, $hour, $minute, $second, $zone)
175			= ($1, uc $2, $3, $4, $5, $6, uc $7);
176			$month = $MONTH{$month} \|\| 1;
177			if ( 0 < $year && $year < 49) {$year += 2000}
178			elsif (50 < $year && $year < 1000) {$year += 1900}
179			my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
180			eval '$self->{date_time} = timegm_nocheck
181			($second, $minute-($zone_sign$zone_minute), $hour-($zone_sign$zone_hour),
182			$day, $month-1, $year);';
183	wakaba	1.2	$self->{secfrac} = '';
184			$self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
185			} elsif ($field_body =~ /$REG{M_asctime}/) {
186			my ($month, $day, $hour, $minute, $second, $year) = (uc $1, $2, $3, $4, $5, $6);
187			$month = $MONTH{$month} \|\| 1;
188			if ( 0 < $year && $year < 49) {$year += 2000}
189			elsif (50 < $year && $year < 1000) {$year += 1900}
190			eval '$self->{date_time} = timegm_nocheck
191			($second, $minute, $hour, $day, $month-1, $year);';
192			$self->{secfrac} = '';
193			$self->{option}->{zone} = [-1, 0, 0];
194			} elsif ($field_body =~ /$REG{M_rfc724_slash_date}/) {
195			my ($month, $day, $year, $hour, $minute, $second, $zone)
196			= ($1, $2, $3, $4, $5, $6, uc $7);
197			if ( 0 < $year && $year < 49) {$year += 2000}
198			elsif (50 < $year && $year < 1000) {$year += 1900}
199			my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
200			eval '$self->{date_time} = timegm_nocheck
201			($second, $minute-($zone_sign$zone_minute), $hour-($zone_sign$zone_hour),
202			$day, $month-1, $year);';
203			$self->{secfrac} = '';
204	wakaba	1.1	$self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
205			} else {
206			$self->{date_time} = 0;
207	wakaba	1.2	$self->{secfrac} = '';
208	wakaba	1.1	}
209			$self;
210			}
211
212	wakaba	1.2	=head2 $self->second_fraction ([$new_fraction])
213
214			Returns or set the decimal fraction of a second.
215			Value is a string containing of only [0-9]
216			or empty string.
217
218			=cut
219
220			sub second_fraction ($;$) {
221			my $self = shift;
222			my $new_fraction = shift;
223			if (defined $new_fraction) {
224			$self->{secfrac} = $new_fraction unless $new_fraction =~ /[^0-9]/;
225			}
226			$self->{secfrac};
227			}
228
229	wakaba	1.1	=head2 $self->stringify ()
230
231			Returns C<field-body> as a string.
232
233			=cut
234
235	wakaba	1.2	sub stringify ($;%) {
236	wakaba	1.1	my $self = shift;
237	wakaba	1.2	my %option = @_;
238			$option{format} \|\|= $self->{option}->{format} \|\| $DEFAULT{format};
239			if ($option{format} eq 'iso8601') {
240			$self->as_iso8601_time (%option);
241			} elsif ($option{format} eq 'http') {
242			$self->as_http_time (%option);
243			} elsif ($option{format} eq 'unix') {
244			$self->as_unix_time (%option);
245			} else { #if ($option{format} eq 'rfc2822') {
246			$self->as_rfc2822_time (%option);
247			}
248	wakaba	1.1	}
249
250	wakaba	1.2	sub as_plain_string ($;%) {
251	wakaba	1.1	my $self = shift;
252			$self->stringify (@_);
253			}
254
255	wakaba	1.2	=head2 $self->as_unix_time ([%options])
256
257			Returns date-time value as the unixtime format
258			(seconds counted from the Epoch, 1970-01-01 00:00:00).
259
260			=cut
261
262			sub as_unix_time ($;%) {
263	wakaba	1.1	my $self = shift;
264			$self->{date_time};
265			}
266
267	wakaba	1.2	=head2 $self->as_rfc2822_time ([%options])
268
269			Returns C<date-time> value as RFC 2822 format.
270			(It is also known as RFC 822 format modified by RFC 1123)
271
272			Option C<output_day_of_week> enables to output
273			C<day-of-week> string. (Default C<+1>)
274
275			If option C<output_zone_string> > 0, use timezone
276			name C<GMT> instead of numeric representation.
277			This option is intended to be used for C<HTTP-date>
278			with option C<zone>. (Default C<-1>)
279
280			Option C<zone> specifies output time zone with
281			RFC 2822 numeric representation such as C<+0000>.
282			Unless this option, time zone of input data
283			(when C<parsed> method is used) or default value
284			C<+0000> is used.
285
286			=cut
287
288	wakaba	1.1	sub as_rfc2822_time ($;%) {
289			my $self = shift;
290			my %option = @_;
291			my $time = $self->{date_time};
292			my @zone = [+1, 0, 0];
293			if (ref $option{zone}) {@zone = @{$option{zone}}}
294			elsif ($option{zone}) {@zone = $self->_zone_string_to_array ($option{zone})}
295			elsif (ref $self->{option}->{zone}) {@zone = @{$self->{option}->{zone}}}
296	wakaba	1.2	elsif ($self->{option}->{zone})
297			{@zone = $self->{option}->_zone_string_to_array ($self->{option}->{zone})}
298			$option{output_day_of_week} \|\|= $self->{option}->{output_day_of_week}
299			\|\| $DEFAULT{output_day_of_week};
300			$option{output_zone_string} \|\|= $self->{option}->{output_zone_string}
301			\|\| $DEFAULT{output_zone_string};
302	wakaba	1.1
303			$time += $zone[0] * ($zone[1] * 60 + $zone[2]) * 60;
304			my ($sec,$min,$hour,$day,$month,$year,$day_of_week) = gmtime ($time);
305			$month = (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$month];
306			$year += 1900 if $year < 1900;
307			$day_of_week = (qw(Sun Mon Tue Wed Thr Fri Sat))[$day_of_week] .', ';
308
309	wakaba	1.2	($option{output_day_of_week}>0? $day_of_week: '').
310			sprintf('%02d %s %s %02d:%02d:%02d %s',
311			$day,$month,$year,$hour,$min,$sec,
312			($option{output_zone_string}>0 && $zone[0]>0 && $zone[1]+$zone[2]==0?
313			'GMT': sprintf('%s%02d%02d',$zone[0]>0?'+':'-',@zone[1,2]))
314			);
315			}
316
317			=head2 $self->as_http_time ([%options])
318
319			Returns C<date-time> value as HTTP preferred format.
320			This method is same as
321			C<$self->as_rfc2822_time (output_zone_string => 1, zone => '+0000')>.
322
323			=cut
324
325			sub as_http_time ($;%) {
326			my $self = shift;
327			my %option = @_;
328			$option{output_zone_string} = 1;
329			$option{zone} = [+1, 0, 0];
330			$self->as_rfc2822_time (%option);
331			}
332
333			=head2 $self->as_iso8601_time ([%options])
334
335			Returns C<date-time> value as ISO 8601 format.
336
337			If option C<output_zone_string> > 0, use timezone
338			name C<Z> instead of numeric representation.
339			This option is intended to be used for C<HTTP-date>
340			with option C<zone>. (Default C<-1>)
341
342			Option C<zone> specifies output time zone with
343			RFC 2822 numeric representation such as C<+0000>.
344			Unless this option, time zone of input data
345			(when C<parsed> method is used) or default value
346			C<+0000> is used.
347
348			=cut
349
350			sub as_iso8601_time ($;%) {
351			my $self = shift;
352			my %option = @_;
353			my $time = $self->{date_time};
354			$option{output_zone_string} \|\|= $self->{option}->{output_zone_string}
355			\|\| $DEFAULT{output_zone_string};
356			my @zone = [+1, 0, 0];
357			if (ref $option{zone}) {@zone = @{$option{zone}}}
358			elsif ($option{zone}) {@zone = $self->_zone_string_to_array ($option{zone})}
359			elsif (ref $self->{option}->{zone}) {@zone = @{$self->{option}->{zone}}}
360			elsif ($self->{option}->{zone}) {@zone = $self->{option}->_zone_string_to_array ($self->{option}->{zone})}
361
362			$time += $zone[0] * ($zone[1] * 60 + $zone[2]) * 60;
363			my ($sec,$min,$hour,$day,$month,$year,$day_of_week) = gmtime ($time);
364			$year += 1900 if $year < 1900;
365
366			sprintf('%04d-%02d-%02dT%02d:%02d:%02d%s%s',
367			$year,$month,$day,$hour,$min,$sec,
368			($self->{secfrac}? '.'.$self->{secfrac}: ''),
369			($option{output_zone_string}>0 && $zone[0]>0 && $zone[1]+$zone[2]==0?
370			'Z': sprintf('%s%02d:%02d',$zone[0]>0?'+':'-',@zone[1,2]))
371			);
372	wakaba	1.1	}
373
374			=head2 $self->delete_comment ($field_body)
375
376			Remove all C<comment> in given strictured C<field-body>.
377			This method is intended for internal use.
378
379			=cut
380
381			sub delete_comment ($$) {
382			my $self = shift;
383			my $body = shift;
384			$body =~ s{($REG{quoted_string})\|$REG{comment}}{
385			my $o = $1; $o? $o : ' ';
386			}gex;
387			$body;
388			}
389
390			sub _zone_string_to_array ($$;$) {
391			my $self = shift;
392			my $zone = shift;
393			my $format = shift;
394			my @azone = [+1, 0, 0];
395			## if $format eq rfc2822
396			if ($zone =~ /([+-])$REG{FWS}([0-9][0-9])([0-9][0-9])/) {
397			@azone = ("${1}1", $2, $3);
398			} else { $zone =~ tr/-//d;
399			if (ref $ZONE{$zone}) {@azone = @{$ZONE{$zone}}}
400			elsif ($zone) {@azone = (-1, 0, 0)}
401			}
402			# }
403			@azone;
404			}
405
406			=head1 EXAMPLE
407
408	wakaba	1.2	use Message::Field::Date;
409	wakaba	1.1
410	wakaba	1.2	my $field_body = '04 Feb 2002 00:12:33 CST';
411			my $field = Message::Field::Date->parse ($field_body);
412	wakaba	1.1
413	wakaba	1.2	print "Un*xtime:\t", $field->as_unix_time, "\n";
414			print "RFC 2822:\t", $field->as_rfc2822_time, "\n";
415			print "HTTP preferred:\t", $field->as_http_time, "\n";
416			print "ISO 8601:\t", $field->as_iso8601_time, "\n";
417	wakaba	1.1
418			=head1 LICENSE
419
420			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
421
422			This program is free software; you can redistribute it and/or modify
423			it under the terms of the GNU General Public License as published by
424			the Free Software Foundation; either version 2 of the License, or
425			(at your option) any later version.
426
427			This program is distributed in the hope that it will be useful,
428			but WITHOUT ANY WARRANTY; without even the implied warranty of
429			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
430			GNU General Public License for more details.
431
432			You should have received a copy of the GNU General Public License
433			along with this program; see the file COPYING. If not, write to
434			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
435			Boston, MA 02111-1307, USA.
436
437			=head1 CHANGE
438
439			See F<ChangeLog>.
440
441			=cut
442
443			1;