File Coverage

lib/DateTimeX/Web.pm

Criterion	Covered	Total	%
statement	170	175	97.1
branch	52	72	72.2
condition	14	21	66.6
subroutine	38	38	100.0
pod	18	18	100.0
total	292	324	90.1

package DateTimeX::Web;

use strict;
use warnings;
use Carp;

our $VERSION = '0.07';

use DateTime;
use DateTime::Locale;
use DateTime::TimeZone;
use DateTime::Format::Strptime;
use DateTime::Format::Mail;
use DateTime::Format::W3CDTF;
use DateTime::Format::MySQL;
use DateTime::Format::HTTP;
use Scalar::Util qw( blessed );

sub _parse_options {
  my $self = shift;

  if ( @_ == 1 ) {
    return %{$_[0]} if ref $_[0] eq 'HASH';
    return @{$_[0]} if ref $_[0] eq 'ARRAY';
  }
  croak "Odd number of elements in hash assignment" if @_ % 2;
  return @_;
}

sub new {
  my $class = shift;

  my %config = $class->_parse_options(@_);

  $config{on_error} ||= 'croak';

  my $self = bless {
    config => \%config,
    format => {
      mail  => DateTime::Format::Mail->new( loose => 1 ),
      wwwc  => DateTime::Format::W3CDTF->new,
      mysql => DateTime::Format::MySQL->new,
      http  => 'DateTime::Format::HTTP',  # ::HTTP has no 'new'
    },
    parser => {},
  }, $class;

  $self->time_zone( $config{time_zone} || delete $config{timezone} || 'UTC' );
  $self->locale( $config{locale} || 'en-US' );

  $self;
}

sub format {
  my ($self, $name, $package) = @_;

  if ( $package ) {
    if ( ref $package ) {
      $self->{format}->{lc $name} = $package;
    }
    else {
      unless ( $package =~ s/^\+// ) {
        $package =~ s/^DateTime::Format:://;
        $package = "DateTime::Format\::$package";
      }
      eval "require $package;";
      croak $@ if $@;
      $self->{format}->{lc $name} =
        ( $package->can('new') ) ? $package->new : $package;
    }
  }
  $self->{format}->{lc $name};
}

sub time_zone {
  my ($self, $zone) = @_;

  if ( $zone ) {
    $self->{config}->{time_zone} =
      ( blessed $zone && $zone->isa('DateTime::TimeZone') )
        ? $zone
        : DateTime::TimeZone->new( name => $zone );
  }
  $self->{config}->{time_zone};
}

sub locale {
  my ($self, $locale) = @_;

  if ( $locale ) {
    $self->{config}->{locale} =
      ( blessed $locale && ($locale->isa('DateTime::Locale::root') || $locale->isa('DateTime::Locale::FromData') ) )
        ? $locale
        : DateTime::Locale->load( $locale );
  }
  $self->{config}->{locale};
}

{
    my @constructors = qw(now today last_day_of_month from_day_of_year);
    for my $method (@constructors) {
        my $code = sub {
            my $self = shift;

            my %options = $self->_parse_options(@_);

            $self->_merge_config( \%options );

            my $dt = eval { DateTime->$method( %options ) };
            $self->_error( $@ ) if $@;
            return $dt;
        };

        no strict 'refs';
        *{$method} = $code;
    }
}

sub from {
  my $self = shift;

  my %options = $self->_parse_options(@_);

  return $self->from_epoch( %options ) if $options{epoch};
  return $self->from_object( %options ) if $options{object};

  $self->_merge_config( \%options );

  my $dt = eval { DateTime->new( %options ) };
  $self->_error( $@ ) if $@;
  return $dt;
}

sub from_epoch {
  my $self  = shift;
  my $epoch = shift;
     $epoch = shift if $epoch eq 'epoch';
  my %options = $self->_parse_options(@_);

  $self->_merge_config( \%options );

  my $dt = eval { DateTime->from_epoch( epoch => $epoch, %options ) };
  $self->_error( $@ ) if $@;

  return $dt;
}

sub from_object {
  my $self  = shift;
  my $object = shift;
     $object = shift if $object eq 'object';
  my %options = $self->_parse_options(@_);

  $self->_merge_config( \%options );

  my $orig_time_zone;
  if (my $time_zone = delete $options{time_zone}) {
      if ($object->can('set_time_zone')) {
          $orig_time_zone = $object->time_zone;
          $object->set_time_zone($time_zone);
      }
  }

  my $dt = eval { DateTime->from_object( object => $object, %options ) };
  $self->_error( $@ ) if $@;

  if ($orig_time_zone) {
      $object->set_time_zone($orig_time_zone);
  }

  return $dt;
}

sub from_rss   { shift->parse_as( wwwc  => @_ ); }
sub from_mail  { shift->parse_as( mail  => @_ ); }
sub from_mysql { shift->parse_as( mysql => @_ ); }
sub from_http  { shift->parse_as( http  => @_ ); }

*from_wwwc  = \&from_rss;
*from_rss20 = \&from_mail;

sub parse_as {
  my ($self, $formatter, $string, @args) = @_;

  my %options = $self->_parse_options(@args);

  $self->_load( $formatter );

  my $dt = eval { $self->format($formatter)->parse_datetime( $string ) };
  if ( $@ ) {
    $self->_error( $@ );
  }
  else {
    $self->_merge_config( \%options );
    $self->_set_config( $dt, \%options );
    return $dt;
  }
}

sub parse {
  my ($self, $pattern, $string, @args) = @_;

  my %options = $self->_parse_options(@args);

  unless ( $self->{parser}->{$pattern} ) {
    $self->_merge_config( \%options );
    $options{pattern} = $pattern;
    my $parser = DateTime::Format::Strptime->new( %options );
    $self->{parser}->{$pattern} = $parser;
  }
  my $dt = eval { $self->{parser}->{$pattern}->parse_datetime( $string ) };
  if ( $@ ) {
    $self->_error( $@ );
  }
  else {
    $self->_set_config( $dt, \%options );
    return $dt;
  }
}

*strptime = \&parse;

sub for_rss   { shift->render_as( wwwc  => @_ ); }
sub for_mail  { shift->render_as( mail  => @_ ); }
sub for_mysql { shift->render_as( mysql => @_ ); }
sub for_http  { shift->render_as( http  => @_ ); }

*for_wwwc  = \&for_rss;
*for_rss20 = \&for_mail;

sub render_as {
  my ($self, $formatter, @args) = @_;

  $self->_load( $formatter );

  my $dt = $self->_datetime( @args );

  my $str = eval { $self->format($formatter)->format_datetime( $dt ) };
  $self->_error( $@ ) if $@;
  return $str;
}

sub _merge_config {
  my ($self, $options) = @_;

  foreach my $key (qw( time_zone locale )) {
    next unless defined $self->{config}->{$key};
    next if defined $options->{$key};
    $options->{$key} = $self->{config}->{$key};
  }
}

sub _datetime {
  my $self = shift;

  return $self->now unless @_;
  return $_[0] if @_ == 1 && blessed $_[0] && $_[0]->isa('DateTime');
  return $self->from( @_ );
}

sub _load {
  my ($self, $formatter) = @_;

  unless ( $self->format($formatter) ) {
    $self->format( $formatter => "DateTime::Format\::$formatter" );
  }
}

sub _set_config {
  my ($self, $dt, $options) = @_;

  $options ||= $self->{config};

  foreach my $key (qw( time_zone locale )) {
    my $func = "set_$key";
    $dt->$func( $options->{$key} ) if $options->{$key};
  }
}

sub _error {
  my ($self, $message) = @_;

  my $on_error = $self->{config}->{on_error};

  return if $on_error eq 'ignore';
  return $on_error->( $message ) if ref $on_error eq 'CODE';

  local $Carp::CarpLevel = 1;
  croak $message;
}

1;

__END__