File Coverage

blib/lib/Time/Duration/Parse/More.pm

Criterion	Covered	Total	%
statement	47	48	97.9
branch	17	20	85.0
condition	3	3	100.0
subroutine	6	7	85.7
pod	2	2	100.0
total	75	80	93.7

package Time::Duration::Parse::More;

# ABSTRACT: parse natural language time duration expressions
our $VERSION = '0.007'; # VERSION
our $AUTHORITY = 'cpan:MELO'; # AUTHORITY

use strict;
use warnings;
use Exporter;
use Carp;

our @ISA    = qw( Exporter );
our @EXPORT = qw( parse_duration );

# From Time::Duration::Parse
my %units = (
  map(($_, 1),                  qw(s second seconds sec secs)),
  map(($_, 60),                 qw(m minute minutes min mins)),
  map(($_, 60 * 60),            qw(h hr hour hours)),
  map(($_, 60 * 60 * 24),       qw(d day days)),
  map(($_, 60 * 60 * 24 * 7),   qw(w week weeks)),
  map(($_, 60 * 60 * 24 * 30),  qw(M month months)),
  map(($_, 60 * 60 * 24 * 365), qw(y year years))
);

my %cache;

sub parse_duration {
  my ($expression) = @_;
  return unless defined $expression;

  return $cache{$expression} if exists $cache{$expression};

  my ($val, $cacheable) = _parse_duration($expression);
  return $val unless $cacheable;
  return $cache{$expression} = $val;
}

sub parse_duration_nc { return (_parse_duration(@_))[0] }

sub _parse_duration {
  my ($expression) = @_;
  return unless defined $expression;

  ## 'midnight' is uncacheable
  if ($expression eq 'midnight') {
    my ($sec, $min, $hour) = (localtime())[0 .. 2];
    return (60 - $sec + (60 - $min - 1) * 60 + (24 - $hour - 1) * 60 * 60, 0);
  }

  my $e = $expression;

  ### split up 1h2m3s...
  my $n_re = qr{[-+]?\d+(?:[.,]\d+)?};
  $e =~ s/ ($n_re) ([hsm]) (?= $n_re [hsm]) /$1 $2 /gxi;
  $e =~ s/ ($n_re) ([hsm]) \b / $1 $2 /gxi;

  $e =~ s/\band\b/ /gi;
  $e =~ s/[\s\t]+/ /g;
  $e =~ s/^\s+|\s+$//g;

  $e =~ s/^\s*([-+]?\d+(?:[.,]\d+)?)\s*$/$1s/;
  $e =~ s/^\s*([-+]?[.,]\d+)\s*$/$1s/;
  $e =~ s/\b(\d+):(\d+):(\d+)\b/$1h $2m $3s/g;
  $e =~ s/\b(\d+):(\d+)\b/$1h $2m/g;

  my $duration = 0;
  my $signal   = 1;
  while ($e) {
    if    ($e =~ s/^plus\b(\s*,?)*//)  { $signal = 1 }
    elsif ($e =~ s/^minus\b(\s*,?)*//) { $signal = -1 }
    elsif ($e =~ s/^(([-+]?\d+(?:[,.]\d*)?)\s*(\w+))(\s*,?)*// or $e =~ s/^(([-+]?[,.]\d+)\s*(\w+))(\s*,?)*//) {
      my ($m, $n, $u) = ($1, $2, $3);
      $n =~ s/,/./;
      $u = lc($u) unless length($u) == 1;
      croak "Unit '$u' not recognized in '$m'" unless exists $units{$u};
      $duration += $signal * $n * $units{$u};
    }
    else {
      croak("Could not parse '$e'");
    }
  }

  return (sprintf('%.0f', $duration), 1);
}


1;

__END__