File Coverage

blib/lib/Time/Stamp.pm

Criterion	Covered	Total	%
statement	72	72	100.0
branch	51	52	98.0
condition	9	11	81.8
subroutine	14	14	100.0
pod			n/a
total	146	149	97.9

# vim: set sw=2 sts=2 ts=2 expandtab smarttab:
#
# This file is part of Time-Stamp
#
# This software is copyright (c) 2011 by Randy Stauner.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package Time::Stamp;
{
  $Time::Stamp::VERSION = '1.300';
}
# git description: v1.200-5-gd4b4217

BEGIN {
  $Time::Stamp::AUTHORITY = 'cpan:RWSTAUNER';
}
# ABSTRACT: Easy, readable, efficient timestamp functions

# TODO: use collector?

use Sub::Exporter 0.982 -setup => {
  -as => 'do_import',
  exports => [
    localstamp => \'_build_localstamp',
    gmstamp    => \'_build_gmstamp',
    parsegm    => \'_build_parsestamp',
    parselocal => \'_build_parsestamp',
  ],
  groups => [
    stamps => [qw(localstamp gmstamp)],
    parsers => [qw(parselocal parsegm)],
  ]
};

sub import {
  @_ = map {
    /(local|gm)(?:stamp)?((?:-\w+)+)/
    ? ($1.'stamp' => {
        map  {
          /^([um]s)$/ ? ($1 => 1)
            : (format => $_)
        }
        grep { $_ }
          split(/-/, $2)
      })
    : $_
  } @_;
  goto &do_import;
}

# set up named formats with default values
my $formats = do {
  # should we offer { prefix => '', suffix => '' } ? is that really useful?
  # the stamps are easy enough to parse as is (the whole point of this module)
  my %default = (
    date_sep => '-',
    dt_sep   => 'T', # ISO 8601
    time_sep => ':',
    tz_sep   => '',
    tz       => '',
  );
  my %blank = map { $_ => '' } keys %default;
  my $n = {
    default  => {%default},
    easy     => {%default, dt_sep => ' ', tz_sep => ' '}, # easier to read
    numeric  => {%blank},
    compact  => {
      %blank,
      dt_sep   => '_', # visual separation
    },
  };
  # aliases
  $n->{$_} = $n->{default} for qw(iso8601 rfc3339 w3cdtf);
  $n;
};

# we could offer a separate format_time_array() but currently
# I think the gain would be less than the cost of the extra function call:
# sub _build { return sub { format_time_array($arg, @_ or localtime) }; }
# sub format_time_array { sprintf(_format(shift), _ymdhms(@_)) }

sub _build_localstamp {
##my ( $class, $name, $arg, $col ) = @_;
  my ( undef, undef, $arg, undef ) = @_;

  return _generate_code(local => $arg);
}

sub _build_gmstamp {
##my ( $class, $name, $arg, $col ) = @_;
  my ( undef, undef, $arg, undef ) = @_;

  # add the Z for UTC (Zulu) time zone unless the numeric format is requested
  $arg = {tz => 'Z', %$arg}
    unless $arg->{format} && $arg->{format} eq 'numeric';

  return _generate_code(gm => $arg);
}

# TODO: could these subs be faster with a no_args option? would only save 2 if's
sub _generate_code {
  my ($which, $arg) = @_;
  $arg = { %$arg };
  # note: mu is 03BC
  $arg->{frac} ||= $arg->{us} ? 6 : $arg->{ms} ? 3 : 0;

  my $format = _format($arg);

  my $code;
  my $vars = {
    which => $which,
  };
  if( $arg->{frac} ){
    $vars->{frac} = $arg->{frac};
    # always display a fraction if requested
    $vars->{gettime} = _have_hires()
      # gettimeofday() returns microseconds, so we need six digits to stringify
      # which means we need a sprintf somewhere
      ? 'do { my @t = Time::HiRes::gettimeofday(); $t[1] = sprintf "%06d", $t[1]; @t }'
      # if HiRes fails to load use whole number precision
      : '(time(), 0)';

    $code = <<'CODE';
      sub {
        # localtime() will not preserve the fraction, so separate it
        my ($t, $f) = @_ ? (split(/\./, $_[0]), 0) : {{gettime}};

        my @lt = _ymdhms(@_ > 1 ? @_ : {{which}}time($t));

        # use %.6f for precision, but strip leading zero
        return sprintf($format, @lt, substr(sprintf('%.{{frac}}f', '.'.$f), 1));
      };
CODE
  }
  # if not using fraction return a more efficient sub
  else {
    $code = <<'CODE';
      sub {
        return sprintf($format,
          _ymdhms(@_ > 1 ? @_ : {{which}}time(@_ ? $_[0] : time))
        );
      };
CODE
  }
  # poor man's template (easier than sprintf or escaping sigils)
  $code =~ s/\{\{(\w+)\}\}/$vars->{$1}/g;

  return do { eval $code or die $@ }; ## no critic (StringyEval)
}

sub _build_parsestamp {
##my ($class, $name, $arg, $col) = @_;
  my ( undef, $name, $arg, undef ) = @_;

  # pre-compile the regexp
  my $regexp = exists $arg->{regexp}
    ? qr/$arg->{regexp}/
    : qr/^ (\d{4}) \D* (\d{2}) \D* (\d{2}) \D*
           (\d{2}) \D* (\d{2}) \D* (\d{2}) (?:\.(\d+))? .* $/x;

  require Time::Local; # core
  my $time = $name eq 'parsegm'
    ? \&Time::Local::timegm
    : \&Time::Local::timelocal;

  return sub {
    my ($stamp) = @_;
    my ($frac, @time) = reverse ($stamp =~ $regexp);

    # if the regexp didn't match (empty list) give up now
    return
      if !@time;

    # regexp didn't have 7th capture group (for fraction)
    if( @time < 6 ){
      unshift @time, $frac;
      # if there was a fraction in group 6 separate it
      # or timelocal may produce something unexpected.
      # if there was no fraction $frac will be undef
      ($time[0], $frac) = split(/\./, $time[0]);
    }

    # coerce strings into numbers (map { int } would not work for fractions)
    @time = map { $_ + 0 } @time;

    $time[5] -= 1900; # year
    $time[4] -= 1;    # month

    # make sure it starts with a dot (whether it has one or not)
    $frac =~ s/^0?\.?/./
      if defined $frac;

    if( wantarray ){
      $time[0] .= $frac
        if defined $frac;
      return @time;
    }
    else {
      my $ts = &$time(@time);
      $ts .= $frac
        if defined $frac;
      return $ts;
    }
  };
}

sub _format {
  my ($arg) = @_;

  my $name = $arg->{format} || ''; # avoid undef
  # we could return $arg->{format} unless exists $formats->{$name}; warn if no % found?
  # or just return $arg->{sprintf} if exists $arg->{sprintf};
  $name = 'default'
    unless exists $formats->{$name};

  # start with named format, overwrite with any explicitly specified options
  my %opt = (%{ $formats->{$name} }, %$arg);

  # TODO: $opt{tz} = tz_offset() if $opt{guess_tz};

  # sadly "%02.6f" does not zero-pad the integer portion, so we have to be trickier

  return
    join($opt{date_sep}, qw(%04d %02d %02d)) .
    $opt{dt_sep} .
    join($opt{time_sep}, qw(%02d %02d %02d)) .
    ($opt{frac} ? '%s' : '') .
    ($opt{tz} ? $opt{tz_sep} . $opt{tz} : '')
  ;
}

# convert *time() arrays to something ready to send to sprintf
sub _ymdhms {
  return ($_[5] + 1900, $_[4] + 1, @_[3, 2, 1, 0]);
}

my $_have_hires;
sub _have_hires {
  if( !defined($_have_hires) ){
    local $@;
    $_have_hires = eval { require Time::HiRes; 1 } || do {
      warn "Time::HiRes requested but failed to load: $@";
      0;
    };
  }
  return $_have_hires;
}

# define default localstamp and gmstamp in this package
# so that exporting is not strictly required
__PACKAGE__->import(qw(
  localstamp
  gmstamp
  parsegm
  parselocal
));

1;

__END__