File Coverage

blib/lib/DateTime/Format/Mail.pm

Criterion	Covered	Total	%
statement	113	113	100.0
branch	39	54	72.2
condition	13	17	76.4
subroutine	21	21	100.0
pod	10	10	100.0
total	196	215	91.1

package DateTime::Format::Mail;
# $Id$
$DateTime::Format::Mail::VERSION = '0.403';
use strict;
use 5.005;
use Carp;
use DateTime 1.04;
use Params::Validate qw( validate validate_pos SCALAR );
use vars qw( $VERSION );

my %validations = (
    year_cutoff =>  {
        type => SCALAR,
        callbacks => {
            'greater than or equal to zero, less than 100' => sub {
                defined $_[0]
                    and $_[0] =~ /^ \d+ $/x
                    and $_[0] >= 0
                    and $_[0] < 100
            },
        },
    }
);

# Timezones for strict parser.
my %timezones = qw(
    EDT -0400   EST -0500       CDT -0500       CST -0600
    MDT -0600   MST -0700       PDT -0700       PST -0800
    GMT +0000   UT  +0000
);
my $tz_RE = join( '|', sort keys %timezones );
$tz_RE= qr/(?:$tz_RE)/;
$timezones{UTC} = $timezones{UT};

# Strict parser regex

# Lovely regex. Mostly a translation of the BNF in 2822.
# XXX - need more thorough tests to ensure it's *strict*.

my $strict_RE = qr{
    ^ \s* # optional
    # [day-of-week "," ]
    (?:
      (?:Mon|Tue|Wed|Thu|Fri|Sat|Sun) ,
      \s+
    )?
    # date => day month year
    (\d{1,2})  # day => 1*2DIGIT
    \s+
    (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) # month-name
    \s*
    ((?:\d\d)?\d\d) # year
    # FWS
    \s+
    # time
    (\d\d):(\d\d):(\d\d) # time
    (?:
        \s+ (
            [+-] \d{4}  # standard form
            | $tz_RE    # obsolete form (mostly ignored)
            | [A-IK-Za-ik-z]  # including military (no 'J')
            ) # time zone (optional)
    )?
    \s* $
}ox;

# Loose parser regex
my $loose_RE = qr{
    ^ \s* # optional
    (?i:
        (?:Mon|Tue|Wed|Thu|Fri|Sat|Sun|[A-Z][a-z][a-z]) ,? # Day name + comma
    )?
        # (empirically optional)
    \s*
    (\d{1,2})  # day of month
    [-\s]*
    (?i: (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) ) # month
    [-\s]*
    ((?:\d\d)?\d\d) # year
    \s+
    (\d?\d):(\d?\d) (?: :(\d?\d) )? # time
    (?:
        \s+ "? (
            [+-] \d{4}  # standard form
            | [A-Z]+    # obsolete form (mostly ignored)
            | GMT [+-] \d+      # empirical (converted)
            | [A-Z]+\d+ # bizarre empirical (ignored)
            | [a-zA-Z/]+        # linux style (ignored)
            | [+-]{0,2} \d{3,5} # corrupted standard form
            ) "? # time zone (optional)
    )?
        (?: \s+ \([^\)]+\) )? # (friendly tz name; empirical)
    \s* \.? $
}x;

sub _set_parse_method
{
    my $self = shift;
    croak "Calling object method as class method!" unless ref $self;
    $self->{parser_method} = shift;
    return $self;
}

sub _get_parse_method
{
    my $self = shift;
    my $method = ref($self) ? $self->{parser_method} : '';
    $method ||= '_parse_strict';
}

sub new
{
    my $class = shift;
    my %args = validate( @_, {
            loose => {
                type => SCALAR,
                default => 0,
            },
            year_cutoff => {
                %{ $validations{year_cutoff} },
                default => $class->default_cutoff,
            },
        }
    );

    my $self = bless {}, ref($class)||$class;
    if (ref $class)
    {
        # If called on an object, clone
        $self->_set_parse_method( $class->_get_parse_method );
        $self->set_year_cutoff( $class->year_cutoff );
        # and that's it. we don't store much info per object
    }
    else
    {
        my $parser = $args{loose} ? "loose" : "strict";
        $self->$parser();
        $self->set_year_cutoff( $args{year_cutoff} ) if $args{year_cutoff};
    }

    $self;
}

sub clone
{
    my $self = shift;
    croak "Calling object method as class method!" unless ref $self;
    return $self->new();
}

sub loose
{
    my $self = shift;
    croak "loose() takes no arguments!" if @_;
    return $self->_set_parse_method( '_parse_loose' );
}

sub strict
{
    my $self = shift;
    croak "strict() takes no arguments!" if @_;
    return $self->_set_parse_method( '_parse_strict' );
}

sub _parse_strict
{
    my $self = shift;
    my $date = shift;

    # Wed, 12 Mar 2003 13:05:00 +1100
    my @parsed = $date =~ $strict_RE;
    croak "Invalid format for date!" unless @parsed;
    my %when;
    @when{qw( day month year hour minute second time_zone)} = @parsed;
    return \%when;
}

sub _parse_loose
{
    my $self = shift;
    my $date = shift;

    # Wed, 12 Mar 2003 13:05:00 +1100
    my @parsed = $date =~ $loose_RE;
    croak "Invalid format for date!" unless @parsed;
    my %when;
    @when{qw( day month year hour minute second time_zone)} = @parsed;
    $when{month} = "\L\u$when{month}";
    $when{second} ||= 0;
    return \%when;
}

sub parse_datetime
{
    my $self = shift;
    croak "No date specified for parse_datetime." unless @_;
    croak "Too many arguments to parse_datetime." if @_ != 1;
    my $date = shift;

    # Wed, 12 Mar 2003 13:05:00 +1100
    my $method = $self->_get_parse_method();
    my %when = %{ $self->$method($date) };
    $when{time_zone} ||= '-0000';

    my %months = do { my $i = 1;
        map { $_, $i++ } qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
    };
    $when{month} = $months{$when{month}}
        or croak "Invalid month `$when{month}'.";

    $when{year} = $self->fix_year( $when{year} );
    $when{time_zone} = _determine_timezone( $when{time_zone} );
    $when{time_zone} = 'floating' if $when{time_zone} eq '-0000';

    my $date_time = DateTime->new( %when );

    return $date_time;
}

sub _determine_timezone
{
    my $tz = shift;
    return '-0000' unless defined $tz; # return quickly if nothing needed
    return $tz if $tz =~ /^[+-]\d{4}$/;

    $tz =~ s/ ^ [+-] (?=[+-]) //x; # for when there are two signs

    if (exists $timezones{$tz}) {
        $tz = $timezones{$tz};
    } elsif (substr($tz, 0, 3) eq 'GMT' and length($tz)  > 4) {
        $tz = sprintf "%5.5s", substr($tz,3)."0000";
    } elsif ( $tz =~ /^ ([+-]?) (\d+) $/x) {
        my $p = $1||'+';
        $tz = sprintf "%s%04d", $p, $2;
    } else {
        $tz = "-0000";
    }

    return $tz;
}

sub set_year_cutoff
{
    my $self = shift;
    croak "Calling object method as class method!" unless ref $self;
    validate_pos( @_, $validations{year_cutoff} );
    croak "Wrong number of arguments (should be 1) to set_year_cutoff"
        unless @_ == 1;
    my $cutoff = shift;
    $self->{year_cutoff} = $cutoff;
    return $self;
}

# rfc2822, 4.3. Obsolete Date and Time
#   Where a two or three digit year occurs in a date, the year is to be
#   interpreted as follows: If a two digit year is encountered whose
#   value is between 00 and 49, the year is interpreted by adding 2000,
#   ending up with a value between 2000 and 2049.  If a two digit year is
#   encountered with a value between 50 and 99, or any three digit year
#   is encountered, the year is interpreted by adding 1900.
sub default_cutoff
{
    49;
}

sub year_cutoff
{
    my $self = shift;
    croak "Too many arguments (should be 0) to year_cutoff" if @_;
    (ref $self and $self->{year_cutoff}) or $self->default_cutoff;
}

sub fix_year
{
    my $self = shift;
    my $year = shift;
    return $year if length $year >= 4; # Return quickly if we can

    my $cutoff = $self->year_cutoff;
    $year += $year > $cutoff ? 1900 : 2000;
    return $year;
}

sub format_datetime
{
    my $self = shift;
    croak "No DateTime object specified." unless @_;
    my $dt = $_[0]->clone;
    $dt->set_locale('en_US');

    my $rv = $dt->strftime( "%a, %e %b %Y %H:%M:%S %z" );
    $rv =~ s/\+0000$/-0000/ if $dt->time_zone->is_floating;
    $rv;
}

1;

__END__