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 $self = bless {option => {@_}, date_time => shift||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			sub new ($;$) {
131			my $class = shift;
132			my $self = bless {option => {@_}, date_time => shift\|\|time}, $class;
133			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
134			$self->_option_zone_letter ($self->{option}->{zone_letter});
135			$self;
136			}
137
138			=head2 Message::Field::Date->parse ($unfolded_field_body)
139
140			Parse date style C<field-body>.
141
142			=cut
143
144			sub parse ($$;%) {
145			my $class = shift; my $field_body = shift;
146			my $self = bless {option => {@_}}, $class;
147			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
148			$self->_option_zone_letter ($self->{option}->{zone_letter});
149			$field_body = $self->delete_comment ($field_body);
150			if ($field_body =~ /$REG{M_rfc2822_date_time}/) {
151			my ($day, $month, $year, $hour, $minute, $second, $zone)
152			= ($1, uc $2, $3, $4, $5, $6, uc $7);
153			$month = $MONTH{$month} \|\| 1;
154			if ( 0 < $year && $year < 49) {$year += 2000}
155			elsif (50 < $year && $year < 1000) {$year += 1900}
156			my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
157			eval '$self->{date_time} = timegm_nocheck
158			($second, $minute-($zone_sign$zone_minute), $hour-($zone_sign$zone_hour),
159			$day, $month-1, $year);';
160	wakaba	1.2	$self->{secfrac} = '';
161			$self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
162			} elsif ($field_body =~ /$REG{M_iso8601_date_time}/) {
163			my ($year,$month,$day,$hour,$minute,$second,$secfrac,
164			$zone_sign,$zone_hour,$zone_minute)
165			= ($1, $2, $3, $4, $5, $6, $7, "${8}1", $9, $10);
166			eval '$self->{date_time} = timegm_nocheck
167			($second, $minute-($zone_sign$zone_minute), $hour-($zone_sign$zone_hour),
168			$day, $month-1, $year);';
169			$self->{secfrac} = $secfrac;
170	wakaba	1.1	$self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
171			} elsif ($field_body =~ /$REG{M_rfc733_date_time}/) {
172			my ($day, $month, $year, $hour, $minute, $second, $zone)
173			= ($1, uc $2, $3, $4, $5, $6, uc $7);
174			$month = $MONTH{$month} \|\| 1;
175			if ( 0 < $year && $year < 49) {$year += 2000}
176			elsif (50 < $year && $year < 1000) {$year += 1900}
177			my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
178			eval '$self->{date_time} = timegm_nocheck
179			($second, $minute-($zone_sign$zone_minute), $hour-($zone_sign$zone_hour),
180			$day, $month-1, $year);';
181	wakaba	1.2	$self->{secfrac} = '';
182			$self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
183			} elsif ($field_body =~ /$REG{M_asctime}/) {
184			my ($month, $day, $hour, $minute, $second, $year) = (uc $1, $2, $3, $4, $5, $6);
185			$month = $MONTH{$month} \|\| 1;
186			if ( 0 < $year && $year < 49) {$year += 2000}
187			elsif (50 < $year && $year < 1000) {$year += 1900}
188			eval '$self->{date_time} = timegm_nocheck
189			($second, $minute, $hour, $day, $month-1, $year);';
190			$self->{secfrac} = '';
191			$self->{option}->{zone} = [-1, 0, 0];
192			} elsif ($field_body =~ /$REG{M_rfc724_slash_date}/) {
193			my ($month, $day, $year, $hour, $minute, $second, $zone)
194			= ($1, $2, $3, $4, $5, $6, uc $7);
195			if ( 0 < $year && $year < 49) {$year += 2000}
196			elsif (50 < $year && $year < 1000) {$year += 1900}
197			my ($zone_sign, $zone_hour, $zone_minute) = $self->_zone_string_to_array ($zone);
198			eval '$self->{date_time} = timegm_nocheck
199			($second, $minute-($zone_sign$zone_minute), $hour-($zone_sign$zone_hour),
200			$day, $month-1, $year);';
201			$self->{secfrac} = '';
202	wakaba	1.1	$self->{option}->{zone} = [$zone_sign, $zone_hour, $zone_minute];
203			} else {
204			$self->{date_time} = 0;
205	wakaba	1.2	$self->{secfrac} = '';
206	wakaba	1.1	}
207			$self;
208			}
209
210	wakaba	1.2	=head2 $self->second_fraction ([$new_fraction])
211
212			Returns or set the decimal fraction of a second.
213			Value is a string containing of only [0-9]
214			or empty string.
215
216			=cut
217
218			sub second_fraction ($;$) {
219			my $self = shift;
220			my $new_fraction = shift;
221			if (defined $new_fraction) {
222			$self->{secfrac} = $new_fraction unless $new_fraction =~ /[^0-9]/;
223			}
224			$self->{secfrac};
225			}
226
227	wakaba	1.1	=head2 $self->stringify ()
228
229			Returns C<field-body> as a string.
230
231			=cut
232
233	wakaba	1.2	sub stringify ($;%) {
234	wakaba	1.1	my $self = shift;
235	wakaba	1.2	my %option = @_;
236			$option{format} \|\|= $self->{option}->{format} \|\| $DEFAULT{format};
237			if ($option{format} eq 'iso8601') {
238			$self->as_iso8601_time (%option);
239			} elsif ($option{format} eq 'http') {
240			$self->as_http_time (%option);
241			} elsif ($option{format} eq 'unix') {
242			$self->as_unix_time (%option);
243			} else { #if ($option{format} eq 'rfc2822') {
244			$self->as_rfc2822_time (%option);
245			}
246	wakaba	1.1	}
247
248	wakaba	1.2	sub as_plain_string ($;%) {
249	wakaba	1.1	my $self = shift;
250			$self->stringify (@_);
251			}
252
253	wakaba	1.2	=head2 $self->as_unix_time ([%options])
254
255			Returns date-time value as the unixtime format
256			(seconds counted from the Epoch, 1970-01-01 00:00:00).
257
258			=cut
259
260			sub as_unix_time ($;%) {
261	wakaba	1.1	my $self = shift;
262			$self->{date_time};
263			}
264
265	wakaba	1.2	=head2 $self->as_rfc2822_time ([%options])
266
267			Returns C<date-time> value as RFC 2822 format.
268			(It is also known as RFC 822 format modified by RFC 1123)
269
270			Option C<output_day_of_week> enables to output
271			C<day-of-week> string. (Default C<+1>)
272
273			If option C<output_zone_string> > 0, use timezone
274			name C<GMT> instead of numeric representation.
275			This option is intended to be used for C<HTTP-date>
276			with option C<zone>. (Default C<-1>)
277
278			Option C<zone> specifies output time zone with
279			RFC 2822 numeric representation such as C<+0000>.
280			Unless this option, time zone of input data
281			(when C<parsed> method is used) or default value
282			C<+0000> is used.
283
284			=cut
285
286	wakaba	1.1	sub as_rfc2822_time ($;%) {
287			my $self = shift;
288			my %option = @_;
289			my $time = $self->{date_time};
290			my @zone = [+1, 0, 0];
291			if (ref $option{zone}) {@zone = @{$option{zone}}}
292			elsif ($option{zone}) {@zone = $self->_zone_string_to_array ($option{zone})}
293			elsif (ref $self->{option}->{zone}) {@zone = @{$self->{option}->{zone}}}
294	wakaba	1.2	elsif ($self->{option}->{zone})
295			{@zone = $self->{option}->_zone_string_to_array ($self->{option}->{zone})}
296			$option{output_day_of_week} \|\|= $self->{option}->{output_day_of_week}
297			\|\| $DEFAULT{output_day_of_week};
298			$option{output_zone_string} \|\|= $self->{option}->{output_zone_string}
299			\|\| $DEFAULT{output_zone_string};
300	wakaba	1.1
301			$time += $zone[0] * ($zone[1] * 60 + $zone[2]) * 60;
302			my ($sec,$min,$hour,$day,$month,$year,$day_of_week) = gmtime ($time);
303			$month = (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$month];
304			$year += 1900 if $year < 1900;
305			$day_of_week = (qw(Sun Mon Tue Wed Thr Fri Sat))[$day_of_week] .', ';
306
307	wakaba	1.2	($option{output_day_of_week}>0? $day_of_week: '').
308			sprintf('%02d %s %s %02d:%02d:%02d %s',
309			$day,$month,$year,$hour,$min,$sec,
310			($option{output_zone_string}>0 && $zone[0]>0 && $zone[1]+$zone[2]==0?
311			'GMT': sprintf('%s%02d%02d',$zone[0]>0?'+':'-',@zone[1,2]))
312			);
313			}
314
315			=head2 $self->as_http_time ([%options])
316
317			Returns C<date-time> value as HTTP preferred format.
318			This method is same as
319			C<$self->as_rfc2822_time (output_zone_string => 1, zone => '+0000')>.
320
321			=cut
322
323			sub as_http_time ($;%) {
324			my $self = shift;
325			my %option = @_;
326			$option{output_zone_string} = 1;
327			$option{zone} = [+1, 0, 0];
328			$self->as_rfc2822_time (%option);
329			}
330
331			=head2 $self->as_iso8601_time ([%options])
332
333			Returns C<date-time> value as ISO 8601 format.
334
335			If option C<output_zone_string> > 0, use timezone
336			name C<Z> instead of numeric representation.
337			This option is intended to be used for C<HTTP-date>
338			with option C<zone>. (Default C<-1>)
339
340			Option C<zone> specifies output time zone with
341			RFC 2822 numeric representation such as C<+0000>.
342			Unless this option, time zone of input data
343			(when C<parsed> method is used) or default value
344			C<+0000> is used.
345
346			=cut
347
348			sub as_iso8601_time ($;%) {
349			my $self = shift;
350			my %option = @_;
351			my $time = $self->{date_time};
352			$option{output_zone_string} \|\|= $self->{option}->{output_zone_string}
353			\|\| $DEFAULT{output_zone_string};
354			my @zone = [+1, 0, 0];
355			if (ref $option{zone}) {@zone = @{$option{zone}}}
356			elsif ($option{zone}) {@zone = $self->_zone_string_to_array ($option{zone})}
357			elsif (ref $self->{option}->{zone}) {@zone = @{$self->{option}->{zone}}}
358			elsif ($self->{option}->{zone}) {@zone = $self->{option}->_zone_string_to_array ($self->{option}->{zone})}
359
360			$time += $zone[0] * ($zone[1] * 60 + $zone[2]) * 60;
361			my ($sec,$min,$hour,$day,$month,$year,$day_of_week) = gmtime ($time);
362			$year += 1900 if $year < 1900;
363
364			sprintf('%04d-%02d-%02dT%02d:%02d:%02d%s%s',
365			$year,$month,$day,$hour,$min,$sec,
366			($self->{secfrac}? '.'.$self->{secfrac}: ''),
367			($option{output_zone_string}>0 && $zone[0]>0 && $zone[1]+$zone[2]==0?
368			'Z': sprintf('%s%02d:%02d',$zone[0]>0?'+':'-',@zone[1,2]))
369			);
370	wakaba	1.1	}
371
372			=head2 $self->delete_comment ($field_body)
373
374			Remove all C<comment> in given strictured C<field-body>.
375			This method is intended for internal use.
376
377			=cut
378
379			sub delete_comment ($$) {
380			my $self = shift;
381			my $body = shift;
382			$body =~ s{($REG{quoted_string})\|$REG{comment}}{
383			my $o = $1; $o? $o : ' ';
384			}gex;
385			$body;
386			}
387
388			sub _zone_string_to_array ($$;$) {
389			my $self = shift;
390			my $zone = shift;
391			my $format = shift;
392			my @azone = [+1, 0, 0];
393			## if $format eq rfc2822
394			if ($zone =~ /([+-])$REG{FWS}([0-9][0-9])([0-9][0-9])/) {
395			@azone = ("${1}1", $2, $3);
396			} else { $zone =~ tr/-//d;
397			if (ref $ZONE{$zone}) {@azone = @{$ZONE{$zone}}}
398			elsif ($zone) {@azone = (-1, 0, 0)}
399			}
400			# }
401			@azone;
402			}
403
404			=head1 EXAMPLE
405
406	wakaba	1.2	use Message::Field::Date;
407	wakaba	1.1
408	wakaba	1.2	my $field_body = '04 Feb 2002 00:12:33 CST';
409			my $field = Message::Field::Date->parse ($field_body);
410	wakaba	1.1
411	wakaba	1.2	print "Un*xtime:\t", $field->as_unix_time, "\n";
412			print "RFC 2822:\t", $field->as_rfc2822_time, "\n";
413			print "HTTP preferred:\t", $field->as_http_time, "\n";
414			print "ISO 8601:\t", $field->as_iso8601_time, "\n";
415	wakaba	1.1
416			=head1 LICENSE
417
418			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
419
420			This program is free software; you can redistribute it and/or modify
421			it under the terms of the GNU General Public License as published by
422			the Free Software Foundation; either version 2 of the License, or
423			(at your option) any later version.
424
425			This program is distributed in the hope that it will be useful,
426			but WITHOUT ANY WARRANTY; without even the implied warranty of
427			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
428			GNU General Public License for more details.
429
430			You should have received a copy of the GNU General Public License
431			along with this program; see the file COPYING. If not, write to
432			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
433			Boston, MA 02111-1307, USA.
434
435			=head1 CHANGE
436
437			See F<ChangeLog>.
438
439			=cut
440
441			1;