File Coverage

blib/lib/Rose/DateTime/Util.pm

Criterion	Covered	Total	%
statement	133	153	86.9
branch	90	120	75.0
condition	11	19	57.8
subroutine	15	15	100.0
pod	7	8	87.5
total	256	315	81.2

package Rose::DateTime::Util;

use strict;

use Carp();

use DateTime;
use DateTime::Infinite;

require Exporter;
our @ISA = qw(Exporter);

our @EXPORT_OK = qw(format_date parse_date parse_european_date parse_epoch);

our %EXPORT_TAGS =
(
  std => [ qw(format_date parse_date parse_european_date) ],
  all => \@EXPORT_OK
);

our $VERSION = '0.540';

our $TZ = 'floating';
our $Debug = 0;
our $European_Dates = __PACKAGE__->init_european_dates;
our $Error;

sub error { $Error }

sub time_zone
{
  my($class) = shift;
  return $TZ = shift  if(@_);
  return $TZ;
}

sub european_dates
{
  my($class) = shift;

  if(@_)
  {
    if(defined $_[0])
    {
      return $European_Dates = $_[0] ? 1 : 0;
    }

    return $European_Dates = $class->init_european_dates;
  }

  return $European_Dates;
}

sub init_european_dates
{
  #my($class) = shift;

  my $locale_class = DateTime->DefaultLocale;

  unless(ref $locale_class)
  {
    $locale_class = DateTime::Locale->load($locale_class);
  }

  # Fall back to the older (pre-0.4) DateTime::Locale API
  my $short =
    $locale_class->can('date_format_short') ?
      $locale_class->date_format_short :
      $locale_class->short_date_format;

  $short =~ tr{dmyDMY}{}cd;
  $short =~ tr{dmyDMY}{dmydmy}s;

  # date_parts_order() is deprecated in DateTime::Locale 0.44+
  #if($locale_class->date_parts_order eq 'dmy')
  if($short eq 'dmy')
  {
    return 1;
  }

  return 0;
}

sub parse_european_date
{
  local $European_Dates = 1;
  &parse_date; # implicitly pass the current args: @_
}

sub parse_date
{
  my($arg, $time_zone) = @_;

  $time_zone ||= $TZ;

  my($fsecs, $secs, $mins, $hours, $mday, $month, $year, $wday, $yday, $isdst,
     $month_abbrev, $date, $ampm, $hours2, $ampm2);

  $Error = undef;

  no warnings 'uninitialized';

  if(ref $arg && $arg->isa('DateTime'))
  {
    if(@_ > 1)
    {
      my $error;

      TRY:
      {
        local $@;
        eval { $arg->set_time_zone($time_zone) };
        $error = $@;
      }

      if($error)
      {
        $Error = $error;
        return undef;
      }
    }

    return $arg;
  }
  elsif(($year, $month, $mday, $hours, $mins, $secs, $fsecs, $ampm, $hours2, $ampm2) = ($arg =~
  m{
    ^
    (\d{4}) \s* [-._]? \s* # year
    (\d{2}) \s* [-._]? \s* # month
    (\d{2})            # day
    (?:
      \s* [-._T]? \s*
      (?:
        (\d\d?) :        # hour
        (\d\d)           # min
        (?: (?: : (\d\d) )? (?: \. (\d{0,9}) )? )? # sec? nanosec?
        (?: \s* ([aApP]\.?[mM]\.?) )? # am/pm?
        |
        (\d\d?) # hour
        (?: \s* ([aApP]\.?[mM]\.?) ) # am/pm
      )
    )?
    $
  }x))
  {
    # yyyy mm dd [hh:mm[:ss[.nnnnnnnnn]]] [am/pm] also valid w/o spaces or w/ hyphens

    $hours = $hours2  if(defined $hours2);
    $ampm  = $ampm2   if(defined $ampm2);

    $date = _timelocal($secs, $mins, $hours, $mday, $month, $year, $ampm, $fsecs, $time_zone);
  }
  elsif(($month, $mday, $year, $hours, $mins, $secs, $fsecs, $ampm) = ($arg =~
  m{
    ^
    (\d{1,2}) [-/._] (\d{1,2}) [-/._] (\d{4}) # xx-xx-yyyy
    (?:
      (?: \s+ | [-._T] )
      (\d\d?) # hour
      (?::(\d\d)(?::(\d\d))?)?(?:\.(\d{0,9}))? # min? sec? nanosec?
      (?:\s*([aApP]\.?[mM]\.?))? # am/pm
    )?
    $
  }x))
  {
    # Normal:   mm/dd/yyyy, mm-dd-yyyy, mm.dd.yyyy [hh:mm[:ss][.nnnnnnnnn]] [am/pm]
    # European: dd/mm/yyyy, dd-mm-yyyy, dd.mm.yyyy [hh:mm[:ss][.nnnnnnnnn]] [am/pm]

    if($European_Dates)
    {
      ($mday, $month) = ($month, $mday); # swap month and day in Euro-mode
    }

    $date = _timelocal($secs, $mins, $hours, $mday, $month, $year, $ampm, $fsecs, $time_zone);
  }
  elsif(lc $arg eq 'now' || lc $arg eq 'now!')
  {
    # Right now
    return DateTime->now(time_zone => $time_zone);
  }
  elsif($arg =~ /^(?: (-?\d+)(?:\.(\d{0,9}))? | (-?\d*)\.(\d{1,9}) )$/x)
  {
    my $epoch = defined $1 ? $1 : $3;
    my $fsecs = defined $2 ? $2 : $4;

    $epoch = 0  if($epoch eq '-');

    # In Unix time format (guessing)
    $date = DateTime->from_epoch(epoch => $epoch || 0, time_zone => $time_zone);

    if($fsecs)
    {
      my $len = length $fsecs;

      if($len < 9)
      {
        $fsecs .= ('0' x (9 - length $fsecs));
      }
      elsif($len > 9)
      {
        $fsecs = substr($fsecs, 0, 9);
      }

      $date->set(nanosecond => $fsecs);
    }

    return $date;
  }
  elsif($arg =~ /^today$/i)
  {
    $date = DateTime->now(time_zone => $time_zone);
    $date->truncate(to => 'day');
  }
  elsif($arg =~ /^(-)?infinity$/i)
  {
    if($1)
    {
      return DateTime::Infinite::Past->new;
    }

    return DateTime::Infinite::Future->new;
  }
  else
  {
    $Error = "Could not parse date: $arg" .
             (($Error) ? " - $Error" : '');
    return undef;
  }

  unless($date)
  {
    $Error = "Could not parse date: $arg" .
             (($Error) ? " - $Error" : '');
    return undef;
  }

  return $date;
}

sub parse_epoch
{
  my($arg, $time_zone) = @_;

  $time_zone ||= $TZ;

  $Error = undef;

  my $date;

  no warnings 'uninitialized';

  if($arg =~ /^(?: (-?\d+)(?:\.(\d{0,9}))? | (-?\d*)\.(\d{1,9}) )$/x)
  {
    my $epoch = defined $1 ? $1 : $3;
    my $fsecs = defined $2 ? $2 : $4;

    $epoch = 0  if($epoch eq '-');

    # In Unix time format (guessing)
    $date = DateTime->from_epoch(epoch => $epoch || 0, time_zone => $time_zone);

    if($fsecs)
    {
      my $len = length $fsecs;

      if($len < 9)
      {
        $fsecs .= ('0' x (9 - length $fsecs));
      }
      elsif($len > 9)
      {
        $fsecs = substr($fsecs, 0, 9);
      }

      $date->set(nanosecond => $fsecs);
    }

    return $date;
  }
  else
  {
    return parse_date(@_);
  }

  unless($date)
  {
    $Error = "Could not parse epoch: $arg" .
             (($Error) ? " - $Error" : '');
    return undef;
  }

  return $date;
}

sub format_date
{
  my($date, @formats) = @_;

  my(@localtime, %formats, @ret, $ret);

  return undef  unless(defined $date);
  #return $date  if($date =~ /^-?infinity$/i);

  unless(ref $date && $date->isa('DateTime'))
  {
    Carp::croak("format_date() requires a DateTime object as its first argument");
  }

  return '-infinity'  if($date->isa('DateTime::Infinite::Past'));
  return 'infinity'   if($date->isa('DateTime::Infinite::Future'));

  foreach my $format (@formats)
  {
    $format =~ s/%t/%l:%M:%S %p/g; # strftime() treats %t as a \t

    # Formats not handled by strftime()
    if($format =~ /%[EFf]/)
    {
      unless(%formats)
      {
        my $date_word;
        my $mday = $date->day;

        #if($mday =~ /([^1]|^)1$/)    { $date_word = $mday . 'st' }
        #elsif($mday =~ /([^1]|^)2$/) { $date_word = $mday . 'nd' }
        #elsif($mday =~ /([^1]|^)3$/) { $date_word = $mday . 'rd' }
        #else                         { $date_word = $mday . 'th' }

        # Requires a reasonably modern perl
        if($mday =~ /(?
        elsif($mday =~ /(?
        elsif($mday =~ /(?
        else                       { $date_word = $mday . 'th' }

        %formats =
        (
          #'%e' => $mday, # DateTime snagged  this one
          '%E' => $date_word,
          '%F' => $date->strftime("%A, %B $date_word %Y"),
          '%f' => $date->month + 0,
        );
      }

      $format =~ s/(%[eEFf])/$formats{$1}/g;
    }

    push(@ret, $date->strftime($format));
  }

  return wantarray ? @ret : join(' ', @ret);
}

#
# Internal Subroutines
#

sub _timelocal
{
  my($secs, $mins, $hours, $mday, $month, $year, $ampm, $fsecs, $tz) = @_;

  my($date);

  $hours  = 0  unless(defined($hours));

  if(defined $fsecs)
  {
    my $len = length $fsecs;

    if($len < 9)
    {
      $fsecs .= ('0' x (9 - length $fsecs));
    }
    elsif($len > 9)
    {
      $fsecs = substr($fsecs, 0, 9);
    }
  }
  else
  {
    $fsecs = 0;
  }

  $secs  = 0  unless(defined $secs);
  $mins  = 0  unless(defined $mins);

  if($ampm)
  {
    if($ampm =~ /^p/i)
    {
      $hours += 12  unless($hours == 12);
    }
    elsif($hours == 12)
    {
      $hours = 0;
    }
  }

  my $error;

  TRY:
  {
    local $@;

    eval
    {
      $date = DateTime->new(year   => $year,
                            month  => $month,
                            day    => $mday,
                            hour   => $hours,
                            minute => $mins,
                            second => $secs,
                            nanosecond => $fsecs,
                            time_zone => $tz);
    };

    $error = $@;
  }

  if($error)
  {
    $Error = $error;
    warn $Error  if($Debug); # $ENV{'MOD_PERL'}
    return;
  }

  return $date;
}

1;

# Can't figure out how to hide comments like this from search.cpan.org's
# POD-to-HTML translator...
# =begin comment
# B The local time zone may not be known on all systems (in
# particular, Win32 systems).  If you are on such a system, you will encounter a
# fatal error if C tries to construct a L object with
# a time zone of "local".
#
# See the L documentation for information on the various
# ways to successfully indicate your local time zone, or set a different default
# time zone for this class by calling
# Ltime_zone(...)> with a new time zone as an
# argument.
# =end comment

__END__