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->unix_time ([$new_time])

Returns or set the unix-time (seconds from the Epoch).

=cut

sub unix_time ($;$) {
  my $self = shift;
  my $new_time = shift;
  if (defined $new_time) {
    $self->{date_time} = $new_time unless $new_time =~ /[^0-9]/;
  }
  $self->{date_time};
}

=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 Thu 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->option ($option_name, [$option_value])

Set/gets new value of the option.

=cut

sub option ($$;$) {
  my $self = shift;
  my ($name, $value) = @_;
  if (defined $value) {
    $self->{option}->{$name} = $value;
  }
  $self->{option}->{$name};
}

=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.4	=head2 $self->unix_time ([$new_time])
213
214			Returns or set the unix-time (seconds from the Epoch).
215
216			=cut
217
218			sub unix_time ($;$) {
219			my $self = shift;
220			my $new_time = shift;
221			if (defined $new_time) {
222			$self->{date_time} = $new_time unless $new_time =~ /[^0-9]/;
223			}
224			$self->{date_time};
225			}
226
227	wakaba	1.2	=head2 $self->second_fraction ([$new_fraction])
228
229			Returns or set the decimal fraction of a second.
230			Value is a string containing of only [0-9]
231			or empty string.
232
233			=cut
234
235			sub second_fraction ($;$) {
236			my $self = shift;
237			my $new_fraction = shift;
238			if (defined $new_fraction) {
239			$self->{secfrac} = $new_fraction unless $new_fraction =~ /[^0-9]/;
240			}
241			$self->{secfrac};
242			}
243
244	wakaba	1.1	=head2 $self->stringify ()
245
246			Returns C<field-body> as a string.
247
248			=cut
249
250	wakaba	1.2	sub stringify ($;%) {
251	wakaba	1.1	my $self = shift;
252	wakaba	1.2	my %option = @_;
253			$option{format} \|\|= $self->{option}->{format} \|\| $DEFAULT{format};
254			if ($option{format} eq 'iso8601') {
255			$self->as_iso8601_time (%option);
256			} elsif ($option{format} eq 'http') {
257			$self->as_http_time (%option);
258			} elsif ($option{format} eq 'unix') {
259			$self->as_unix_time (%option);
260			} else { #if ($option{format} eq 'rfc2822') {
261			$self->as_rfc2822_time (%option);
262			}
263	wakaba	1.1	}
264
265	wakaba	1.2	sub as_plain_string ($;%) {
266	wakaba	1.1	my $self = shift;
267			$self->stringify (@_);
268			}
269
270	wakaba	1.2	=head2 $self->as_unix_time ([%options])
271
272			Returns date-time value as the unixtime format
273			(seconds counted from the Epoch, 1970-01-01 00:00:00).
274
275			=cut
276
277			sub as_unix_time ($;%) {
278	wakaba	1.1	my $self = shift;
279			$self->{date_time};
280			}
281
282	wakaba	1.2	=head2 $self->as_rfc2822_time ([%options])
283
284			Returns C<date-time> value as RFC 2822 format.
285			(It is also known as RFC 822 format modified by RFC 1123)
286
287			Option C<output_day_of_week> enables to output
288			C<day-of-week> string. (Default C<+1>)
289
290			If option C<output_zone_string> > 0, use timezone
291			name C<GMT> instead of numeric representation.
292			This option is intended to be used for C<HTTP-date>
293			with option C<zone>. (Default C<-1>)
294
295			Option C<zone> specifies output time zone with
296			RFC 2822 numeric representation such as C<+0000>.
297			Unless this option, time zone of input data
298			(when C<parsed> method is used) or default value
299			C<+0000> is used.
300
301			=cut
302
303	wakaba	1.1	sub as_rfc2822_time ($;%) {
304			my $self = shift;
305			my %option = @_;
306			my $time = $self->{date_time};
307			my @zone = [+1, 0, 0];
308			if (ref $option{zone}) {@zone = @{$option{zone}}}
309			elsif ($option{zone}) {@zone = $self->_zone_string_to_array ($option{zone})}
310			elsif (ref $self->{option}->{zone}) {@zone = @{$self->{option}->{zone}}}
311	wakaba	1.2	elsif ($self->{option}->{zone})
312			{@zone = $self->{option}->_zone_string_to_array ($self->{option}->{zone})}
313			$option{output_day_of_week} \|\|= $self->{option}->{output_day_of_week}
314			\|\| $DEFAULT{output_day_of_week};
315			$option{output_zone_string} \|\|= $self->{option}->{output_zone_string}
316			\|\| $DEFAULT{output_zone_string};
317	wakaba	1.1
318			$time += $zone[0] * ($zone[1] * 60 + $zone[2]) * 60;
319			my ($sec,$min,$hour,$day,$month,$year,$day_of_week) = gmtime ($time);
320			$month = (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$month];
321			$year += 1900 if $year < 1900;
322	wakaba	1.5	$day_of_week = (qw(Sun Mon Tue Wed Thu Fri Sat))[$day_of_week] .', ';
323	wakaba	1.1
324	wakaba	1.2	($option{output_day_of_week}>0? $day_of_week: '').
325			sprintf('%02d %s %s %02d:%02d:%02d %s',
326			$day,$month,$year,$hour,$min,$sec,
327			($option{output_zone_string}>0 && $zone[0]>0 && $zone[1]+$zone[2]==0?
328			'GMT': sprintf('%s%02d%02d',$zone[0]>0?'+':'-',@zone[1,2]))
329			);
330			}
331
332			=head2 $self->as_http_time ([%options])
333
334			Returns C<date-time> value as HTTP preferred format.
335			This method is same as
336			C<$self->as_rfc2822_time (output_zone_string => 1, zone => '+0000')>.
337
338			=cut
339
340			sub as_http_time ($;%) {
341			my $self = shift;
342			my %option = @_;
343			$option{output_zone_string} = 1;
344			$option{zone} = [+1, 0, 0];
345			$self->as_rfc2822_time (%option);
346			}
347
348			=head2 $self->as_iso8601_time ([%options])
349
350			Returns C<date-time> value as ISO 8601 format.
351
352			If option C<output_zone_string> > 0, use timezone
353			name C<Z> instead of numeric representation.
354			This option is intended to be used for C<HTTP-date>
355			with option C<zone>. (Default C<-1>)
356
357			Option C<zone> specifies output time zone with
358			RFC 2822 numeric representation such as C<+0000>.
359			Unless this option, time zone of input data
360			(when C<parsed> method is used) or default value
361			C<+0000> is used.
362
363			=cut
364
365			sub as_iso8601_time ($;%) {
366			my $self = shift;
367			my %option = @_;
368			my $time = $self->{date_time};
369			$option{output_zone_string} \|\|= $self->{option}->{output_zone_string}
370			\|\| $DEFAULT{output_zone_string};
371			my @zone = [+1, 0, 0];
372			if (ref $option{zone}) {@zone = @{$option{zone}}}
373			elsif ($option{zone}) {@zone = $self->_zone_string_to_array ($option{zone})}
374			elsif (ref $self->{option}->{zone}) {@zone = @{$self->{option}->{zone}}}
375			elsif ($self->{option}->{zone}) {@zone = $self->{option}->_zone_string_to_array ($self->{option}->{zone})}
376
377			$time += $zone[0] * ($zone[1] * 60 + $zone[2]) * 60;
378			my ($sec,$min,$hour,$day,$month,$year,$day_of_week) = gmtime ($time);
379			$year += 1900 if $year < 1900;
380
381			sprintf('%04d-%02d-%02dT%02d:%02d:%02d%s%s',
382			$year,$month,$day,$hour,$min,$sec,
383			($self->{secfrac}? '.'.$self->{secfrac}: ''),
384			($option{output_zone_string}>0 && $zone[0]>0 && $zone[1]+$zone[2]==0?
385			'Z': sprintf('%s%02d:%02d',$zone[0]>0?'+':'-',@zone[1,2]))
386			);
387	wakaba	1.5	}
388
389			=head2 $self->option ($option_name, [$option_value])
390
391			Set/gets new value of the option.
392
393			=cut
394
395			sub option ($$;$) {
396			my $self = shift;
397			my ($name, $value) = @_;
398			if (defined $value) {
399			$self->{option}->{$name} = $value;
400			}
401			$self->{option}->{$name};
402	wakaba	1.1	}
403
404			=head2 $self->delete_comment ($field_body)
405
406			Remove all C<comment> in given strictured C<field-body>.
407			This method is intended for internal use.
408
409			=cut
410
411			sub delete_comment ($$) {
412			my $self = shift;
413			my $body = shift;
414			$body =~ s{($REG{quoted_string})\|$REG{comment}}{
415			my $o = $1; $o? $o : ' ';
416			}gex;
417			$body;
418			}
419
420			sub _zone_string_to_array ($$;$) {
421			my $self = shift;
422			my $zone = shift;
423			my $format = shift;
424			my @azone = [+1, 0, 0];
425			## if $format eq rfc2822
426			if ($zone =~ /([+-])$REG{FWS}([0-9][0-9])([0-9][0-9])/) {
427			@azone = ("${1}1", $2, $3);
428			} else { $zone =~ tr/-//d;
429			if (ref $ZONE{$zone}) {@azone = @{$ZONE{$zone}}}
430			elsif ($zone) {@azone = (-1, 0, 0)}
431			}
432			# }
433			@azone;
434			}
435
436			=head1 EXAMPLE
437
438	wakaba	1.2	use Message::Field::Date;
439	wakaba	1.1
440	wakaba	1.2	my $field_body = '04 Feb 2002 00:12:33 CST';
441			my $field = Message::Field::Date->parse ($field_body);
442	wakaba	1.1
443	wakaba	1.2	print "Un*xtime:\t", $field->as_unix_time, "\n";
444			print "RFC 2822:\t", $field->as_rfc2822_time, "\n";
445			print "HTTP preferred:\t", $field->as_http_time, "\n";
446			print "ISO 8601:\t", $field->as_iso8601_time, "\n";
447	wakaba	1.1
448			=head1 LICENSE
449
450			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
451
452			This program is free software; you can redistribute it and/or modify
453			it under the terms of the GNU General Public License as published by
454			the Free Software Foundation; either version 2 of the License, or
455			(at your option) any later version.
456
457			This program is distributed in the hope that it will be useful,
458			but WITHOUT ANY WARRANTY; without even the implied warranty of
459			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
460			GNU General Public License for more details.
461
462			You should have received a copy of the GNU General Public License
463			along with this program; see the file COPYING. If not, write to
464			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
465			Boston, MA 02111-1307, USA.
466
467			=head1 CHANGE
468
469			See F<ChangeLog>.
470
471			=cut
472
473			1;