Time-Duration-Parse-0.06/0000755000077000007700000000000011020104245017227 5ustar tatsuhikotatsuhiko00000000000000Time-Duration-Parse-0.06/Changes0000644000077000007700000000164111020103762020527 0ustar tatsuhikotatsuhiko00000000000000Revision history for Perl extension Time::Duration::Parse 0.06 Fri May 30 16:04:12 PDT 2008 - Accept 1.5h (Thanks to Thomas Sibley) 0.05 Thu Jan 10 12:05:26 PST 2008 - Accept hh:mm(:ss) as a format. - Relaxed to handle trailing spaces. (Thanks to Thomas Sibley) 0.04 Fri Jan 4 17:11:45 PST 2008 - Compatible to Time::Duration's concise. RT:32078 (Thanks to Thomas Sibley) 0.03 Mon Nov 5 12:18:15 PST 2007 - Accept 'hr' for hours (Ricardo SIGNES) - Do not require space between digits and units (1hr) (Ricaldo SIGNES) - Accept a simple integer as a number of seconds (Jonathan Swartz) - Accept negative durations like "-30 minutes" (Jonathan Swartz) 0.02 Tue Jul 18 16:58:53 JST 2006 - Accept upper-case timespec like '3 Seconds' as well. - Unified exception format 0.01 Tue Jul 18 02:29:01 2006 - original version Time-Duration-Parse-0.06/inc/0000755000077000007700000000000011020104245020000 5ustar tatsuhikotatsuhiko00000000000000Time-Duration-Parse-0.06/inc/Module/0000755000077000007700000000000011020104245021225 5ustar tatsuhikotatsuhiko00000000000000Time-Duration-Parse-0.06/inc/Module/Install/0000755000077000007700000000000011020104245022633 5ustar tatsuhikotatsuhiko00000000000000Time-Duration-Parse-0.06/inc/Module/Install/Base.pm0000644000077000007700000000203511020104244024042 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Module::Install::Base; $VERSION = '0.68'; # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } ### This is the ONLY module that shouldn't have strict on # use strict; #line 41 sub new { my ($class, %args) = @_; foreach my $method ( qw(call load) ) { *{"$class\::$method"} = sub { shift()->_top->$method(@_); } unless defined &{"$class\::$method"}; } bless( \%args, $class ); } #line 61 sub AUTOLOAD { my $self = shift; local $@; my $autoload = eval { $self->_top->autoload } or return; goto &$autoload; } #line 76 sub _top { $_[0]->{_top} } #line 89 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $Fake; sub new { $Fake ||= bless(\@_, $_[0]) } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 138 Time-Duration-Parse-0.06/inc/Module/Install/Can.pm0000644000077000007700000000337411020104244023700 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Module::Install::Can; use strict; use Module::Install::Base; use Config (); ### This adds a 5.005 Perl version dependency. ### This is a bug and will be fixed. use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.68'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 157 Time-Duration-Parse-0.06/inc/Module/Install/Fetch.pm0000644000077000007700000000463011020104244024224 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.68'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Time-Duration-Parse-0.06/inc/Module/Install/Include.pm0000644000077000007700000000101411020104244024547 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Module::Install::Include; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.68'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; Time-Duration-Parse-0.06/inc/Module/Install/Makefile.pm0000644000077000007700000001351111020104244024706 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Module::Install::Makefile; use strict 'vars'; use Module::Install::Base; use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.68'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ($self->{makemaker_args} ||= {}); %$args = ( %$args, @_ ) if @_; $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join(' ', grep length, $clean->{FILES}, @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join(' ', grep length, $realclean->{FILES}, @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } require File::Find; %test_dir = (); File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args); $args->{VERSION} = $self->version || $self->determine_VERSION($args); $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ($] >= 5.005) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->build_requires, $self->requires) ); # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { $args{dist} = $preop; } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 363 Time-Duration-Parse-0.06/inc/Module/Install/Metadata.pm0000644000077000007700000002152711020104244024717 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.68'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } my @scalar_keys = qw{ name module_name abstract author version license distribution_type perl_version tests installdirs }; my @tuple_keys = qw{ build_requires requires recommends bundles }; sub Meta { shift } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } foreach my $key (@scalar_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} if defined wantarray and !@_; $self->{values}{$key} = shift; return $self; }; } foreach my $key (@tuple_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} unless @_; my @rv; while (@_) { my $module = shift or last; my $version = shift || 0; if ( $module eq 'perl' ) { $version =~ s{^(\d+)\.(\d+)\.(\d+)} {$1 + $2/1_000 + $3/1_000_000}e; $self->perl_version($version); next; } my $rv = [ $module, $version ]; push @rv, $rv; } push @{ $self->{values}{$key} }, @rv; @rv; }; } # configure_requires is currently a null-op sub configure_requires { 1 } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub sign { my $self = shift; return $self->{'values'}{'sign'} if defined wantarray and ! @_; $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 ); return $self; } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; return $self; } $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0; return $self; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die "all_from called with no args without setting name() first"; $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; die "all_from: cannot find $file from $name" unless -e $file; } $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; # The remaining probes read from POD sections; if the file # has an accompanying .pod, use that instead my $pod = $file; if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) { $file = $pod; } $self->author_from($file) unless $self->author; $self->license_from($file) unless $self->license; $self->abstract_from($file) unless $self->abstract; } sub provides { my $self = shift; my $provides = ( $self->{values}{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides(%{ $build->find_dist_packages || {} }); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}{no_index}{$type} }, @_ if $type; return $self->{values}{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML', 0 ); require YAML; my $data = YAML::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } sub _slurp { my ( $self, $file ) = @_; local *FH; open FH, "< $file" or die "Cannot open $file.pod: $!"; do { local $/; }; } sub perl_version_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ ^ use \s* v? ([\d_\.]+) \s* ; /ixms ) { my $v = $1; $v =~ s{_}{}g; $self->perl_version($1); } else { warn "Cannot determine perl version info from $file\n"; return; } } sub author_from { my ( $self, $file ) = @_; my $content = $self->_slurp($file); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $file\n"; } } sub license_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as perl itself' => 'perl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser public license' => 'gpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { if ( $osi and $license_text =~ /All rights reserved/i ) { warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it."; } $self->license($license); return 1; } } } warn "Cannot determine license info from $file\n"; return 'unknown'; } 1; Time-Duration-Parse-0.06/inc/Module/Install/Win32.pm0000644000077000007700000000341611020104244024076 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Module::Install::Win32; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.68'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); if (!$rv) { die <<'END_MESSAGE'; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } } 1; Time-Duration-Parse-0.06/inc/Module/Install/WriteAll.pm0000644000077000007700000000162411020104244024716 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.68'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_ ); $self->sign(1) if $args{sign}; $self->Meta->write if $args{meta}; $self->admin->WriteAll(%args) if $self->is_admin; if ( $0 =~ /Build.PL$/i ) { $self->Build->write; } else { $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{'PL_FILES'} ) { $self->makemaker_args( PL_FILES => {} ); } if ($args{inline}) { $self->Inline->write; } else { $self->Makefile->write; } } } 1; Time-Duration-Parse-0.06/inc/Module/Install.pm0000644000077000007700000001761111020104244023176 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.004; use strict 'vars'; use vars qw{$VERSION}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.68'; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE"; Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE } # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 and (stat($0))[9] > time ) { die << "END_DIE"; Your installer $0 has a modification time in the future. This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } use Cwd (); use File::Find (); use File::Path (); use FindBin; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; unshift @_, ($self, $1); goto &{$self->can('call')} unless uc($1) eq $1; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; } sub preload { my ($self) = @_; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { my $admin = $self->{admin}; @exts = $admin->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!"; my $in_pod = 0; while ( ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } close PKGFILE; } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } 1; Time-Duration-Parse-0.06/inc/Test/0000755000077000007700000000000011020104245020717 5ustar tatsuhikotatsuhiko00000000000000Time-Duration-Parse-0.06/inc/Test/More.pm0000644000077000007700000003432111020104244022161 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Test::More; use 5.004; use strict; # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my($file, $line) = (caller(1))[1,2]; warn @_, " at $file line $line\n"; } use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); $VERSION = '0.74'; $VERSION = eval $VERSION; # make the alpha version come out as a number use Test::Builder::Module; @ISA = qw(Test::Builder::Module); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan can_ok isa_ok diag BAIL_OUT ); #line 157 sub plan { my $tb = Test::More->builder; $tb->plan(@_); } # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { my $class = shift; my $list = shift; my @other = (); my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } else { push @other, $item; } $idx++; } @$list = @other; } #line 257 sub ok ($;$) { my($test, $name) = @_; my $tb = Test::More->builder; $tb->ok($test, $name); } #line 324 sub is ($$;$) { my $tb = Test::More->builder; $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; $tb->isnt_eq(@_); } *isn't = \&isnt; #line 369 sub like ($$;$) { my $tb = Test::More->builder; $tb->like(@_); } #line 385 sub unlike ($$;$) { my $tb = Test::More->builder; $tb->unlike(@_); } #line 425 sub cmp_ok($$$;$) { my $tb = Test::More->builder; $tb->cmp_ok(@_); } #line 461 sub can_ok ($@) { my($proto, @methods) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; unless( $class ) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } unless( @methods ) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { $tb->_try(sub { $proto->can($method) }) or push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; my $ok = $tb->ok( !@nok, $name ); $tb->diag(map " $class->can('$_') failed\n", @nok); return $ok; } #line 523 sub isa_ok ($$;$) { my($object, $class, $obj_name) = @_; my $tb = Test::More->builder; my $diag; $obj_name = 'The object' unless defined $obj_name; my $name = "$obj_name isa $class"; if( !defined $object ) { $diag = "$obj_name isn't defined"; } elsif( !ref $object ) { $diag = "$obj_name isn't a reference"; } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides my($rslt, $error) = $tb->_try(sub { $object->isa($class) }); if( $error ) { if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { # Its an unblessed reference if( !UNIVERSAL::isa($object, $class) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } else { die <isa on your object and got some weird error. Here's the error. $error WHOA } } elsif( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } my $ok; if( $diag ) { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } else { $ok = $tb->ok( 1, $name ); } return $ok; } #line 592 sub pass (;$) { my $tb = Test::More->builder; $tb->ok(1, @_); } sub fail (;$) { my $tb = Test::More->builder; $tb->ok(0, @_); } #line 653 sub use_ok ($;@) { my($module, @imports) = @_; @imports = () unless @imports; my $tb = Test::More->builder; my($pack,$filename,$line) = caller; # Work around a glitch in $@ and eval my $eval_error; { local($@,$!,$SIG{__DIE__}); # isolate eval if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { # probably a version check. Perl needs to see the bare number # for it to work with non-Exporter based modules. eval <ok( !$eval_error, "use $module;" ); unless( $ok ) { chomp $eval_error; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(<builder; my $pack = caller; # Try to deterine if we've been given a module name or file. # Module names must be barewords, files not. $module = qq['$module'] unless _is_module_name($module); local($!, $@, $SIG{__DIE__}); # isolate eval local $SIG{__DIE__}; eval <ok( !$@, "require $module;" ); unless( $ok ) { chomp $@; $tb->diag(<builder; unless( @_ == 2 or @_ == 3 ) { my $msg = <ok(0); } my($got, $expected, $name) = @_; $tb->_unoverload_str(\$expected, \$got); my $ok; if( !ref $got and !ref $expected ) { # neither is a reference $ok = $tb->is_eq($got, $expected, $name); } elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't $ok = $tb->ok(0, $name); $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); } else { # both references local @Data_Stack = (); if( _deep_check($got, $expected) ) { $ok = $tb->ok(1, $name); } else { $ok = $tb->ok(0, $name); $tb->diag(_format_stack(@Data_Stack)); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{$Stack[-1]{vals}}[0,1]; my @vars = (); ($vars[0] = $var) =~ s/\$FOO/ \$got/; ($vars[1] = $var) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx (0..$#vals) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : _dne($val) ? "Does not exist" : ref $val ? "$val" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } sub _type { my $thing = shift; return '' if !ref $thing; for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { return $type if UNIVERSAL::isa($thing, $type); } return ''; } #line 930 sub diag { my $tb = Test::More->builder; $tb->diag(@_); } #line 999 #'# sub skip { my($why, $how_many) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } if( defined $how_many and $how_many =~ /\D/ ) { _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } for( 1..$how_many ) { $tb->skip($why); } local $^W = 0; last SKIP; } #line 1086 sub todo_skip { my($why, $how_many) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1..$how_many ) { $tb->todo_skip($why); } local $^W = 0; last TODO; } #line 1139 sub BAIL_OUT { my $reason = shift; my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } #line 1178 #'# sub eq_array { local @Data_Stack; _deep_check(@_); } sub _eq_array { my($a1, $a2) = @_; if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for (0..$max) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; $ok = _deep_check($e1,$e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _deep_check { my($e1, $e2) = @_; my $tb = Test::More->builder; my $ok = 0; # Effectively turn %Refs_Seen into a stack. This avoids picking up # the same referenced used twice (such as [\$a, \$a]) to be considered # circular. local %Refs_Seen = %Refs_Seen; { # Quiet uninitialized value warnings when comparing undefs. local $^W = 0; $tb->_unoverload_str(\$e1, \$e2); # Either they're both references or both not. my $same_ref = !(!ref $e1 xor !ref $e2); my $not_ref = (!ref $e1 and !ref $e2); if( defined $e1 xor defined $e2 ) { $ok = 0; } elsif ( _dne($e1) xor _dne($e2) ) { $ok = 0; } elsif ( $same_ref and ($e1 eq $e2) ) { $ok = 1; } elsif ( $not_ref ) { push @Data_Stack, { type => '', vals => [$e1, $e2] }; $ok = 0; } else { if( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; } else { $Refs_Seen{$e1} = "$e2"; } my $type = _type($e1); $type = 'DIFFERENT' unless _type($e2) eq $type; if( $type eq 'DIFFERENT' ) { push @Data_Stack, { type => $type, vals => [$e1, $e2] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { $ok = _eq_array($e1, $e2); } elsif( $type eq 'HASH' ) { $ok = _eq_hash($e1, $e2); } elsif( $type eq 'REF' ) { push @Data_Stack, { type => $type, vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } elsif( $type eq 'SCALAR' ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } elsif( $type ) { push @Data_Stack, { type => $type, vals => [$e1, $e2] }; $ok = 0; } else { _whoa(1, "No type in _deep_check"); } } } return $ok; } sub _whoa { my($check, $desc) = @_; if( $check ) { die < keys %$a2 ? $a1 : $a2; foreach my $k (keys %$bigger) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; $ok = _deep_check($e1, $e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } #line 1366 sub eq_set { my($a1, $a2) = @_; return 0 unless @$a1 == @$a2; # There's faster ways to do this, but this is easiest. local $^W = 0; # It really doesn't matter how we sort them, as long as both arrays are # sorted with the same algorithm. # # Ensure that references are not accidentally treated the same as a # string containing the reference. # # Have to inline the sort routine due to a threading/sort bug. # See [rt.cpan.org 6782] # # I don't know how references would be sorted so we just don't sort # them. This means eq_set doesn't really work with refs. return eq_array( [grep(ref, @$a1), sort( grep(!ref, @$a1) )], [grep(ref, @$a2), sort( grep(!ref, @$a2) )], ); } #line 1556 1; Time-Duration-Parse-0.06/inc/Time/0000755000077000007700000000000011020104245020676 5ustar tatsuhikotatsuhiko00000000000000Time-Duration-Parse-0.06/inc/Time/Duration.pm0000644000077000007700000001602211020104244023021 0ustar tatsuhikotatsuhiko00000000000000#line 1 package Time::Duration; # POD is at the end. $VERSION = '1.06'; require Exporter; @ISA = ('Exporter'); @EXPORT = qw( later later_exact earlier earlier_exact ago ago_exact from_now from_now_exact duration duration_exact concise ); @EXPORT_OK = ('interval', @EXPORT); use strict; use constant DEBUG => 0; # ALL SUBS ARE PURE FUNCTIONS #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub concise ($) { my $string = $_[0]; #print "in : $string\n"; $string =~ tr/,//d; $string =~ s/\band\b//; $string =~ s/\b(year|day|hour|minute|second)s?\b/substr($1,0,1)/eg; $string =~ s/\s*(\d+)\s*/$1/g; return $string; } sub later { interval( $_[0], $_[1], ' earlier', ' later', 'right then'); } sub later_exact { interval_exact($_[0], $_[1], ' earlier', ' later', 'right then'); } sub earlier { interval( $_[0], $_[1], ' later', ' earlier', 'right then'); } sub earlier_exact { interval_exact($_[0], $_[1], ' later', ' earlier', 'right then'); } sub ago { interval( $_[0], $_[1], ' from now', ' ago', 'right now'); } sub ago_exact { interval_exact($_[0], $_[1], ' from now', ' ago', 'right now'); } sub from_now { interval( $_[0], $_[1], ' ago', ' from now', 'right now'); } sub from_now_exact { interval_exact($_[0], $_[1], ' ago', ' from now', 'right now'); } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub duration_exact { my $span = $_[0]; # interval in seconds my $precision = int($_[1] || 0) || 2; # precision (default: 2) return '0 seconds' unless $span; _render('', _separate(abs $span)); } sub duration { my $span = $_[0]; # interval in seconds my $precision = int($_[1] || 0) || 2; # precision (default: 2) return '0 seconds' unless $span; _render('', _approximate($precision, _separate(abs $span))); } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub interval_exact { my $span = $_[0]; # interval, in seconds # precision is ignored my $direction = ($span <= -1) ? $_[2] # what a neg number gets : ($span >= 1) ? $_[3] # what a pos number gets : return $_[4]; # what zero gets _render($direction, _separate($span)); } sub interval { my $span = $_[0]; # interval, in seconds my $precision = int($_[1] || 0) || 2; # precision (default: 2) my $direction = ($span <= -1) ? $_[2] # what a neg number gets : ($span >= 1) ? $_[3] # what a pos number gets : return $_[4]; # what zero gets _render($direction, _approximate($precision, _separate($span))); } #~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~# # # The actual figuring is below here use constant MINUTE => 60; use constant HOUR => 3600; use constant DAY => 24 * HOUR; use constant YEAR => 365 * DAY; sub _separate { # Breakdown of seconds into units, starting with the most significant my $remainder = abs $_[0]; # remainder my $this; # scratch my @wheel; # retval # Years: $this = int($remainder / (365 * 24 * 60 * 60)); push @wheel, ['year', $this, 1_000_000_000]; $remainder -= $this * (365 * 24 * 60 * 60); # Days: $this = int($remainder / (24 * 60 * 60)); push @wheel, ['day', $this, 365]; $remainder -= $this * (24 * 60 * 60); # Hours: $this = int($remainder / (60 * 60)); push @wheel, ['hour', $this, 24]; $remainder -= $this * (60 * 60); # Minutes: $this = int($remainder / 60); push @wheel, ['minute', $this, 60]; $remainder -= $this * 60; push @wheel, ['second', int($remainder), 60]; return @wheel; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub _approximate { # Now nudge the wheels into an acceptably (im)precise configuration my($precision, @wheel) = @_; Fix: { # Constraints for leaving this block: # 1) number of nonzero wheels must be <= $precision # 2) no wheels can be improperly expressed (like having "60" for mins) my $nonzero_count = 0; my $improperly_expressed; DEBUG and print join ' ', '#', (map "${$_}[1] ${$_}[0]", @wheel), "\n"; for(my $i = 0; $i < @wheel; $i++) { my $this = $wheel[$i]; next if $this->[1] == 0; # Zeros require no attention. ++$nonzero_count; next if $i == 0; # the years wheel is never improper or over any limit; skip if($nonzero_count > $precision) { # This is one nonzero wheel too many! DEBUG and print '', $this->[0], " is one nonzero too many!\n"; # Incr previous wheel if we're big enough: if($this->[1] >= ($this->[-1] / 2)) { DEBUG and printf "incrementing %s from %s to %s\n", $wheel[$i-1][0], $wheel[$i-1][1], 1 + $wheel[$i-1][1], ; ++$wheel[$i-1][1]; } # Reset this and subsequent wheels to 0: for(my $j = $i; $j < @wheel; $j++) { $wheel[$j][1] = 0 } redo Fix; # Start over. } elsif($this->[1] >= $this->[-1]) { # It's an improperly expressed wheel. (Like "60" on the mins wheel) $improperly_expressed = $i; DEBUG and print '', $this->[0], ' (', $this->[1], ") is improper!\n"; } } if(defined $improperly_expressed) { # Only fix the least-significant improperly expressed wheel (at a time). DEBUG and printf "incrementing %s from %s to %s\n", $wheel[$improperly_expressed-1][0], $wheel[$improperly_expressed-1][1], 1 + $wheel[$improperly_expressed-1][1], ; ++$wheel[ $improperly_expressed - 1][1]; $wheel[ $improperly_expressed][1] = 0; # We never have a "150" in the minutes slot -- if it's improper, # it's only by having been rounded up to the limit. redo Fix; # Start over. } # Otherwise there's not too many nonzero wheels, and there's no # improperly expressed wheels, so fall thru... } return @wheel; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub _render { # Make it into English my $direction = shift @_; my @wheel = map {; ( $_->[1] == 0) ? () # zero wheels : ($_->[1] == 1) ? "${$_}[1] ${$_}[0]" # singular : "${$_}[1] ${$_}[0]s" # plural } @_ ; return "just now" unless @wheel; # sanity $wheel[-1] .= $direction; return $wheel[0] if @wheel == 1; return "$wheel[0] and $wheel[1]" if @wheel == 2; $wheel[-1] = "and $wheel[-1]"; return join q{, }, @wheel; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1; __END__ so "1y 0d 1h 50m 50s", N=3, so you round at minutes to "1y 0d 1h 51m 0s", #That's okay, so fall thru. so "1y 1d 0h 59m 50s", N=3, so you round at minutes to "1y 1d 0h 60m 0s", but that's not improperly expressed, so you loop around and get "1y 1d 1h 0m 0s", which is short enough, and is properly expressed. #line 444 Time-Duration-Parse-0.06/lib/0000755000077000007700000000000011020104245017775 5ustar tatsuhikotatsuhiko00000000000000Time-Duration-Parse-0.06/lib/Time/0000755000077000007700000000000011020104245020673 5ustar tatsuhikotatsuhiko00000000000000Time-Duration-Parse-0.06/lib/Time/Duration/0000755000077000007700000000000011020104245022460 5ustar tatsuhikotatsuhiko00000000000000Time-Duration-Parse-0.06/lib/Time/Duration/Parse.pm0000644000077000000000000000546711020104206023154 0ustar tatsuhikowheel00000000000000package Time::Duration::Parse; use strict; our $VERSION = '0.06'; use Carp; use Exporter::Lite; our @EXPORT = qw( parse_duration ); # This map is taken from Cache and Cache::Cache # map of expiration formats to their respective time in seconds 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)) ); sub parse_duration { my $timespec = shift; # Treat a plain number as a number of seconds (and parse it later) if ($timespec =~ /^\s*(-?\d+(?:[.,]\d+)?)\s*$/) { $timespec = "$1s"; } # Convert hh:mm(:ss)? to something we understand $timespec =~ s/\b(\d+):(\d\d):(\d\d)\b/$1h $2m $3s/g; $timespec =~ s/\b(\d+):(\d\d)\b/$1h $2m/g; my $duration = 0; while ($timespec =~ s/^\s*(-?\d+(?:[.,]\d+)?)\s*([a-zA-Z]+)(?:\s*(?:,|and)\s*)*//i) { my($amount, $unit) = ($1, $2); $unit = lc($unit) unless length($unit) == 1; if (my $value = $Units{$unit}) { $amount =~ s/,/./; $duration += $amount * $value; } else { Carp::croak "Unknown timespec: $1 $2"; } } if ($timespec =~ /\S/) { Carp::croak "Unknown timespec: $timespec"; } return sprintf "%.0f", $duration; } 1; __END__ =head1 NAME Time::Duration::Parse - Parse string that represents time duration =head1 SYNOPSIS use Time::Duration::Parse; my $seconds = parse_duration("2 minutes and 3 seconds"); # 123 =head1 DESCRIPTION Time::Duration::Parse is a module to parse human readable duration strings like I<2 minutes and 3 seconds> to seconds. It does the opposite of I function in Time::Duration and is roundtrip safe. So, the following is always true. use Time::Duration::Parse; use Time::Duration; my $seconds = int rand 100000; is( parse_duration(duration_exact($seconds)), $seconds ); =head1 FUNCTIONS =over 4 =item parse_duration $seconds = parse_duration($string); Parses duration string and returns seconds. When it encounters an error in a given string, it dies an exception saying "Unknown timespec: blah blah blah". This function is exported by default. =head1 AUTHOR Tatsuhiko Miyagawa Emiyagawa@bulknews.netE =head1 COPYRIGHT This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Some internal code is taken from Cache and Cache::Cache modules on CPAN. =head1 SEE ALSO L, L, L =cut Time-Duration-Parse-0.06/Makefile.PL0000644000077000007700000000032611020103655021206 0ustar tatsuhikotatsuhiko00000000000000use inc::Module::Install; name('Time-Duration-Parse'); all_from('lib/Time/Duration/Parse.pm'); requires('Exporter::Lite'); build_requires('Test::More'); build_requires('Time::Duration'); auto_include; WriteAll; Time-Duration-Parse-0.06/MANIFEST0000644000077000007700000000064711020103655020373 0ustar tatsuhikotatsuhiko00000000000000Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm inc/Test/More.pm inc/Time/Duration.pm lib/Time/Duration/Parse.pm Makefile.PL MANIFEST This list of files META.yml t/00_compile.t t/01_parse.t t/02_roundtrip.t Time-Duration-Parse-0.06/META.yml0000644000077000007700000000070611020104244020502 0ustar tatsuhikotatsuhiko00000000000000--- abstract: Parse string that represents time duration author: - Tatsuhiko Miyagawa build_requires: Test::More: 0 Time::Duration: 0 distribution_type: module generated_by: Module::Install version 0.68 license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.3.html version: 1.3 name: Time-Duration-Parse no_index: directory: - inc - t requires: Exporter::Lite: 0 version: 0.06 Time-Duration-Parse-0.06/t/0000755000077000007700000000000011020104245017472 5ustar tatsuhikotatsuhiko00000000000000Time-Duration-Parse-0.06/t/00_compile.t0000644000077000007700000000012111020103655021604 0ustar tatsuhikotatsuhiko00000000000000use strict; use Test::More tests => 1; BEGIN { use_ok 'Time::Duration::Parse' } Time-Duration-Parse-0.06/t/01_parse.t0000644000077000000000000000255611020103707020356 0ustar tatsuhikowheel00000000000000use strict; use Test::More tests => 37; use Time::Duration::Parse; sub ok_duration { my($spec, $seconds) = @_; is parse_duration($spec), $seconds, "$spec = $seconds"; } sub fail_duration { my $spec = shift; eval { parse_duration($spec) }; ok $@, $@; } ok_duration '3', 3; ok_duration '3 seconds', 3; ok_duration '3 Seconds', 3; ok_duration '3 s', 3; ok_duration '6 minutes', 360; ok_duration '6 minutes and 3 seconds', 363; ok_duration '6 Minutes and 3 seconds', 363; ok_duration '1 day', 86400; ok_duration '1 day, and 3 seconds', 86403; ok_duration '-1 seconds', -1; ok_duration '-6 minutes', -360; ok_duration '1 hr', 3600; ok_duration '3s', 3; ok_duration '1hr', 3600; ok_duration '1d 2:03', 93780; ok_duration '1d 2:03:01', 93781; ok_duration '1d -24:00', 0; ok_duration '2:03', 7380; ok_duration ' 1s ', 1; ok_duration ' 1 ', 1; ok_duration ' 1.3 ', 1; ok_duration '1.5h', 5400; ok_duration '1,5h', 5400; ok_duration '1.5h 30m', 7200; ok_duration '1.9s', 2; # Check rounding ok_duration '1.3s', 1; ok_duration '1.3', 1; ok_duration '1.9', 2; ok_duration '1h,30m, 3s', 5403; ok_duration '1h and 30m,3s', 5403; ok_duration '1,5h, 3s', 5403; ok_duration '1,5h and 3s', 5403; ok_duration '1.5h, 3s', 5403; ok_duration '1.5h and 3s', 5403; fail_duration '3 sss'; fail_duration '6 minutes and 3 sss'; fail_duration '6 minutes, and 3 seconds a'; Time-Duration-Parse-0.06/t/02_roundtrip.t0000644000077000007700000000100211020103655022203 0ustar tatsuhikotatsuhiko00000000000000use strict; use Test::More; use Time::Duration::Parse; eval { require Time::Duration }; if ($@) { plan skip_all => 'Time::Duration is required'; } plan tests => 2000; my @tests = map int rand(100_000), 1..1000; for my $test (@tests) { my $spec = Time::Duration::duration_exact($test); is parse_duration($spec), $test, "$spec - $test"; } for my $test (@tests) { my $spec = Time::Duration::concise(Time::Duration::duration_exact($test)); is parse_duration($spec), $test, "$spec - $test"; }