├── .githooks └── pre-commit ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .mailmap ├── .travis.yml ├── Changes ├── LICENSE ├── MANIFEST ├── Makefile.PL ├── Piece.pm ├── Piece.xs ├── README.md ├── Seconds.pm ├── TODO ├── cpanfile ├── rev_deps.pl ├── reverse_deps.txt ├── setup-hooks.sh └── t ├── 01base.t ├── 02core.t ├── 02core_dst.t ├── 03compare.t ├── 04mjd.t ├── 05overload.t ├── 06large.t ├── 06subclass.t ├── 07arith.t ├── 08truncate.t ├── 09locales.t ├── 10overload.t ├── 99legacy.t └── lib └── Time └── Piece └── Twin.pm /.githooks/pre-commit: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # Check if Piece.pm has been modified 7 | my $git_diff = `git diff --cached --name-only`; 8 | exit 0 unless $git_diff =~ /Piece\.pm/; 9 | 10 | print "Updating README.md with latest POD from Piece.pm...\n"; 11 | 12 | # Check if Pod::Markdown is installed 13 | eval { require Pod::Markdown }; 14 | if ($@) { 15 | print "Error: Pod::Markdown is required but not installed.\n"; 16 | print "Please install it with: cpanm Pod::Markdown\n"; 17 | exit 1; 18 | } 19 | 20 | # Convert POD to Markdown 21 | my $parser = Pod::Markdown->new; 22 | $parser->parse_from_file('Piece.pm'); 23 | my $pod_markdown = $parser->as_markdown; 24 | 25 | # Read the existing README.md 26 | open my $fh, '<', 'README.md' or die "Cannot open README.md: $!"; 27 | my $readme = do { local $/; <$fh> }; 28 | close $fh; 29 | 30 | my ( $before, $after ) = 31 | $readme =~ /(.*?)## Documentation\n+.*?(## Development.*?$)/s; 32 | 33 | $before .= "## Documentation\n\n"; 34 | 35 | # If still failed, create a basic structure 36 | unless ( $before && $after ) { 37 | $before = 38 | "# Time::Piece\n\n[![CI Tests](https://github.com/Dual-Life/Time-Piece/actions/workflows/ci.yml/badge.svg)](https://github.com/Dual-Life/Time-Piece/actions/workflows/ci.yml)\n\nA Perl module that replaces the standard `localtime` and `gmtime` functions with implementations that return objects.\n\n## Documentation\n\n"; 39 | $after = 40 | "\n## Development Instructions\n\n[Your development instructions here]"; 41 | } 42 | 43 | # Create the new README content 44 | my $new_readme = $before . $pod_markdown . "\n" . $after; 45 | 46 | # Write the new README 47 | open $fh, '>', 'README.md' or die "Cannot write to README.md: $!"; 48 | print $fh $new_readme; 49 | close $fh; 50 | 51 | # Stage the updated README 52 | system( 'git', 'add', 'README.md' ); 53 | 54 | print "README.md updated with latest POD from Piece.pm\n"; 55 | exit 0; 56 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI Tests 2 | 3 | on: 4 | push: 5 | branches: [ main, master, dev_test_*, feature/* ] 6 | pull_request: 7 | branches: [ main, master ] 8 | workflow_dispatch: # Allow manual triggering 9 | 10 | jobs: 11 | test: 12 | name: Test on ${{ matrix.os }} with Perl ${{ matrix.perl }} 13 | runs-on: ${{ matrix.os }} 14 | env: 15 | AUTOMATED_TESTING: 1 16 | strategy: 17 | fail-fast: false 18 | matrix: 19 | os: [ubuntu-latest, macos-latest, windows-latest, windows-2019] 20 | perl: ["5.8", "latest"] 21 | 22 | steps: 23 | - uses: actions/checkout@v4 24 | 25 | - name: Set up Perl 26 | uses: shogo82148/actions-setup-perl@v1 27 | with: 28 | perl-version: ${{ matrix.perl }} 29 | 30 | - name: Show Perl version 31 | run: perl -V 32 | 33 | - name: Install dependencies 34 | run: | 35 | cpanm --installdeps --notest . 36 | 37 | - name: Build and test 38 | run: | 39 | cpanm --test-only -v . 40 | 41 | test-bsd: 42 | name: Test on BSD 43 | runs-on: ubuntu-latest 44 | # 'false' to disable BSD tests 45 | if: true 46 | env: 47 | AUTOMATED_TESTING: 1 48 | 49 | steps: 50 | - uses: actions/checkout@v4 51 | 52 | - name: Test on BSD 53 | uses: vmactions/openbsd-vm@v1 54 | with: 55 | envs: 'AUTOMATED_TESTING' 56 | usesh: true 57 | copyback: false 58 | prepare: | 59 | perl -V 60 | run: | 61 | perl Makefile.PL 62 | make test 63 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.bs 2 | *.c 3 | *.def 4 | *.i 5 | *.o 6 | *.obj 7 | *.pdb 8 | *.xsc 9 | Makefile 10 | Makefile.old 11 | blib 12 | pm_to_blib 13 | MANIFEST.bak 14 | MYMETA.* 15 | /*.patch 16 | Time-Piece-* 17 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | Samuel Smith 2 | Matt Sergeant 3 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: "perl" 2 | sudo: false 3 | perl: 4 | - "5.8" 5 | - "5.10" 6 | - "5.12" 7 | - "5.14" 8 | - "5.16" 9 | - "5.18" 10 | - "5.20" 11 | - "5.22" 12 | - "5.24" 13 | - "5.26" 14 | - "dev" 15 | - "blead" 16 | 17 | # slows down already cached versions by 3 (33s => 1m45s) 18 | # (i.e. cache download: 9s, setup: 45s-130s) 19 | # but speeds up building the non-cached versions (5.24-*) by 2 (3m50s => 1m45s) 20 | # overall: 25min => 35min, so disable the perl cache 21 | #cache: 22 | # directories: 23 | # - /home/travis/perl5/perlbrew/ 24 | 25 | # blead and 5.6 stumble over YAML and more missing dependencies 26 | # for Devel::Cover::Report::Coveralls 27 | # cpanm does not do 5.6 28 | before_install: 29 | - mkdir /home/travis/bin || true 30 | - ln -s `which true` /home/travis/bin/cpansign 31 | - eval $(curl https://travis-perl.github.io/init) --auto 32 | install: 33 | - export AUTOMATED_TESTING=1 HARNESS_TIMER=1 AUTHOR_TESTING=0 RELEASE_TESTING=0 34 | #- cpan-install --deps # installs prereqs, including recommends 35 | #- cpan-install Test::LeakTrace 36 | - cpan-install --coverage # installs converage prereqs, if enabled 37 | 38 | before_script: 39 | - coverage-setup 40 | 41 | notifications: 42 | email: 43 | on_success: change 44 | on_failure: always 45 | 46 | matrix: 47 | fast_finish: true 48 | include: 49 | allow_failures: 50 | - env: COVERAGE=1 AUTHOR_TESTING=1 51 | - perl: "blead" 52 | 53 | # Hack to not run on tag pushes: 54 | branches: 55 | except: 56 | - /^v?[0-9]+\.[0-9]+/ 57 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Time-Piece 2 | 3 | 1.3x 2025-0x-0x 4 | - Windows support for %k, %l, %P 5 | - Set c_isdst after strptime 6 | 7 | 1.36 2025-04-06 8 | - Parsing speed up for strftime and strptime 9 | 10 | 1.35 2025-01-06 11 | - Convert tests from Test.pm to Test::More 12 | - Eliminate C++ guards 13 | - Fix minor typoes/spelling mistakes in comments/docs 14 | 15 | 1.3401 2020-04-06 16 | - Add tests for negative and large epochs 17 | - Remove %I tests from 09locales.t 18 | - Exempt more tests unless $ENV{AUTOMATED_TESTING} 19 | - Safeguards around 12-hour time notation 20 | 21 | 1.34 2020-02-27 22 | - Exempt DST tests unless $ENV{AUTOMATED_TESTING} 23 | - Add recent test files to MANIFEST (openstrike) 24 | 25 | 1.33 2018-08-18 26 | - Allow objects in overloaded methods 27 | 28 | 1.3204 2018-02-19 29 | - Fix compilation warnings. 30 | 31 | 1.3203 2017-12-12 32 | - Fix copy constructor erroneous parent modification (Thanks Grinnz!) 33 | - Fix wrong islocal of existing object in copy constructor (Thanks Grinnz!) 34 | - Switch to XSLoader 35 | 36 | 1.3202 2017-09-13 37 | - Fix AIX compile 38 | 39 | 1.3201 2017-06-22 40 | - Fix compile errors on MS 41 | - Use macro for buf sizes 42 | - Remove some compile warnings 43 | - SP off by 1 in _crt_localtime 44 | 45 | 1.32 2017-06-20 46 | - Since 1.31: 47 | - New truncate() method 48 | - Add new flags: %F, %T, %P + more 49 | - Add rudimentary locale support via use_locale() 50 | - More tests 51 | - Less bugs (hopefully) 52 | 53 | 1.31_04 2017-06-16 54 | - Tests for %F and %T 55 | - Fix wrong test count on Windows 56 | - Use sensible defaults for strptime 57 | 58 | 1.31_03 2017-06-14 59 | - Don't use localization on default 60 | - Bugs with %s in strptime fixed 61 | 62 | 1.31_02 2017-01-16 63 | - Add better localization between strftime and strptime 64 | 65 | 1.31_01 2017-01-13 66 | - Respect singular for 1 sec, min, etc. in pretty (choroba) 67 | - Add truncate() (openstrike) 68 | - Add many more tests (openstrike) 69 | - Add more compatibility to strf/strptime 70 | 71 | 1.31 2015-10-20 72 | - No Changes since 1.30_01 73 | 74 | 1.30_01 2015-09-01 75 | - Ignore some tests on non *nix platforms 76 | - fix compile warnings 77 | - Inherit from Dynaloader (fix static build issues) 78 | - Fix windows mem corruption 79 | 80 | 1.30 2015-05-16 81 | - Stable release. Overview from 1.29: 82 | - Make strftime more portable + fix %z %z 83 | - Add many more tests 84 | - Clean inheritance 85 | 86 | 1.29_05 2015-05-02 87 | - Combine multiple 'use constant' statements (saves 0.5ms at runtime) 88 | - Don't leave c_epoch undef 89 | - deprecate parse() function 90 | - More constructor tests 91 | - export() calls Exporter::export 92 | 93 | 1.29_04 2015-04-09 94 | - Clean inheritance of Exporter and DynaLoader (Thanks dolmen!) 95 | - Refactor _strftime to use localtime/gmtime to generate tm struct 96 | 97 | 1.29_03 2015-04-04 98 | - Don't mix gmtime and mktime in _strftime 99 | - Clean whitespace at end of lines 100 | - Add more tests for DST issues and also strptime parsing 101 | 102 | 1.29_02 2015-04-04 103 | - Fix handling of %Z and %z in strftime (hopefully) 104 | - Remove compile warnings for int cast 105 | 106 | 1.29_01 2015-03-30 107 | - Fix handling of %Z and %z in strftime (in progress) 108 | - Remove unused constants from Time::Seconds (Thanks Xaerxess!) 109 | - _strftime: use system mktime to better support past/future dates 110 | - Relicense strptime as BSD 2-clause http://git.io/vfNSg 111 | 112 | 1.29 2014-09-01 113 | - when pretty printing negative Time::Seconds, do not lose the "minus" 114 | 115 | 1.27 2014-01-03 116 | - portability fixes for XS changes in 1.25_01 117 | 118 | 1.26 2013-12-29 119 | - no changes since previous (trial) release 120 | 121 | 1.25_01 2013-12-16 122 | - fix compiling for WinCE, execution is untested 123 | - add a .gitignore (from Win32::API) 124 | - fix a compiler warning about unused var, and add inlining 125 | - add PERL_NO_GET_CONTEXT to XS to bring the binary into 21st century 126 | - refactor XS code to remove large sections of duplicate machine code 127 | - fix _crt_localtime to return year only once, previously 128 | _crt_localtime returned year (item #6) twice in the list 129 | 130 | 1.24 2013-12-03 131 | - add repository metadata (thanks, David Steinbrunner) 132 | 133 | 1.23 2013-09-06 134 | - add a LICENSE file (thanks, John Peacock!) 135 | - make sure Time::Seconds loads Exporter, which it relies on (thanks, 136 | GFUJI and TOKUHIROM!) 137 | - fix day of year parsing (like "%y%j") (thanks, Doug Wilson) 138 | 139 | 1.22 2013-08-12 140 | - add explicit copyright and license statements 141 | - fix encoding of .pm files and add =encoding directive 142 | 143 | 1.21 2013-07-06 144 | - fix installation target; now installs to site in v5.12 and later 145 | - make Time::Seconds match its VERSION to Time::Piece 146 | - numerous portability fixes imported from perl core distribution 147 | 148 | 1.20 149 | - Fix for alloca broke Solaris 150 | - Fixed documentation buggette about strptime 151 | - Added ->pretty() method for Time::Seconds objects 152 | - Add %s support to strptime 153 | 154 | 1.19 155 | - Fix for alloca broke FreeBSD 156 | 157 | 1.18 158 | - Fix for alloca on IRIX 159 | 160 | 1.17 161 | - Force all to use internal strptime then everyone gets %z even OSX 162 | users. 163 | - Finally figured out the timezone test failures on Win32 and fixed 164 | them. 165 | 166 | 1.16 167 | - Implement %z for the internal implementation of strptime(). 168 | Unfortunately this doesn't get picked up everywhere, so there are 169 | no tests for it (yet - patches welcome). 170 | - Fix for major bug in add_months() using negative months which were 171 | multiples of 12. Also affected add_years() with negative years. 172 | - Fix for object creation bug in get_epochs which called new from 173 | object but that wasn't supported in the new() code. 174 | - Added docs about the weakness of using epoch seconds internally 175 | and suggested alternatives. 176 | - Removed useless "use UNIVERSAL qw(isa)" line. 177 | - Fix for installing over core perl version. 178 | 179 | 1.15 180 | - Skip a test on Win32 that there's just no way of passing 181 | - Document the above failure 182 | 183 | 1.14 184 | - rework add_months() to not rely on strptime being able to parse 185 | illegal dates (Gisle Aas). 186 | - Various win32 TZ fixes from p5p core perl version 187 | 188 | 1.13 189 | - More QNX fixes (kraai@ftbfs.org) 190 | - Restore freebsd copyright on strptime. 191 | - Added add_months and add_years methods. 192 | 193 | 1.12 194 | - QNX fixes 195 | - Merge with perl core version 196 | 197 | 1.11 198 | - Skip %V test on Win32 199 | 200 | 1.10 201 | - Number of bug fixes from RT 202 | - (maintenance by Ricardo SIGNES) 203 | - avoid warning in _mktime (bug #19677) 204 | 205 | 1.09 206 | - (patches from Ricardo SIGNES) 207 | - Tests largely moved to Test::More (from Test.pm) 208 | - Time::Piece should now be safely subclassable 209 | 210 | 1.08 211 | - A number of fixes for strptime 212 | - Fixed docs wrt Time::Object references 213 | - Fixed docs wrt ->month returning short month name 214 | - Added ->fullmonth and ->fullday to get full day names 215 | 216 | 1.07 217 | - Fix for ->week method 218 | 219 | 1.06 220 | - Fix for Solaris pre-2.8 221 | - Compilation checked on: 222 | sparc solaris 2.7 223 | sparc solaris 2.8 224 | i686 linux 225 | ia64 linux 226 | pa-risc1.1 hpux 10.20 227 | pa-risc2.0 hpux 11.00 228 | alpha dec_osf 4.0 229 | - Fixes for Win32 (Randy Kobes) 230 | 231 | 1.05 232 | - Fix for Solaris (again) 233 | 234 | 1.04 235 | - Slight fixes to strptime for Solaris and MacOSX 236 | - Bug in strptime with daylight savings fixed. 237 | 238 | 1.03 239 | - Updated MJD stuff (Tim Jeness) 240 | - Added compare tests 241 | - Ported test suite to Test.pm finally 242 | 243 | 1.01 244 | - Added cs_sec and cs_mon to Time::Seconds so that 245 | old Time::Object installs still work (except for add()) 246 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2001, Larry Wall. 2 | 3 | strptime copied from freebsd with the following copyright: 4 | 5 | Copyright (c) 1994 Powerdog Industries. All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer 14 | in the documentation and/or other materials provided with the 15 | distribution. 16 | 3. All advertising materials mentioning features or use of this 17 | software must display the following acknowledgement: 18 | This product includes software developed by Powerdog Industries. 19 | 4. The name of Powerdog Industries may not be used to endorse or 20 | promote products derived from this software without specific prior 21 | written permission. 22 | 23 | THIS SOFTWARE IS PROVIDED BY POWERDOG INDUSTRIES ``AS IS'' AND ANY 24 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 25 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 26 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE POWERDOG INDUSTRIES BE 27 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 28 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 29 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 30 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 31 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 32 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 33 | EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 34 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Changes 2 | LICENSE 3 | Makefile.PL 4 | MANIFEST This list of files 5 | Piece.pm 6 | Piece.xs 7 | README.md 8 | reverse_deps.txt 9 | Seconds.pm 10 | t/01base.t 11 | t/02core.t 12 | t/02core_dst.t 13 | t/03compare.t 14 | t/04mjd.t 15 | t/05overload.t 16 | t/06large.t 17 | t/06subclass.t 18 | t/07arith.t 19 | t/08truncate.t 20 | t/09locales.t 21 | t/10overload.t 22 | t/99legacy.t 23 | t/lib/Time/Piece/Twin.pm 24 | TODO 25 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use ExtUtils::MakeMaker; 2 | 3 | require 5.006; 4 | 5 | WriteMakefile( 6 | 'NAME' => 'Time::Piece', 7 | 'VERSION_FROM' => 'Piece.pm', # finds $VERSION 8 | 'AUTHOR' => 'Matt Sergeant', 9 | 'ABSTRACT_FROM' => 'Piece.pm', 10 | 'INSTALLDIRS' => ( ($] >= 5.009005 and $] < 5.011) ? 'perl' : 'site'), 11 | #'CCFLAGS' => '-Wall -Wextra -Wconversion', 12 | 'PREREQ_PM' => { Exporter => '5.57', 'Scalar::Util' => 0 }, 13 | (eval { ExtUtils::MakeMaker->VERSION(6.21) } ? (LICENSE => 'perl') : ()), 14 | 'META_MERGE' => { 15 | 'resources' => { 16 | 'repository' => 'https://github.com/Dual-Life/Time-Piece', 17 | }, 18 | }, 19 | ); 20 | -------------------------------------------------------------------------------- /Piece.pm: -------------------------------------------------------------------------------- 1 | package Time::Piece; 2 | 3 | use strict; 4 | 5 | use XSLoader (); 6 | use Time::Seconds; 7 | use Carp; 8 | use Time::Local; 9 | use Scalar::Util qw/ blessed /; 10 | 11 | use Exporter (); 12 | 13 | our @EXPORT = qw( 14 | localtime 15 | gmtime 16 | ); 17 | 18 | our %EXPORT_TAGS = ( 19 | ':override' => 'internal', 20 | ); 21 | 22 | our $VERSION = '1.36'; 23 | 24 | XSLoader::load( 'Time::Piece', $VERSION ); 25 | 26 | my $DATE_SEP = '-'; 27 | my $TIME_SEP = ':'; 28 | my @MON_LIST = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); 29 | my @FULLMON_LIST = qw(January February March April May June July 30 | August September October November December); 31 | my @DAY_LIST = qw(Sun Mon Tue Wed Thu Fri Sat); 32 | my @FULLDAY_LIST = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday); 33 | my $IS_WIN32 = ($^O =~ /Win32/); 34 | my $IS_LINUX = ($^O =~ /linux/i); 35 | 36 | my $LOCALE; 37 | 38 | use constant { 39 | 'c_sec' => 0, 40 | 'c_min' => 1, 41 | 'c_hour' => 2, 42 | 'c_mday' => 3, 43 | 'c_mon' => 4, 44 | 'c_year' => 5, 45 | 'c_wday' => 6, 46 | 'c_yday' => 7, 47 | 'c_isdst' => 8, 48 | 'c_epoch' => 9, 49 | 'c_islocal' => 10, 50 | }; 51 | 52 | sub localtime { 53 | unshift @_, __PACKAGE__ unless eval { $_[0]->isa('Time::Piece') }; 54 | my $class = shift; 55 | my $time = shift; 56 | $time = time if (!defined $time); 57 | $class->_mktime($time, 1); 58 | } 59 | 60 | sub gmtime { 61 | unshift @_, __PACKAGE__ unless eval { $_[0]->isa('Time::Piece') }; 62 | my $class = shift; 63 | my $time = shift; 64 | $time = time if (!defined $time); 65 | $class->_mktime($time, 0); 66 | } 67 | 68 | 69 | # Check if the supplied param is either a normal array (as returned from 70 | # localtime in list context) or a Time::Piece-like wrapper around one. 71 | # 72 | # We need to differentiate between an array ref that we can interrogate and 73 | # other blessed objects (like overloaded values). 74 | sub _is_time_struct { 75 | return 1 if ref($_[1]) eq 'ARRAY'; 76 | return 1 if blessed($_[1]) && $_[1]->isa('Time::Piece'); 77 | 78 | return 0; 79 | } 80 | 81 | 82 | sub new { 83 | my $class = shift; 84 | my ($time) = @_; 85 | 86 | my $self; 87 | 88 | if ($class->_is_time_struct($time)) { 89 | $self = $time->[c_islocal] ? $class->localtime($time) : $class->gmtime($time); 90 | } 91 | elsif (defined($time)) { 92 | $self = $class->localtime($time); 93 | } 94 | elsif (ref($class) && $class->isa(__PACKAGE__)) { 95 | $self = $class->_mktime($class->epoch, $class->[c_islocal]); 96 | } 97 | else { 98 | $self = $class->localtime(); 99 | } 100 | 101 | return bless $self, ref($class) || $class; 102 | } 103 | 104 | sub parse { 105 | my $proto = shift; 106 | my $class = ref($proto) || $proto; 107 | my @components; 108 | 109 | warnings::warnif("deprecated", 110 | "parse() is deprecated, use strptime() instead."); 111 | 112 | if (@_ > 1) { 113 | @components = @_; 114 | } 115 | else { 116 | @components = shift =~ /(\d+)$DATE_SEP(\d+)$DATE_SEP(\d+)(?:(?:T|\s+)(\d+)$TIME_SEP(\d+)(?:$TIME_SEP(\d+)))/; 117 | @components = reverse(@components[0..5]); 118 | } 119 | return $class->new( timelocal(@components )); 120 | } 121 | 122 | sub _mktime { 123 | my ($class, $time, $islocal) = @_; 124 | 125 | $class = blessed($class) || $class; 126 | 127 | if ($class->_is_time_struct($time)) { 128 | return wantarray ? @$time : bless [@$time[0..8], undef, $islocal], $class; 129 | } 130 | _tzset(); 131 | my @time = $islocal ? 132 | CORE::localtime($time) 133 | : 134 | CORE::gmtime($time); 135 | wantarray ? @time : bless [@time, $time, $islocal], $class; 136 | } 137 | 138 | my %_special_exports = ( 139 | localtime => sub { my $c = $_[0]; sub { $c->localtime(@_) } }, 140 | gmtime => sub { my $c = $_[0]; sub { $c->gmtime(@_) } }, 141 | ); 142 | 143 | sub export { 144 | my ($class, $to, @methods) = @_; 145 | for my $method (@methods) { 146 | if (exists $_special_exports{$method}) { 147 | no strict 'refs'; 148 | no warnings 'redefine'; 149 | *{$to . "::$method"} = $_special_exports{$method}->($class); 150 | } else { 151 | $class->Exporter::export($to, $method); 152 | } 153 | } 154 | } 155 | 156 | sub import { 157 | # replace CORE::GLOBAL localtime and gmtime if passed :override 158 | my $class = shift; 159 | my %params; 160 | map($params{$_}++,@_,@EXPORT); 161 | if (delete $params{':override'}) { 162 | $class->export('CORE::GLOBAL', keys %params); 163 | } 164 | else { 165 | $class->export(scalar caller, keys %params); 166 | } 167 | } 168 | 169 | ## Methods ## 170 | 171 | sub sec { 172 | my $time = shift; 173 | $time->[c_sec]; 174 | } 175 | 176 | *second = \&sec; 177 | 178 | sub min { 179 | my $time = shift; 180 | $time->[c_min]; 181 | } 182 | 183 | *minute = \&min; 184 | 185 | sub hour { 186 | my $time = shift; 187 | $time->[c_hour]; 188 | } 189 | 190 | sub mday { 191 | my $time = shift; 192 | $time->[c_mday]; 193 | } 194 | 195 | *day_of_month = \&mday; 196 | 197 | sub mon { 198 | my $time = shift; 199 | $time->[c_mon] + 1; 200 | } 201 | 202 | sub _mon { 203 | my $time = shift; 204 | $time->[c_mon]; 205 | } 206 | 207 | sub month { 208 | my $time = shift; 209 | if (@_) { 210 | return $_[$time->[c_mon]]; 211 | } 212 | elsif (@MON_LIST) { 213 | return $MON_LIST[$time->[c_mon]]; 214 | } 215 | else { 216 | return $time->strftime('%b'); 217 | } 218 | } 219 | 220 | *monname = \&month; 221 | 222 | sub fullmonth { 223 | my $time = shift; 224 | if (@_) { 225 | return $_[$time->[c_mon]]; 226 | } 227 | elsif (@FULLMON_LIST) { 228 | return $FULLMON_LIST[$time->[c_mon]]; 229 | } 230 | else { 231 | return $time->strftime('%B'); 232 | } 233 | } 234 | 235 | sub year { 236 | my $time = shift; 237 | $time->[c_year] + 1900; 238 | } 239 | 240 | sub _year { 241 | my $time = shift; 242 | $time->[c_year]; 243 | } 244 | 245 | sub yy { 246 | my $time = shift; 247 | my $res = $time->[c_year] % 100; 248 | return $res > 9 ? $res : "0$res"; 249 | } 250 | 251 | sub wday { 252 | my $time = shift; 253 | $time->[c_wday] + 1; 254 | } 255 | 256 | sub _wday { 257 | my $time = shift; 258 | $time->[c_wday]; 259 | } 260 | 261 | *day_of_week = \&_wday; 262 | 263 | sub wdayname { 264 | my $time = shift; 265 | if (@_) { 266 | return $_[$time->[c_wday]]; 267 | } 268 | elsif (@DAY_LIST) { 269 | return $DAY_LIST[$time->[c_wday]]; 270 | } 271 | else { 272 | return $time->strftime('%a'); 273 | } 274 | } 275 | 276 | *day = \&wdayname; 277 | 278 | sub fullday { 279 | my $time = shift; 280 | if (@_) { 281 | return $_[$time->[c_wday]]; 282 | } 283 | elsif (@FULLDAY_LIST) { 284 | return $FULLDAY_LIST[$time->[c_wday]]; 285 | } 286 | else { 287 | return $time->strftime('%A'); 288 | } 289 | } 290 | 291 | sub yday { 292 | my $time = shift; 293 | $time->[c_yday]; 294 | } 295 | 296 | *day_of_year = \&yday; 297 | 298 | sub isdst { 299 | my $time = shift; 300 | return 0 unless $time->[c_islocal]; 301 | # Calculate dst based on current TZ 302 | if ( $time->[c_isdst] == -1 ) { 303 | $time->[c_isdst] = ( CORE::localtime( $time->epoch ) )[-1]; 304 | } 305 | return $time->[c_isdst]; 306 | } 307 | 308 | *daylight_savings = \&isdst; 309 | 310 | # Thanks to Tony Olekshy for this algorithm 311 | sub tzoffset { 312 | my $time = shift; 313 | 314 | return Time::Seconds->new(0) unless $time->[c_islocal]; 315 | 316 | my $epoch = $time->epoch; 317 | 318 | my $j = sub { 319 | 320 | my ($s,$n,$h,$d,$m,$y) = @_; $m += 1; $y += 1900; 321 | 322 | $time->_jd($y, $m, $d, $h, $n, $s); 323 | 324 | }; 325 | 326 | # Compute floating offset in hours. 327 | # 328 | # Note use of crt methods so the tz is properly set... 329 | # See: http://perlmonks.org/?node_id=820347 330 | my $delta = 24 * ($j->(_crt_localtime($epoch)) - $j->(_crt_gmtime($epoch))); 331 | 332 | # Return value in seconds rounded to nearest minute. 333 | return Time::Seconds->new( int($delta * 60 + ($delta >= 0 ? 0.5 : -0.5)) * 60 ); 334 | } 335 | 336 | sub epoch { 337 | my $time = shift; 338 | if (defined($time->[c_epoch])) { 339 | return $time->[c_epoch]; 340 | } 341 | else { 342 | my $epoch = $time->[c_islocal] ? 343 | timelocal(@{$time}[c_sec .. c_mon], $time->[c_year]+1900) 344 | : 345 | timegm(@{$time}[c_sec .. c_mon], $time->[c_year]+1900); 346 | $time->[c_epoch] = $epoch; 347 | return $epoch; 348 | } 349 | } 350 | 351 | sub hms { 352 | my $time = shift; 353 | my $sep = @_ ? shift(@_) : $TIME_SEP; 354 | sprintf("%02d$sep%02d$sep%02d", $time->[c_hour], $time->[c_min], $time->[c_sec]); 355 | } 356 | 357 | *time = \&hms; 358 | 359 | sub ymd { 360 | my $time = shift; 361 | my $sep = @_ ? shift(@_) : $DATE_SEP; 362 | sprintf("%d$sep%02d$sep%02d", $time->year, $time->mon, $time->[c_mday]); 363 | } 364 | 365 | *date = \&ymd; 366 | 367 | sub mdy { 368 | my $time = shift; 369 | my $sep = @_ ? shift(@_) : $DATE_SEP; 370 | sprintf("%02d$sep%02d$sep%d", $time->mon, $time->[c_mday], $time->year); 371 | } 372 | 373 | sub dmy { 374 | my $time = shift; 375 | my $sep = @_ ? shift(@_) : $DATE_SEP; 376 | sprintf("%02d$sep%02d$sep%d", $time->[c_mday], $time->mon, $time->year); 377 | } 378 | 379 | sub datetime { 380 | my $time = shift; 381 | my %seps = (date => $DATE_SEP, T => 'T', time => $TIME_SEP, @_); 382 | return join($seps{T}, $time->date($seps{date}), $time->time($seps{time})); 383 | } 384 | 385 | 386 | 387 | # Julian Day is always calculated for UT regardless 388 | # of local time 389 | sub julian_day { 390 | my $time = shift; 391 | # Correct for localtime 392 | $time = $time->gmtime( $time->epoch ) if $time->[c_islocal]; 393 | 394 | # Calculate the Julian day itself 395 | my $jd = $time->_jd( $time->year, $time->mon, $time->mday, 396 | $time->hour, $time->min, $time->sec); 397 | 398 | return $jd; 399 | } 400 | 401 | # MJD is defined as JD - 2400000.5 days 402 | sub mjd { 403 | return shift->julian_day - 2_400_000.5; 404 | } 405 | 406 | # Internal calculation of Julian date. Needed here so that 407 | # both tzoffset and mjd/jd methods can share the code 408 | # Algorithm from Hatcher 1984 (QJRAS 25, 53-55), and 409 | # Hughes et al, 1989, MNRAS, 238, 15 410 | # See: http://adsabs.harvard.edu/cgi-bin/nph-bib_query?bibcode=1989MNRAS.238.1529H&db_key=AST 411 | # for more details 412 | 413 | sub _jd { 414 | my $self = shift; 415 | my ($y, $m, $d, $h, $n, $s) = @_; 416 | 417 | # Adjust input parameters according to the month 418 | $y = ( $m > 2 ? $y : $y - 1); 419 | $m = ( $m > 2 ? $m - 3 : $m + 9); 420 | 421 | # Calculate the Julian Date (assuming Julian calendar) 422 | my $J = int( 365.25 *( $y + 4712) ) 423 | + int( (30.6 * $m) + 0.5) 424 | + 59 425 | + $d 426 | - 0.5; 427 | 428 | # Calculate the Gregorian Correction (since we have Gregorian dates) 429 | my $G = 38 - int( 0.75 * int(49+($y/100))); 430 | 431 | # Calculate the actual Julian Date 432 | my $JD = $J + $G; 433 | 434 | # Modify to include hours/mins/secs in floating portion. 435 | return $JD + ($h + ($n + $s / 60) / 60) / 24; 436 | } 437 | 438 | sub week { 439 | my $self = shift; 440 | 441 | my $J = $self->julian_day; 442 | # Julian day is independent of time zone so add on tzoffset 443 | # if we are using local time here since we want the week day 444 | # to reflect the local time rather than UTC 445 | $J += ($self->tzoffset/(24*3600)) if $self->[c_islocal]; 446 | 447 | # Now that we have the Julian day including fractions 448 | # convert it to an integer Julian Day Number using nearest 449 | # int (since the day changes at midday we convert all Julian 450 | # dates to following midnight). 451 | $J = int($J+0.5); 452 | 453 | use integer; 454 | my $d4 = ((($J + 31741 - ($J % 7)) % 146097) % 36524) % 1461; 455 | my $L = $d4 / 1460; 456 | my $d1 = (($d4 - $L) % 365) + $L; 457 | return $d1 / 7 + 1; 458 | } 459 | 460 | sub _is_leap_year { 461 | my $year = shift; 462 | return (($year %4 == 0) && !($year % 100 == 0)) || ($year % 400 == 0) 463 | ? 1 : 0; 464 | } 465 | 466 | sub is_leap_year { 467 | my $time = shift; 468 | my $year = $time->year; 469 | return _is_leap_year($year); 470 | } 471 | 472 | my @MON_LAST = qw(31 28 31 30 31 30 31 31 30 31 30 31); 473 | 474 | sub month_last_day { 475 | my $time = shift; 476 | my $year = $time->year; 477 | my $_mon = $time->_mon; 478 | return $MON_LAST[$_mon] + ($_mon == 1 ? _is_leap_year($year) : 0); 479 | } 480 | 481 | my $strftime_trans_map = { 482 | 'c' => sub { 483 | my ( $format ) = @_; 484 | if($LOCALE->{PM} && $LOCALE->{AM}){ 485 | $format =~ s/%c/%a %d %b %Y %I:%M:%S %p/; 486 | } 487 | else{ 488 | $format =~ s/%c/%a %d %b %Y %H:%M:%S/; 489 | } 490 | return $format; 491 | }, 492 | 'e' => sub { 493 | my ( $format, $time ) = @_; 494 | my $day = sprintf( "%2d", $time->[c_mday] ); 495 | $format =~ s/%e/$day/ if $IS_WIN32; 496 | return $format; 497 | }, 498 | 'D' => sub { 499 | my ( $format ) = @_; 500 | $format =~ s/%D/%m\/%d\/%y/; 501 | return $format; 502 | }, 503 | 'F' => sub { 504 | my ( $format ) = @_; 505 | $format =~ s/%F/%Y-%m-%d/; 506 | return $format; 507 | }, 508 | 'k' => sub { 509 | my ( $format, $time ) = @_; 510 | my $hr = sprintf( "%2d", $time->[c_hour] ); 511 | $format =~ s/%k/$hr/ if $IS_WIN32; 512 | return $format; 513 | }, 514 | 'l' => sub { 515 | my ( $format, $time ) = @_; 516 | if ($IS_WIN32) { 517 | my $hr = $time->[c_hour] > 12 ? $time->[c_hour] - 12 : $time->[c_hour]; 518 | $hr = sprintf( "%2d", $hr ); 519 | $format =~ s/%l/$hr/ if $IS_WIN32; 520 | } 521 | return $format; 522 | }, 523 | 'P' => sub { 524 | my ( $format ) = @_; 525 | # %P seems to be linux only 526 | $format =~ s/%P/%p/ unless $IS_LINUX; 527 | return $format; 528 | }, 529 | 'r' => sub { 530 | my ( $format ) = @_; 531 | if($LOCALE->{PM} && $LOCALE->{AM}){ 532 | $format =~ s/%r/%I:%M:%S %p/; 533 | } 534 | else{ 535 | $format =~ s/%r/%H:%M:%S/; 536 | } 537 | return $format; 538 | }, 539 | 'R' => sub { 540 | my ( $format ) = @_; 541 | $format =~ s/%R/%H:%M/; 542 | return $format; 543 | }, 544 | 's' => sub { 545 | #%s not portable if time parts are from gmtime since %s will 546 | #cause a call to native mktime (and thus uses local TZ) 547 | my ( $format, $time ) = @_; 548 | my $e = $time->epoch(); 549 | $format =~ s/%s/$e/; 550 | return $format; 551 | }, 552 | 'T' => sub { 553 | my ( $format ) = @_; 554 | $format =~ s/%T/%H:%M:%S/ if $IS_WIN32; 555 | return $format; 556 | }, 557 | 'u' => sub { 558 | my ( $format ) = @_; 559 | $format =~ s/%u/%w/ if $IS_WIN32; 560 | return $format; 561 | }, 562 | 'V' => sub { 563 | my ( $format, $time ) = @_; 564 | my $week = sprintf( "%02d", $time->week() ); 565 | $format =~ s/%V/$week/ if $IS_WIN32; 566 | return $format; 567 | }, 568 | 'x' => sub { 569 | my ( $format ) = @_; 570 | $format =~ s/%x/%a %d %b %Y/; 571 | return $format; 572 | }, 573 | 'X' => sub { 574 | my ( $format ) = @_; 575 | if($LOCALE->{PM} && $LOCALE->{AM}){ 576 | $format =~ s/%X/%I:%M:%S %p/; 577 | } 578 | else{ 579 | $format =~ s/%X/%H:%M:%S/; 580 | } 581 | return $format; 582 | }, 583 | 'z' => sub { #%[zZ] not portable if time parts are from gmtime 584 | my ( $format, $time ) = @_; 585 | $format =~ s/%z/+0000/ if not $time->[c_islocal]; 586 | return $format; 587 | }, 588 | 'Z' => sub { 589 | my ( $format, $time ) = @_; 590 | $format =~ s/%Z/UTC/ if not $time->[c_islocal]; 591 | return $format; 592 | }, 593 | }; 594 | 595 | sub strftime { 596 | my $time = shift; 597 | my $format = @_ ? shift(@_) : '%a, %d %b %Y %H:%M:%S %Z'; 598 | $format = _translate_format($format, $strftime_trans_map, $time); 599 | 600 | return $format unless $format =~ /%/; #if translate removes everything 601 | 602 | return _strftime($format, $time->epoch, $time->[c_islocal]); 603 | } 604 | 605 | sub strptime { 606 | my $time = shift; 607 | my $string = shift; 608 | my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S %Z"; 609 | my $islocal = (ref($time) ? $time->[c_islocal] : 0); 610 | my $locales = $LOCALE || &Time::Piece::_default_locale(); 611 | 612 | my @vals = _strptime($string, $format, $islocal, $locales); 613 | # warn(sprintf("got vals: %d-%d-%d %d:%d:%d\n", reverse(@vals[c_sec..c_year]))); 614 | return scalar $time->_mktime(\@vals, $islocal); 615 | } 616 | 617 | sub day_list { 618 | shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method 619 | my @old = @DAY_LIST; 620 | if (@_) { 621 | @DAY_LIST = @_; 622 | &Time::Piece::_default_locale(); 623 | } 624 | return @old; 625 | } 626 | 627 | sub mon_list { 628 | shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method 629 | my @old = @MON_LIST; 630 | if (@_) { 631 | @MON_LIST = @_; 632 | &Time::Piece::_default_locale(); 633 | } 634 | return @old; 635 | } 636 | 637 | sub time_separator { 638 | shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); 639 | my $old = $TIME_SEP; 640 | if (@_) { 641 | $TIME_SEP = $_[0]; 642 | } 643 | return $old; 644 | } 645 | 646 | sub date_separator { 647 | shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); 648 | my $old = $DATE_SEP; 649 | if (@_) { 650 | $DATE_SEP = $_[0]; 651 | } 652 | return $old; 653 | } 654 | 655 | use overload '""' => \&cdate, 656 | 'cmp' => \&str_compare, 657 | 'fallback' => undef; 658 | 659 | sub cdate { 660 | my $time = shift; 661 | if ($time->[c_islocal]) { 662 | return scalar(CORE::localtime($time->epoch)); 663 | } 664 | else { 665 | return scalar(CORE::gmtime($time->epoch)); 666 | } 667 | } 668 | 669 | sub str_compare { 670 | my ($lhs, $rhs, $reverse) = @_; 671 | 672 | if (blessed($rhs) && $rhs->isa('Time::Piece')) { 673 | $rhs = "$rhs"; 674 | } 675 | return $reverse ? $rhs cmp $lhs->cdate : $lhs->cdate cmp $rhs; 676 | } 677 | 678 | use overload 679 | '-' => \&subtract, 680 | '+' => \&add; 681 | 682 | sub subtract { 683 | my $time = shift; 684 | my $rhs = shift; 685 | 686 | if (shift) 687 | { 688 | # SWAPED is set (so someone tried an expression like NOTDATE - DATE). 689 | # Imitate Perl's standard behavior and return the result as if the 690 | # string $time resolves to was subtracted from NOTDATE. This way, 691 | # classes which override this one and which have a stringify function 692 | # that resolves to something that looks more like a number don't need 693 | # to override this function. 694 | return $rhs - "$time"; 695 | } 696 | 697 | #TODO: handle math with objects where one is DST and the other isn't 698 | #so either convert both to a gmtime object, subtract and then convert to localtime object (would have to add ->to_gmt and ->to_local methods) 699 | #or check the tzoffset on each object, if they are different, add in the differing seconds. 700 | if (blessed($rhs) && $rhs->isa('Time::Piece')) { 701 | return Time::Seconds->new($time->epoch - $rhs->epoch); 702 | } 703 | else { 704 | # rhs is seconds. 705 | return $time->_mktime(($time->epoch - $rhs), $time->[c_islocal]); 706 | } 707 | } 708 | 709 | sub add { 710 | my $time = shift; 711 | my $rhs = shift; 712 | 713 | return $time->_mktime(($time->epoch + $rhs), $time->[c_islocal]); 714 | } 715 | 716 | use overload 717 | '<=>' => \&compare; 718 | 719 | sub get_epochs { 720 | my ($lhs, $rhs, $reverse) = @_; 721 | unless (blessed($rhs) && $rhs->isa('Time::Piece')) { 722 | $rhs = $lhs->new($rhs); 723 | } 724 | if ($reverse) { 725 | return $rhs->epoch, $lhs->epoch; 726 | } 727 | return $lhs->epoch, $rhs->epoch; 728 | } 729 | 730 | sub compare { 731 | my ($lhs, $rhs) = get_epochs(@_); 732 | return $lhs <=> $rhs; 733 | } 734 | 735 | sub add_months { 736 | my ($time, $num_months) = @_; 737 | 738 | croak("add_months requires a number of months") unless defined($num_months); 739 | 740 | my $final_month = $time->_mon + $num_months; 741 | my $num_years = 0; 742 | if ($final_month > 11 || $final_month < 0) { 743 | # these two ops required because we have no POSIX::floor and don't 744 | # want to load POSIX.pm 745 | if ($final_month < 0 && $final_month % 12 == 0) { 746 | $num_years = int($final_month / 12) + 1; 747 | } 748 | else { 749 | $num_years = int($final_month / 12); 750 | } 751 | $num_years-- if ($final_month < 0); 752 | 753 | $final_month = $final_month % 12; 754 | } 755 | 756 | my @vals = _mini_mktime($time->sec, $time->min, $time->hour, 757 | $time->mday, $final_month, $time->year - 1900 + $num_years); 758 | # warn(sprintf("got %d vals: %d-%d-%d %d:%d:%d [%d]\n", scalar(@vals), reverse(@vals), $time->[c_islocal])); 759 | return scalar $time->_mktime(\@vals, $time->[c_islocal]); 760 | } 761 | 762 | sub add_years { 763 | my ($time, $years) = @_; 764 | $time->add_months($years * 12); 765 | } 766 | 767 | sub truncate { 768 | my ($time, %params) = @_; 769 | return $time unless exists $params{to}; 770 | #if ($params{to} eq 'week') { return $time->_truncate_week; } 771 | my %units = ( 772 | second => 0, 773 | minute => 1, 774 | hour => 2, 775 | day => 3, 776 | month => 4, 777 | quarter => 5, 778 | year => 5 779 | ); 780 | my $to = $units{$params{to}}; 781 | croak "Invalid value of 'to' parameter: $params{to}" unless defined $to; 782 | my $start_month = 0; 783 | if ($params{to} eq 'quarter') { 784 | $start_month = int( $time->_mon / 3 ) * 3; 785 | } 786 | my @down_to = (0, 0, 0, 1, $start_month, $time->year); 787 | return $time->_mktime([@down_to[0..$to-1], @$time[$to..c_isdst]], 788 | $time->[c_islocal]); 789 | } 790 | 791 | my $_format_cache = {}; 792 | 793 | #Given a format and a translate map, replace format flags in 794 | #accordance with the logic from the translation map subroutines 795 | sub _translate_format { 796 | my ( $format, $trans_map, $time ) = @_; 797 | my $bad_flags = $IS_WIN32 ? qr/%([eklsVzZ])/ : qr/%([szZ])/; 798 | my $can_cache = ($format !~ $bad_flags) ? 1 : 0; 799 | 800 | if ( $can_cache && exists $_format_cache->{$format} ){ 801 | return $_format_cache->{$format}; 802 | } 803 | 804 | $format =~ s/%%/\e\e/g; #escape the escape 805 | my $lexer = _build_format_lexer($format); 806 | 807 | while(my $flag = $lexer->() ){ 808 | next unless exists $trans_map->{$flag}; 809 | $format = $trans_map->{$flag}($format, $time); 810 | } 811 | 812 | $format =~ s/\e\e/%%/g; 813 | $_format_cache->{$_[0]} = $format if $can_cache; 814 | 815 | return $format; 816 | } 817 | 818 | sub _build_format_lexer { 819 | my $format = shift(); 820 | 821 | #Higher Order Perl p.359 (or thereabouts) 822 | return sub { 823 | LABEL: { 824 | return $1 if $format =~ m/\G%([a-zA-Z])/gc; #return single char flags 825 | 826 | redo LABEL if $format =~ m/\G(.)/gc; 827 | return; #return at empty string 828 | } 829 | }; 830 | } 831 | 832 | sub use_locale { 833 | #get locale month/day names from posix strftime (from Piece.xs) 834 | my $locales = _get_localization(); 835 | 836 | #If AM and PM are the same, set both to '' 837 | if ( !$locales->{PM} 838 | || !$locales->{AM} 839 | || ( $locales->{PM} eq $locales->{AM} ) ) 840 | { 841 | $locales->{PM} = ''; 842 | $locales->{AM} = ''; 843 | } 844 | 845 | if ( !$locales->{pm} 846 | || !$locales->{am} 847 | || ( $locales->{pm} eq $locales->{am} ) ) 848 | { 849 | $locales->{pm} = lc $locales->{PM}; 850 | $locales->{am} = lc $locales->{AM}; 851 | } 852 | 853 | #should probably figure out how to get a 854 | #region specific format for %c someday 855 | $locales->{c_fmt} = ''; 856 | 857 | #Set globals. If anything is 858 | #weird just use original 859 | if( @{$locales->{weekday}} < 7 ){ 860 | @{$locales->{weekday}} = @FULLDAY_LIST; 861 | } 862 | else { 863 | @FULLDAY_LIST = @{$locales->{weekday}}; 864 | } 865 | 866 | if( @{$locales->{wday}} < 7 ){ 867 | @{$locales->{wday}} = @DAY_LIST; 868 | } 869 | else { 870 | @DAY_LIST = @{$locales->{wday}}; 871 | } 872 | 873 | if( @{$locales->{month}} < 12 ){ 874 | @{$locales->{month}} = @FULLMON_LIST; 875 | }else { 876 | @FULLMON_LIST = @{$locales->{month}}; 877 | } 878 | 879 | if( @{$locales->{mon}} < 12 ){ 880 | @{$locales->{mon}} = @MON_LIST; 881 | } 882 | else{ 883 | @MON_LIST= @{$locales->{mon}}; 884 | } 885 | 886 | $LOCALE = $locales; 887 | } 888 | 889 | #$Time::Piece::LOCALE is used by strptime and thus needs to be 890 | #in sync with what ever users change to via day_list() and mon_list(). 891 | #Should probably deprecate this use of global state, but oh well... 892 | sub _default_locale { 893 | my $locales = {}; 894 | 895 | @{ $locales->{weekday} } = @FULLDAY_LIST; 896 | @{ $locales->{wday} } = @DAY_LIST; 897 | @{ $locales->{month} } = @FULLMON_LIST; 898 | @{ $locales->{mon} } = @MON_LIST; 899 | $locales->{alt_month} = $locales->{month}; 900 | 901 | $locales->{PM} = 'PM'; 902 | $locales->{AM} = 'AM'; 903 | $locales->{pm} = 'pm'; 904 | $locales->{am} = 'am'; 905 | $locales->{c_fmt} = ''; 906 | 907 | $LOCALE = $locales; 908 | } 909 | 910 | sub _locale { 911 | return $LOCALE; 912 | } 913 | 914 | 915 | 1; 916 | __END__ 917 | 918 | =head1 NAME 919 | 920 | Time::Piece - Object Oriented time objects 921 | 922 | =head1 SYNOPSIS 923 | 924 | use Time::Piece; 925 | 926 | my $t = localtime; 927 | print "Time is $t\n"; 928 | print "Year is ", $t->year, "\n"; 929 | 930 | =head1 DESCRIPTION 931 | 932 | This module replaces the standard C and C functions with 933 | implementations that return objects. It does so in a backwards 934 | compatible manner, so that using localtime/gmtime in the way documented 935 | in perlfunc will still return what you expect. 936 | 937 | The module actually implements most of an interface described by 938 | Larry Wall on the perl5-porters mailing list here: 939 | L 940 | 941 | =head1 USAGE 942 | 943 | After importing this module, when you use localtime or gmtime in a scalar 944 | context, rather than getting an ordinary scalar string representing the 945 | date and time, you get a Time::Piece object, whose stringification happens 946 | to produce the same effect as the localtime and gmtime functions. There is 947 | also a new() constructor provided, which is the same as localtime(), except 948 | when passed a Time::Piece object, in which case it's a copy constructor. The 949 | following methods are available on the object: 950 | 951 | $t->sec # also available as $t->second 952 | $t->min # also available as $t->minute 953 | $t->hour # 24 hour 954 | $t->mday # also available as $t->day_of_month 955 | $t->mon # 1 = January 956 | $t->_mon # 0 = January 957 | $t->monname # Feb 958 | $t->month # same as $t->monname 959 | $t->fullmonth # February 960 | $t->year # based at 0 (year 0 AD is, of course 1 BC) 961 | $t->_year # year minus 1900 962 | $t->yy # 2 digit year 963 | $t->wday # 1 = Sunday 964 | $t->_wday # 0 = Sunday 965 | $t->day_of_week # 0 = Sunday 966 | $t->wdayname # Tue 967 | $t->day # same as wdayname 968 | $t->fullday # Tuesday 969 | $t->yday # also available as $t->day_of_year, 0 = Jan 01 970 | $t->isdst # also available as $t->daylight_savings 971 | 972 | $t->hms # 12:34:56 973 | $t->hms(".") # 12.34.56 974 | $t->time # same as $t->hms 975 | 976 | $t->ymd # 2000-02-29 977 | $t->date # same as $t->ymd 978 | $t->mdy # 02-29-2000 979 | $t->mdy("/") # 02/29/2000 980 | $t->dmy # 29-02-2000 981 | $t->dmy(".") # 29.02.2000 982 | $t->datetime # 2000-02-29T12:34:56 (ISO 8601) 983 | $t->cdate # Tue Feb 29 12:34:56 2000 984 | "$t" # same as $t->cdate 985 | 986 | $t->epoch # seconds since the epoch 987 | $t->tzoffset # timezone offset in a Time::Seconds object 988 | 989 | $t->julian_day # number of days since Julian period began 990 | $t->mjd # modified Julian date (JD-2400000.5 days) 991 | 992 | $t->week # week number (ISO 8601) 993 | 994 | $t->is_leap_year # true if it's a leap year 995 | $t->month_last_day # 28-31 996 | 997 | $t->time_separator($s) # set the default separator (default ":") 998 | $t->date_separator($s) # set the default separator (default "-") 999 | $t->day_list(@days) # set the default weekdays 1000 | $t->mon_list(@days) # set the default months 1001 | 1002 | $t->strftime(FORMAT) # same as POSIX::strftime (without the overhead 1003 | # of the full POSIX extension) 1004 | $t->strftime() # "Tue, 29 Feb 2000 12:34:56 GMT" 1005 | 1006 | Time::Piece->strptime(STRING, FORMAT) 1007 | # see strptime man page. Creates a new 1008 | # Time::Piece object 1009 | 1010 | Note that C and C are not listed above. If called as 1011 | methods on a Time::Piece object, they act as constructors, returning a new 1012 | Time::Piece object for the current time. In other words: they're not useful as 1013 | methods. 1014 | 1015 | =head2 Local Locales 1016 | 1017 | Both wdayname (day) and monname (month) allow passing in a list to use 1018 | to index the name of the days against. This can be useful if you need 1019 | to implement some form of localisation without actually installing or 1020 | using locales. Note that this is a global override and will affect 1021 | all Time::Piece instances. 1022 | 1023 | my @days = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi ); 1024 | 1025 | my $french_day = localtime->day(@days); 1026 | 1027 | These settings can be overridden globally too: 1028 | 1029 | Time::Piece::day_list(@days); 1030 | 1031 | Or for months: 1032 | 1033 | Time::Piece::mon_list(@months); 1034 | 1035 | And locally for months: 1036 | 1037 | print localtime->month(@months); 1038 | 1039 | Or to populate with your current system locale call: 1040 | Time::Piece->use_locale(); 1041 | 1042 | =head2 Date Calculations 1043 | 1044 | It's possible to use simple addition and subtraction of objects: 1045 | 1046 | use Time::Seconds; 1047 | 1048 | my $seconds = $t1 - $t2; 1049 | $t1 += ONE_DAY; # add 1 day (constant from Time::Seconds) 1050 | 1051 | The following are valid ($t1 and $t2 are Time::Piece objects): 1052 | 1053 | $t1 - $t2; # returns Time::Seconds object 1054 | $t1 - 42; # returns Time::Piece object 1055 | $t1 + 533; # returns Time::Piece object 1056 | 1057 | However adding a Time::Piece object to another Time::Piece object 1058 | will cause a runtime error. 1059 | 1060 | Note that the first of the above returns a Time::Seconds object, so 1061 | while examining the object will print the number of seconds (because 1062 | of the overloading), you can also get the number of minutes, hours, 1063 | days, weeks and years in that delta, using the Time::Seconds API. 1064 | 1065 | In addition to adding seconds, there are two APIs for adding months and 1066 | years: 1067 | 1068 | $t = $t->add_months(6); 1069 | $t = $t->add_years(5); 1070 | 1071 | The months and years can be negative for subtractions. Note that there 1072 | is some "strange" behaviour when adding and subtracting months at the 1073 | ends of months. Generally when the resulting month is shorter than the 1074 | starting month then the number of overlap days is added. For example 1075 | subtracting a month from 2008-03-31 will not result in 2008-02-31 as this 1076 | is an impossible date. Instead you will get 2008-03-02. This appears to 1077 | be consistent with other date manipulation tools. 1078 | 1079 | =head2 Truncation 1080 | 1081 | Calling the C method returns a copy of the object but with the 1082 | time truncated to the start of the supplied unit. 1083 | 1084 | $t = $t->truncate(to => 'day'); 1085 | 1086 | This example will set the time to midnight on the same date which C<$t> 1087 | had previously. Allowed values for the "to" parameter are: "year", 1088 | "quarter", "month", "day", "hour", "minute" and "second". 1089 | 1090 | =head2 Date Comparisons 1091 | 1092 | Date comparisons are also possible, using the full suite of "<", ">", 1093 | "<=", ">=", "<=>", "==" and "!=". 1094 | 1095 | =head2 Date Parsing 1096 | 1097 | Time::Piece has a built-in strptime() function (from FreeBSD), allowing 1098 | you incredibly flexible date parsing routines. For example: 1099 | 1100 | my $t = Time::Piece->strptime("Sunday 3rd Nov, 1943", 1101 | "%A %drd %b, %Y"); 1102 | 1103 | print $t->strftime("%a, %d %b %Y"); 1104 | 1105 | Outputs: 1106 | 1107 | Wed, 03 Nov 1943 1108 | 1109 | (see, it's even smart enough to fix my obvious date bug) 1110 | 1111 | For more information see "man strptime", which should be on all unix 1112 | systems. 1113 | 1114 | Alternatively look here: L 1115 | 1116 | =head3 CAVEAT %A, %a, %B, %b, and friends 1117 | 1118 | Time::Piece::strptime by default can only parse American English date names. 1119 | Meanwhile, Time::Piece->strftime() will return date names that use the current 1120 | configured system locale. This means dates returned by strftime might not be 1121 | able to be parsed by strptime. This is the default behavior and can be 1122 | overridden by calling Time::Piece->use_locale(). This builds a list of the 1123 | current locale's day and month names which strptime will use to parse with. 1124 | Note this is a global override and will affect all Time::Piece instances. 1125 | 1126 | For instance with a German locale: 1127 | 1128 | localtime->day_list(); 1129 | 1130 | Returns 1131 | 1132 | ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' ) 1133 | 1134 | While: 1135 | 1136 | Time::Piece->use_locale(); 1137 | localtime->day_list(); 1138 | 1139 | Returns 1140 | 1141 | ( 'So', 'Mo', 'Di', 'Mi', 'Do', 'Fr', 'Sa' ) 1142 | 1143 | =head2 YYYY-MM-DDThh:mm:ss 1144 | 1145 | The ISO 8601 standard defines the date format to be YYYY-MM-DD, and 1146 | the time format to be hh:mm:ss (24 hour clock), and if combined, they 1147 | should be concatenated with date first and with a capital 'T' in front 1148 | of the time. 1149 | 1150 | =head2 Week Number 1151 | 1152 | The I may be an unknown concept to some readers. The ISO 1153 | 8601 standard defines that weeks begin on a Monday and week 1 of the 1154 | year is the week that includes both January 4th and the first Thursday 1155 | of the year. In other words, if the first Monday of January is the 1156 | 2nd, 3rd, or 4th, the preceding days of the January are part of the 1157 | last week of the preceding year. Week numbers range from 1 to 53. 1158 | 1159 | =head2 Global Overriding 1160 | 1161 | Finally, it's possible to override localtime and gmtime everywhere, by 1162 | including the ':override' tag in the import list: 1163 | 1164 | use Time::Piece ':override'; 1165 | 1166 | =head1 CAVEATS 1167 | 1168 | =head2 Setting $ENV{TZ} in Threads on Win32 1169 | 1170 | Note that when using perl in the default build configuration on Win32 1171 | (specifically, when perl is built with PERL_IMPLICIT_SYS), each perl 1172 | interpreter maintains its own copy of the environment and only the main 1173 | interpreter will update the process environment seen by strftime. 1174 | 1175 | Therefore, if you make changes to $ENV{TZ} from inside a thread other than 1176 | the main thread then those changes will not be seen by strftime if you 1177 | subsequently call that with the %Z formatting code. You must change $ENV{TZ} 1178 | in the main thread to have the desired effect in this case (and you must 1179 | also call _tzset() in the main thread to register the environment change). 1180 | 1181 | Furthermore, remember that this caveat also applies to fork(), which is 1182 | emulated by threads on Win32. 1183 | 1184 | =head2 Use of epoch seconds 1185 | 1186 | This module internally uses the epoch seconds system that is provided via 1187 | the perl C function and supported by C and C. 1188 | 1189 | If your perl does not support times larger than C<2^31> seconds then this 1190 | module is likely to fail at processing dates beyond the year 2038. There are 1191 | moves afoot to fix that in perl. Alternatively use 64 bit perl. Or if none 1192 | of those are options, use the L module which has support for years 1193 | well into the future and past. 1194 | 1195 | Also, the internal representation of Time::Piece->strftime deviates from the 1196 | standard POSIX implementation in that is uses the epoch (instead of separate 1197 | year, month, day parts). This change was added in version 1.30. If you must 1198 | have a more traditional strftime (which will normally never calculate day 1199 | light saving times correctly), you can pass the date parts from Time::Piece 1200 | into the strftime function provided by the POSIX module 1201 | (see strftime in L ). 1202 | 1203 | =head1 AUTHOR 1204 | 1205 | Matt Sergeant, matt@sergeant.org 1206 | Jarkko Hietaniemi, jhi@iki.fi (while creating Time::Piece for core perl) 1207 | 1208 | =head1 COPYRIGHT AND LICENSE 1209 | 1210 | Copyright 2001, Larry Wall. 1211 | 1212 | This module is free software, you may distribute it under the same terms 1213 | as Perl. 1214 | 1215 | =head1 SEE ALSO 1216 | 1217 | The excellent Calendar FAQ at L 1218 | 1219 | =head1 BUGS 1220 | 1221 | The test harness leaves much to be desired. Patches welcome. 1222 | 1223 | =cut 1224 | -------------------------------------------------------------------------------- /Piece.xs: -------------------------------------------------------------------------------- 1 | #define PERL_NO_GET_CONTEXT 2 | #include "EXTERN.h" 3 | #include "perl.h" 4 | #include "XSUB.h" 5 | #include 6 | 7 | #define DAYS_PER_YEAR 365 8 | #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) 9 | #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) 10 | #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) 11 | #define SECS_PER_HOUR (60*60) 12 | #define SECS_PER_DAY (24*SECS_PER_HOUR) 13 | /* parentheses deliberately absent on these two, otherwise they don't work */ 14 | #define MONTH_TO_DAYS 153/5 15 | #define DAYS_TO_MONTH 5/153 16 | /* offset to bias by March (month 4) 1st between month/mday & year finding */ 17 | #define YEAR_ADJUST (4*MONTH_TO_DAYS+1) 18 | /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ 19 | #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ 20 | #define TP_BUF_SIZE 160 21 | 22 | #ifdef WIN32 23 | 24 | /* 25 | * (1) The CRT maintains its own copy of the environment, separate from 26 | * the Win32API copy. 27 | * 28 | * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this 29 | * copy, and then calls SetEnvironmentVariableA() to update the Win32API 30 | * copy. 31 | * 32 | * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and 33 | * SetEnvironmentVariableA() directly, bypassing the CRT copy of the 34 | * environment. 35 | * 36 | * (4) The CRT strftime() "%Z" implementation calls __tzset(). That 37 | * calls CRT tzset(), but only the first time it is called, and in turn 38 | * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT 39 | * local copy of the environment and hence gets the original setting as 40 | * perl never updates the CRT copy when assigning to $ENV{TZ}. 41 | * 42 | * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT 43 | * putenv() to update the CRT copy of the environment (if it is different) 44 | * whenever we're about to call tzset(). 45 | * 46 | * In addition to all that, when perl is built with PERL_IMPLICIT_SYS 47 | * defined: 48 | * 49 | * (a) Each interpreter has its own copy of the environment inside the 50 | * perlhost structure. That allows applications that host multiple 51 | * independent Perl interpreters to isolate environment changes from 52 | * each other. (This is similar to how the perlhost mechanism keeps a 53 | * separate working directory for each Perl interpreter, so that calling 54 | * chdir() will not affect other interpreters.) 55 | * 56 | * (b) Only the first Perl interpreter instantiated within a process will 57 | * "write through" environment changes to the process environment. 58 | * 59 | * (c) Even the primary Perl interpreter won't update the CRT copy of the 60 | * the environment, only the Win32API copy (it calls win32_putenv()). 61 | * 62 | * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes 63 | * sense to only update the process environment when inside the main 64 | * interpreter, but we don't have access to CPerlHost's m_bTopLevel member 65 | * from here so we'll just have to check PL_curinterp instead. 66 | * 67 | * Therefore, we can simply #undef getenv() and putenv() so that those names 68 | * always refer to the CRT functions, and explicitly call win32_getenv() to 69 | * access perl's %ENV. 70 | * 71 | * We also #undef malloc() and free() to be sure we are using the CRT 72 | * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls 73 | * into VMem::Malloc() and VMem::Free() and all allocations will be freed 74 | * when the Perl interpreter is being destroyed so we'd end up with a pointer 75 | * into deallocated memory in environ[] if a program embedding a Perl 76 | * interpreter continues to operate even after the main Perl interpreter has 77 | * been destroyed. 78 | * 79 | * Note that we don't free() the malloc()ed memory unless and until we call 80 | * malloc() again ourselves because the CRT putenv() function simply puts its 81 | * pointer argument into the environ[] array (it doesn't make a copy of it) 82 | * so this memory must otherwise be leaked. 83 | */ 84 | 85 | #undef getenv 86 | #undef putenv 87 | # ifdef UNDER_CE 88 | # define getenv xcegetenv 89 | # define putenv xceputenv 90 | # endif 91 | #undef malloc 92 | #undef free 93 | 94 | static void 95 | fix_win32_tzenv(void) 96 | { 97 | static char* oldenv = NULL; 98 | char* newenv; 99 | const char* perl_tz_env = win32_getenv("TZ"); 100 | const char* crt_tz_env = getenv("TZ"); 101 | if (perl_tz_env == NULL) 102 | perl_tz_env = ""; 103 | if (crt_tz_env == NULL) 104 | crt_tz_env = ""; 105 | if (strcmp(perl_tz_env, crt_tz_env) != 0) { 106 | STRLEN perl_tz_env_len = strlen(perl_tz_env); 107 | newenv = (char*)malloc(perl_tz_env_len + 4); 108 | if (newenv != NULL) { 109 | /* putenv with old MS CRTs will cause a double free internally if you delete 110 | an env var with the CRT env that doesn't exist in Win32 env (perl %ENV only 111 | modifies the Win32 env, not CRT env), so always create the env var in Win32 112 | env before deleting it with CRT env api, so the error branch never executes 113 | in __crtsetenv after SetEnvironmentVariableA executes inside __crtsetenv. 114 | 115 | VC 9/2008 and up dont have this bug, older VC (msvcrt80.dll and older) and 116 | mingw (msvcrt.dll) have it see [perl #125529] 117 | */ 118 | #if !(_MSC_VER >= 1500) 119 | if(!perl_tz_env_len) 120 | SetEnvironmentVariableA("TZ", ""); 121 | #endif 122 | sprintf(newenv, "TZ=%s", perl_tz_env); 123 | putenv(newenv); 124 | if (oldenv != NULL) 125 | free(oldenv); 126 | oldenv = newenv; 127 | } 128 | } 129 | } 130 | 131 | #endif 132 | 133 | /* 134 | * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32. 135 | * This code is duplicated in the POSIX module, so any changes made here 136 | * should be made there too. 137 | */ 138 | static void 139 | my_tzset(pTHX) 140 | { 141 | #ifdef WIN32 142 | #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) 143 | if (PL_curinterp == aTHX) 144 | #endif 145 | fix_win32_tzenv(); 146 | #endif 147 | tzset(); 148 | } 149 | 150 | /* 151 | * my_mini_mktime - normalise struct tm values without the localtime() 152 | * semantics (and overhead) of mktime(). Stolen shamelessly from Perl's 153 | * Perl_mini_mktime() in util.c - for details on the algorithm, see that 154 | * file. 155 | */ 156 | static void 157 | my_mini_mktime(struct tm *ptm) 158 | { 159 | int yearday; 160 | int secs; 161 | int month, mday, year, jday; 162 | int odd_cent, odd_year; 163 | 164 | year = 1900 + ptm->tm_year; 165 | month = ptm->tm_mon; 166 | mday = ptm->tm_mday; 167 | /* allow given yday with no month & mday to dominate the result */ 168 | if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { 169 | month = 0; 170 | mday = 0; 171 | jday = 1 + ptm->tm_yday; 172 | } 173 | else { 174 | jday = 0; 175 | } 176 | if (month >= 2) 177 | month+=2; 178 | else 179 | month+=14, year--; 180 | 181 | yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; 182 | yearday += month*MONTH_TO_DAYS + mday + jday; 183 | /* 184 | * Note that we don't know when leap-seconds were or will be, 185 | * so we have to trust the user if we get something which looks 186 | * like a sensible leap-second. Wild values for seconds will 187 | * be rationalised, however. 188 | */ 189 | if ((unsigned) ptm->tm_sec <= 60) { 190 | secs = 0; 191 | } 192 | else { 193 | secs = ptm->tm_sec; 194 | ptm->tm_sec = 0; 195 | } 196 | secs += 60 * ptm->tm_min; 197 | secs += SECS_PER_HOUR * ptm->tm_hour; 198 | if (secs < 0) { 199 | if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { 200 | /* got negative remainder, but need positive time */ 201 | /* back off an extra day to compensate */ 202 | yearday += (secs/SECS_PER_DAY)-1; 203 | secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); 204 | } 205 | else { 206 | yearday += (secs/SECS_PER_DAY); 207 | secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); 208 | } 209 | } 210 | else if (secs >= SECS_PER_DAY) { 211 | yearday += (secs/SECS_PER_DAY); 212 | secs %= SECS_PER_DAY; 213 | } 214 | ptm->tm_hour = secs/SECS_PER_HOUR; 215 | secs %= SECS_PER_HOUR; 216 | ptm->tm_min = secs/60; 217 | secs %= 60; 218 | ptm->tm_sec += secs; 219 | /* done with time of day effects */ 220 | /* 221 | * The algorithm for yearday has (so far) left it high by 428. 222 | * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to 223 | * bias it by 123 while trying to figure out what year it 224 | * really represents. Even with this tweak, the reverse 225 | * translation fails for years before A.D. 0001. 226 | * It would still fail for Feb 29, but we catch that one below. 227 | */ 228 | jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ 229 | yearday -= YEAR_ADJUST; 230 | year = (yearday / DAYS_PER_QCENT) * 400; 231 | yearday %= DAYS_PER_QCENT; 232 | odd_cent = yearday / DAYS_PER_CENT; 233 | year += odd_cent * 100; 234 | yearday %= DAYS_PER_CENT; 235 | year += (yearday / DAYS_PER_QYEAR) * 4; 236 | yearday %= DAYS_PER_QYEAR; 237 | odd_year = yearday / DAYS_PER_YEAR; 238 | year += odd_year; 239 | yearday %= DAYS_PER_YEAR; 240 | if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ 241 | month = 1; 242 | yearday = 29; 243 | } 244 | else { 245 | yearday += YEAR_ADJUST; /* recover March 1st crock */ 246 | month = yearday*DAYS_TO_MONTH; 247 | yearday -= month*MONTH_TO_DAYS; 248 | /* recover other leap-year adjustment */ 249 | if (month > 13) { 250 | month-=14; 251 | year++; 252 | } 253 | else { 254 | month-=2; 255 | } 256 | } 257 | ptm->tm_year = year - 1900; 258 | if (yearday) { 259 | ptm->tm_mday = yearday; 260 | ptm->tm_mon = month; 261 | } 262 | else { 263 | ptm->tm_mday = 31; 264 | ptm->tm_mon = month - 1; 265 | } 266 | /* re-build yearday based on Jan 1 to get tm_yday */ 267 | year--; 268 | yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; 269 | yearday += 14*MONTH_TO_DAYS + 1; 270 | ptm->tm_yday = jday - yearday; 271 | /* fix tm_wday if not overridden by caller */ 272 | ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; 273 | } 274 | 275 | # if defined(WIN32) || (defined(__QNX__) && defined(__WATCOMC__)) 276 | # define strncasecmp(x,y,n) strnicmp(x,y,n) 277 | # endif 278 | 279 | /* strptime.c 0.1 (Powerdog) 94/03/27 */ 280 | /* strptime copied from freebsd with the following copyright: */ 281 | /* 282 | * Copyright (c) 1994 Powerdog Industries. All rights reserved. 283 | * 284 | * Redistribution and use in source and binary forms, with or without 285 | * modification, are permitted provided that the following conditions 286 | * are met: 287 | * 288 | * 1. Redistributions of source code must retain the above copyright 289 | * notice, this list of conditions and the following disclaimer. 290 | * 291 | * 2. Redistributions in binary form must reproduce the above copyright 292 | * notice, this list of conditions and the following disclaimer 293 | * in the documentation and/or other materials provided with the 294 | * distribution. 295 | * 296 | * THIS SOFTWARE IS PROVIDED BY POWERDOG INDUSTRIES ``AS IS'' AND ANY 297 | * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 298 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 299 | * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE POWERDOG INDUSTRIES BE 300 | * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 301 | * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 302 | * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 303 | * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 304 | * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 305 | * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 306 | * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 307 | * 308 | * The views and conclusions contained in the software and documentation 309 | * are those of the authors and should not be interpreted as representing 310 | * official policies, either expressed or implied, of Powerdog Industries. 311 | */ 312 | 313 | #include 314 | #include 315 | #include 316 | static char * _strptime(pTHX_ const char *, const char *, struct tm *, 317 | int *got_GMT); 318 | 319 | #define asizeof(a) (sizeof (a) / sizeof ((a)[0])) 320 | 321 | struct lc_time_T { 322 | char * mon[12]; 323 | char * month[12]; 324 | char * wday[7]; 325 | char * weekday[7]; 326 | char * am; 327 | char * pm; 328 | char * AM; 329 | char * PM; 330 | char * alt_month[12]; 331 | }; 332 | 333 | 334 | static struct lc_time_T _C_time_locale; 335 | 336 | #define Locale (&_C_time_locale) 337 | 338 | static char * 339 | _strptime(pTHX_ const char *buf, const char *fmt, struct tm *tm, int *got_GMT) 340 | { 341 | char c; 342 | const char *ptr; 343 | int i; 344 | size_t len; 345 | int Ealternative, Oalternative; 346 | 347 | /* There seems to be a slightly improved version at 348 | * http://www.opensource.apple.com/source/Libc/Libc-583/stdtime/strptime-fbsd.c 349 | * which we may end up borrowing more from 350 | */ 351 | ptr = fmt; 352 | while (*ptr != 0) { 353 | if (*buf == 0) 354 | break; 355 | 356 | c = *ptr++; 357 | 358 | if (c != '%') { 359 | if (isspace((unsigned char)c)) 360 | while (*buf != 0 && isspace((unsigned char)*buf)) 361 | buf++; 362 | else if (c != *buf++) 363 | return 0; 364 | continue; 365 | } 366 | 367 | Ealternative = 0; 368 | Oalternative = 0; 369 | label: 370 | c = *ptr++; 371 | switch (c) { 372 | case 0: 373 | case '%': 374 | if (*buf++ != '%') 375 | return 0; 376 | break; 377 | 378 | case '+': 379 | buf = _strptime(aTHX_ buf, "%c", tm, got_GMT); 380 | if (buf == 0) 381 | return 0; 382 | break; 383 | 384 | case 'C': 385 | if (!isdigit((unsigned char)*buf)) 386 | return 0; 387 | 388 | /* XXX This will break for 3-digit centuries. */ 389 | len = 2; 390 | for (i = 0; len && *buf != 0 && isdigit((unsigned char)*buf); buf++) { 391 | i *= 10; 392 | i += *buf - '0'; 393 | len--; 394 | } 395 | if (i < 19) 396 | return 0; 397 | 398 | tm->tm_year = i * 100 - 1900; 399 | break; 400 | 401 | case 'c': 402 | /* NOTE: c_fmt is intentionally ignored */ 403 | 404 | buf = _strptime(aTHX_ buf, "%a %d %b %Y %I:%M:%S %p %Z", tm, got_GMT); 405 | if (buf == 0) 406 | return 0; 407 | break; 408 | 409 | case 'D': 410 | buf = _strptime(aTHX_ buf, "%m/%d/%y", tm, got_GMT); 411 | if (buf == 0) 412 | return 0; 413 | break; 414 | 415 | case 'E': 416 | if (Ealternative || Oalternative) 417 | break; 418 | Ealternative++; 419 | goto label; 420 | 421 | case 'O': 422 | if (Ealternative || Oalternative) 423 | break; 424 | Oalternative++; 425 | goto label; 426 | 427 | case 'F': 428 | buf = _strptime(aTHX_ buf, "%Y-%m-%d", tm, got_GMT); 429 | if (buf == 0) 430 | return 0; 431 | break; 432 | 433 | case 'R': 434 | buf = _strptime(aTHX_ buf, "%H:%M", tm, got_GMT); 435 | if (buf == 0) 436 | return 0; 437 | break; 438 | 439 | case 'r': 440 | buf = _strptime(aTHX_ buf, "%I:%M:%S %p", tm, got_GMT); 441 | if (buf == 0) 442 | return 0; 443 | break; 444 | 445 | case 'n': /* whitespace */ 446 | case 't': 447 | if (!isspace((unsigned char)*buf)) 448 | return 0; 449 | while (isspace((unsigned char)*buf)) 450 | buf++; 451 | break; 452 | 453 | case 'T': 454 | buf = _strptime(aTHX_ buf, "%H:%M:%S", tm, got_GMT); 455 | if (buf == 0) 456 | return 0; 457 | break; 458 | 459 | case 'X': 460 | buf = _strptime(aTHX_ buf, "%I:%M:%S %p", tm, got_GMT); 461 | if (buf == 0) 462 | return 0; 463 | break; 464 | 465 | case 'x': 466 | buf = _strptime(aTHX_ buf, "%a %d %b %Y", tm, got_GMT); 467 | if (buf == 0) 468 | return 0; 469 | break; 470 | 471 | case 'j': 472 | if (!isdigit((unsigned char)*buf)) 473 | return 0; 474 | 475 | len = 3; 476 | for (i = 0; len && *buf != 0 && isdigit((unsigned char)*buf); buf++) { 477 | i *= 10; 478 | i += *buf - '0'; 479 | len--; 480 | } 481 | if (i < 1 || i > 366) 482 | return 0; 483 | 484 | tm->tm_yday = i - 1; 485 | tm->tm_mday = 0; 486 | break; 487 | 488 | case 'M': 489 | case 'S': 490 | if (*buf == 0 || isspace((unsigned char)*buf)) 491 | break; 492 | 493 | if (!isdigit((unsigned char)*buf)) 494 | return 0; 495 | 496 | len = 2; 497 | for (i = 0; len && *buf != 0 && isdigit((unsigned char)*buf); buf++) { 498 | i *= 10; 499 | i += *buf - '0'; 500 | len--; 501 | } 502 | 503 | if (c == 'M') { 504 | if (i > 59) 505 | return 0; 506 | tm->tm_min = i; 507 | } else { 508 | if (i > 60) 509 | return 0; 510 | tm->tm_sec = i; 511 | } 512 | 513 | if (*buf != 0 && isspace((unsigned char)*buf)) 514 | while (*ptr != 0 && !isspace((unsigned char)*ptr)) 515 | ptr++; 516 | break; 517 | 518 | case 'H': 519 | case 'I': 520 | case 'k': 521 | case 'l': 522 | /* 523 | * Of these, %l is the only specifier explicitly 524 | * documented as not being zero-padded. However, 525 | * there is no harm in allowing zero-padding. 526 | * 527 | * XXX The %l specifier may gobble one too many 528 | * digits if used incorrectly. 529 | */ 530 | if (!isdigit((unsigned char)*buf)) 531 | return 0; 532 | 533 | len = 2; 534 | for (i = 0; len && *buf != 0 && isdigit((unsigned char)*buf); buf++) { 535 | i *= 10; 536 | i += *buf - '0'; 537 | len--; 538 | } 539 | if (c == 'H' || c == 'k') { 540 | if (i > 23) 541 | return 0; 542 | } else if (i > 12) 543 | return 0; 544 | 545 | tm->tm_hour = i; 546 | 547 | if (*buf != 0 && isspace((unsigned char)*buf)) 548 | while (*ptr != 0 && !isspace((unsigned char)*ptr)) 549 | ptr++; 550 | break; 551 | 552 | case 'p': 553 | case 'P': 554 | /* 555 | * XXX This is bogus if parsed before hour-related 556 | * specifiers. 557 | */ 558 | len = strlen(Locale->am); 559 | if (strncasecmp(buf, Locale->am, len) == 0 || 560 | strncasecmp(buf, Locale->AM, len) == 0) { 561 | if (tm->tm_hour > 12) 562 | return 0; 563 | if (tm->tm_hour == 12) 564 | tm->tm_hour = 0; 565 | buf += len; 566 | break; 567 | } 568 | 569 | len = strlen(Locale->pm); 570 | if (strncasecmp(buf, Locale->pm, len) == 0 || 571 | strncasecmp(buf, Locale->PM, len) == 0) { 572 | if (tm->tm_hour > 12) 573 | return 0; 574 | if (tm->tm_hour != 12) 575 | tm->tm_hour += 12; 576 | buf += len; 577 | break; 578 | } 579 | 580 | return 0; 581 | 582 | case 'A': 583 | case 'a': 584 | for (i = 0; i < (int)asizeof(Locale->weekday); i++) { 585 | if (c == 'A') { 586 | len = strlen(Locale->weekday[i]); 587 | if (strncasecmp(buf, 588 | Locale->weekday[i], 589 | len) == 0) 590 | break; 591 | } else { 592 | len = strlen(Locale->wday[i]); 593 | if (strncasecmp(buf, 594 | Locale->wday[i], 595 | len) == 0) 596 | break; 597 | } 598 | } 599 | if (i == (int)asizeof(Locale->weekday)) 600 | return 0; 601 | 602 | tm->tm_wday = i; 603 | buf += len; 604 | break; 605 | 606 | case 'U': 607 | case 'V': 608 | case 'W': 609 | /* 610 | * XXX This is bogus, as we can not assume any valid 611 | * information present in the tm structure at this 612 | * point to calculate a real value, so just check the 613 | * range for now. 614 | */ 615 | if (!isdigit((unsigned char)*buf)) 616 | return 0; 617 | 618 | len = 2; 619 | for (i = 0; len && *buf != 0 && isdigit((unsigned char)*buf); buf++) { 620 | i *= 10; 621 | i += *buf - '0'; 622 | len--; 623 | } 624 | if (i > 53) 625 | return 0; 626 | 627 | if (*buf != 0 && isspace((unsigned char)*buf)) 628 | while (*ptr != 0 && !isspace((unsigned char)*ptr)) 629 | ptr++; 630 | break; 631 | 632 | case 'u': 633 | case 'w': 634 | if (!isdigit((unsigned char)*buf)) 635 | return 0; 636 | 637 | i = *buf - '0'; 638 | if (i > 6 + (c == 'u')) 639 | return 0; 640 | if (i == 7) 641 | i = 0; 642 | 643 | tm->tm_wday = i; 644 | 645 | buf++; 646 | if (*buf != 0 && isspace((unsigned char)*buf)) 647 | while (*ptr != 0 && !isspace((unsigned char)*ptr)) 648 | ptr++; 649 | break; 650 | 651 | case 'd': 652 | case 'e': 653 | /* 654 | * The %e specifier is explicitly documented as not 655 | * being zero-padded but there is no harm in allowing 656 | * such padding. 657 | * 658 | * XXX The %e specifier may gobble one too many 659 | * digits if used incorrectly. 660 | */ 661 | if (!isdigit((unsigned char)*buf)) 662 | return 0; 663 | 664 | len = 2; 665 | for (i = 0; len && *buf != 0 && isdigit((unsigned char)*buf); buf++) { 666 | i *= 10; 667 | i += *buf - '0'; 668 | len--; 669 | } 670 | if (i > 31) 671 | return 0; 672 | 673 | tm->tm_mday = i; 674 | 675 | if (*buf != 0 && isspace((unsigned char)*buf)) 676 | while (*ptr != 0 && !isspace((unsigned char)*ptr)) 677 | ptr++; 678 | break; 679 | 680 | case 'B': 681 | case 'b': 682 | case 'h': 683 | for (i = 0; i < (int)asizeof(Locale->month); i++) { 684 | if (Oalternative) { 685 | if (c == 'B') { 686 | len = strlen(Locale->alt_month[i]); 687 | if (strncasecmp(buf, 688 | Locale->alt_month[i], 689 | len) == 0) 690 | break; 691 | } 692 | } else { 693 | if (c == 'B') { 694 | len = strlen(Locale->month[i]); 695 | if (strncasecmp(buf, 696 | Locale->month[i], 697 | len) == 0) 698 | break; 699 | } else { 700 | len = strlen(Locale->mon[i]); 701 | if (strncasecmp(buf, 702 | Locale->mon[i], 703 | len) == 0) 704 | break; 705 | } 706 | } 707 | } 708 | if (i == (int)asizeof(Locale->month)) 709 | return 0; 710 | 711 | tm->tm_mon = i; 712 | buf += len; 713 | break; 714 | 715 | case 'm': 716 | if (!isdigit((unsigned char)*buf)) 717 | return 0; 718 | 719 | len = 2; 720 | for (i = 0; len && *buf != 0 && isdigit((unsigned char)*buf); buf++) { 721 | i *= 10; 722 | i += *buf - '0'; 723 | len--; 724 | } 725 | if (i < 1 || i > 12) 726 | return 0; 727 | 728 | tm->tm_mon = i - 1; 729 | 730 | if (*buf != 0 && isspace((unsigned char)*buf)) 731 | while (*ptr != 0 && !isspace((unsigned char)*ptr)) 732 | ptr++; 733 | break; 734 | 735 | case 's': 736 | { 737 | char *cp; 738 | int sverrno; 739 | long n; 740 | time_t t; 741 | struct tm mytm; 742 | 743 | sverrno = errno; 744 | errno = 0; 745 | n = strtol(buf, &cp, 10); 746 | if (errno == ERANGE || (long)(t = n) != n) { 747 | errno = sverrno; 748 | return 0; 749 | } 750 | errno = sverrno; 751 | buf = cp; 752 | memset(&mytm, 0, sizeof(mytm)); 753 | 754 | if(*got_GMT == 1) 755 | mytm = *localtime(&t); 756 | else 757 | mytm = *gmtime(&t); 758 | 759 | tm->tm_sec = mytm.tm_sec; 760 | tm->tm_min = mytm.tm_min; 761 | tm->tm_hour = mytm.tm_hour; 762 | tm->tm_mday = mytm.tm_mday; 763 | tm->tm_mon = mytm.tm_mon; 764 | tm->tm_year = mytm.tm_year; 765 | tm->tm_wday = mytm.tm_wday; 766 | tm->tm_yday = mytm.tm_yday; 767 | tm->tm_isdst = mytm.tm_isdst; 768 | } 769 | break; 770 | 771 | case 'Y': 772 | case 'y': 773 | if (*buf == 0 || isspace((unsigned char)*buf)) 774 | break; 775 | 776 | if (!isdigit((unsigned char)*buf)) 777 | return 0; 778 | 779 | len = (c == 'Y') ? 4 : 2; 780 | for (i = 0; len && *buf != 0 && isdigit((unsigned char)*buf); buf++) { 781 | i *= 10; 782 | i += *buf - '0'; 783 | len--; 784 | } 785 | if (c == 'Y') 786 | i -= 1900; 787 | if (c == 'y' && i < 69) 788 | i += 100; 789 | if (i < 0) 790 | return 0; 791 | 792 | tm->tm_year = i; 793 | 794 | if (*buf != 0 && isspace((unsigned char)*buf)) 795 | while (*ptr != 0 && !isspace((unsigned char)*ptr)) 796 | ptr++; 797 | break; 798 | 799 | case 'Z': 800 | { 801 | const char *cp; 802 | char *zonestr; 803 | 804 | for (cp = buf; *cp && isupper((unsigned char)*cp); ++cp) 805 | {/*empty*/} 806 | if (cp - buf) { 807 | zonestr = (char *)malloc((size_t) (cp - buf + 1)); 808 | if (!zonestr) { 809 | errno = ENOMEM; 810 | return 0; 811 | } 812 | strncpy(zonestr, buf,(size_t) (cp - buf)); 813 | zonestr[cp - buf] = '\0'; 814 | my_tzset(aTHX); 815 | if (0 == strcmp(zonestr, "GMT")) { 816 | *got_GMT = 1; 817 | } 818 | free(zonestr); 819 | if (!*got_GMT) return 0; 820 | buf += cp - buf; 821 | } 822 | } 823 | break; 824 | 825 | case 'z': 826 | { 827 | int sign = 1; 828 | 829 | if (*buf != '+') { 830 | if (*buf == '-') 831 | sign = -1; 832 | else 833 | return 0; 834 | } 835 | 836 | buf++; 837 | i = 0; 838 | for (len = 4; len > 0; len--) { 839 | if (isdigit((int)*buf)) { 840 | i *= 10; 841 | i += *buf - '0'; 842 | buf++; 843 | } else 844 | return 0; 845 | } 846 | 847 | tm->tm_hour -= sign * (i / 100); 848 | tm->tm_min -= sign * (i % 100); 849 | *got_GMT = 1; 850 | } 851 | break; 852 | } 853 | } 854 | return (char *)buf; 855 | } 856 | 857 | /* Saves alot of machine code. 858 | Takes a (auto) SP, which may or may not have been PUSHed before, puts 859 | tm struct members on Perl stack, then returns new, advanced, SP to caller. 860 | Assign the return of push_common_tm to your SP, so you can continue to PUSH 861 | or do a PUTBACK and return eventually. 862 | !!!! push_common_tm does not touch PL_stack_sp !!!! 863 | !!!! do not use PUTBACK then SPAGAIN semantics around push_common_tm !!!! 864 | !!!! You must mortalize whatever push_common_tm put on stack yourself to 865 | avoid leaking !!!! 866 | */ 867 | static SV ** 868 | push_common_tm(pTHX_ SV ** SP, struct tm *mytm) 869 | { 870 | PUSHs(newSViv(mytm->tm_sec)); 871 | PUSHs(newSViv(mytm->tm_min)); 872 | PUSHs(newSViv(mytm->tm_hour)); 873 | PUSHs(newSViv(mytm->tm_mday)); 874 | PUSHs(newSViv(mytm->tm_mon)); 875 | PUSHs(newSViv(mytm->tm_year)); 876 | PUSHs(newSViv(mytm->tm_wday)); 877 | PUSHs(newSViv(mytm->tm_yday)); 878 | PUSHs(newSViv(mytm->tm_isdst)); 879 | return SP; 880 | } 881 | 882 | /* specialized common end of 2 XSUBs 883 | SV ** SP -- pass your (auto) SP, which has not been PUSHed before, but was 884 | reset to 0 (PPCODE only or SP -= items or XSprePUSH) 885 | tm *mytm -- a tm *, will be proprocessed with my_mini_mktime 886 | return -- none, after calling return_11part_tm, you must call "return;" 887 | no exceptions 888 | */ 889 | static void 890 | return_11part_tm(pTHX_ SV ** SP, struct tm *mytm) 891 | { 892 | my_mini_mktime(mytm); 893 | 894 | /* warn("tm: %d-%d-%d %d:%d:%d\n", mytm->tm_year, mytm->tm_mon, mytm->tm_mday, mytm->tm_hour, mytm->tm_min, mytm->tm_sec); */ 895 | EXTEND(SP, 11); 896 | SP = push_common_tm(aTHX_ SP, mytm); 897 | /* epoch */ 898 | PUSHs(newSViv(0)); 899 | /* islocal */ 900 | PUSHs(newSViv(0)); 901 | PUTBACK; 902 | { 903 | SV ** endsp = SP; /* the SV * under SP needs to be mortaled */ 904 | SP -= (11 - 1); /* subtract 0 based count of SVs to mortal */ 905 | /* mortal target of SP, then increment before function call 906 | so SP is already calculated before next comparison to not stall CPU */ 907 | do { 908 | sv_2mortal(*SP++); 909 | } while(SP <= endsp); 910 | } 911 | return; 912 | } 913 | 914 | 915 | static void _populate_C_time_locale(pTHX_ HV* locales ) 916 | { 917 | AV* alt_names = (AV *) SvRV( *hv_fetch(locales, "alt_month", 9, 0) ); 918 | AV* long_names = (AV *) SvRV( *hv_fetch(locales, "month", 5, 0) ); 919 | AV* short_names = (AV *) SvRV( *hv_fetch(locales, "mon", 3, 0) ); 920 | int i; 921 | 922 | for (i = 0; i < 1 + (int) av_len( long_names ); i++) { 923 | Locale->alt_month[i] = SvPV_nolen( (SV *) *av_fetch(alt_names, i, 0) ); 924 | Locale->month[i] = SvPV_nolen( (SV *) *av_fetch(long_names, i, 0) ); 925 | Locale->mon[i] = SvPV_nolen( (SV *) *av_fetch(short_names, i, 0) ); 926 | } 927 | 928 | long_names = (AV *) SvRV( *hv_fetch(locales, "weekday", 7, 0) ); 929 | short_names = (AV *) SvRV( *hv_fetch(locales, "wday", 4, 0) ); 930 | 931 | for (i = 0; i < 1 + (int) av_len( long_names ); i++) { 932 | Locale->wday[i] = SvPV_nolen( (SV *) *av_fetch(short_names, i, 0) ); 933 | Locale->weekday[i] = SvPV_nolen( (SV *) *av_fetch(long_names, i, 0) ); 934 | } 935 | 936 | Locale->am = SvPV_nolen( (SV *) *hv_fetch(locales, "am", 2, 0) ); 937 | Locale->pm = SvPV_nolen( (SV *) *hv_fetch(locales, "pm", 2, 0) ); 938 | Locale->AM = SvPV_nolen( (SV *) *hv_fetch(locales, "AM", 2, 0) ); 939 | Locale->PM = SvPV_nolen( (SV *) *hv_fetch(locales, "PM", 2, 0) ); 940 | 941 | return; 942 | } 943 | 944 | MODULE = Time::Piece PACKAGE = Time::Piece 945 | 946 | PROTOTYPES: ENABLE 947 | 948 | void 949 | _strftime(fmt, epoch, islocal = 1) 950 | char * fmt 951 | time_t epoch 952 | int islocal 953 | CODE: 954 | { 955 | char tmpbuf[TP_BUF_SIZE]; 956 | struct tm mytm; 957 | size_t len; 958 | 959 | if(islocal == 1) 960 | mytm = *localtime(&epoch); 961 | else 962 | mytm = *gmtime(&epoch); 963 | 964 | len = strftime(tmpbuf, TP_BUF_SIZE, fmt, &mytm); 965 | /* 966 | ** The following is needed to handle to the situation where 967 | ** tmpbuf overflows. Basically we want to allocate a buffer 968 | ** and try repeatedly. The reason why it is so complicated 969 | ** is that getting a return value of 0 from strftime can indicate 970 | ** one of the following: 971 | ** 1. buffer overflowed, 972 | ** 2. illegal conversion specifier, or 973 | ** 3. the format string specifies nothing to be returned(not 974 | ** an error). This could be because format is an empty string 975 | ** or it specifies %p that yields an empty string in some locale. 976 | ** If there is a better way to make it portable, go ahead by 977 | ** all means. 978 | */ 979 | if ((len > 0 && len < TP_BUF_SIZE) || (len == 0 && *fmt == '\0')) 980 | ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); 981 | else { 982 | /* Possibly buf overflowed - try again with a bigger buf */ 983 | size_t fmtlen = strlen(fmt); 984 | size_t bufsize = fmtlen + TP_BUF_SIZE; 985 | char* buf; 986 | size_t buflen; 987 | 988 | New(0, buf, bufsize, char); 989 | while (buf) { 990 | buflen = strftime(buf, bufsize, fmt, &mytm); 991 | if (buflen > 0 && buflen < bufsize) 992 | break; 993 | /* heuristic to prevent out-of-memory errors */ 994 | if (bufsize > 100*fmtlen) { 995 | Safefree(buf); 996 | buf = NULL; 997 | break; 998 | } 999 | bufsize *= 2; 1000 | Renew(buf, bufsize, char); 1001 | } 1002 | if (buf) { 1003 | ST(0) = sv_2mortal(newSVpv(buf, buflen)); 1004 | Safefree(buf); 1005 | } 1006 | else 1007 | ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); 1008 | } 1009 | } 1010 | 1011 | void 1012 | _tzset() 1013 | PPCODE: 1014 | PUTBACK; /* makes rest of this function tailcall friendly */ 1015 | my_tzset(aTHX); 1016 | return; /* skip XSUBPP's PUTBACK */ 1017 | 1018 | void 1019 | _strptime ( string, format, got_GMT, SV* localization ) 1020 | char * string 1021 | char * format 1022 | int got_GMT 1023 | PREINIT: 1024 | struct tm mytm; 1025 | char * remainder; 1026 | HV * locales; 1027 | PPCODE: 1028 | memset(&mytm, 0, sizeof(mytm)); 1029 | 1030 | /* sensible defaults. */ 1031 | mytm.tm_mday = 1; 1032 | mytm.tm_year = 70; 1033 | mytm.tm_wday = 4; 1034 | mytm.tm_isdst = -1; /* -1 means we don't know */ 1035 | 1036 | if( SvTYPE(SvRV( localization )) == SVt_PVHV ){ 1037 | locales = (HV *)SvRV(localization); 1038 | } 1039 | else{ 1040 | croak("_strptime requires a Hash Reference of locales"); 1041 | } 1042 | 1043 | /* populate our locale data struct (used for %[AaBbPp] flags) */ 1044 | _populate_C_time_locale(aTHX_ locales ); 1045 | 1046 | remainder = (char *)_strptime(aTHX_ string, format, &mytm, &got_GMT); 1047 | if (remainder == NULL) { 1048 | croak("Error parsing time"); 1049 | } 1050 | if (*remainder != '\0') { 1051 | warn("Garbage at end of string in strptime: %s", remainder); 1052 | warn("Perhaps a format flag did not match the actual input?"); 1053 | } 1054 | 1055 | return_11part_tm(aTHX_ SP, &mytm); 1056 | return; 1057 | 1058 | void 1059 | _mini_mktime(int sec, int min, int hour, int mday, int mon, int year) 1060 | PREINIT: 1061 | struct tm mytm; 1062 | time_t t; 1063 | PPCODE: 1064 | t = 0; 1065 | mytm = *gmtime(&t); 1066 | 1067 | mytm.tm_sec = sec; 1068 | mytm.tm_min = min; 1069 | mytm.tm_hour = hour; 1070 | mytm.tm_mday = mday; 1071 | mytm.tm_mon = mon; 1072 | mytm.tm_year = year; 1073 | 1074 | return_11part_tm(aTHX_ SP, &mytm); 1075 | return; 1076 | 1077 | void 1078 | _crt_localtime(time_t sec) 1079 | ALIAS: 1080 | _crt_gmtime = 1 1081 | PREINIT: 1082 | struct tm mytm; 1083 | PPCODE: 1084 | if(ix) mytm = *gmtime(&sec); 1085 | else mytm = *localtime(&sec); 1086 | /* Need to get: $s,$n,$h,$d,$m,$y */ 1087 | 1088 | EXTEND(SP, 10); 1089 | SP = push_common_tm(aTHX_ SP, &mytm); 1090 | PUSHs(newSViv(mytm.tm_isdst)); 1091 | PUTBACK; 1092 | { 1093 | SV ** endsp = SP; /* the SV * under SP needs to be mortaled */ 1094 | SP -= (10 - 1); /* subtract 0 based count of SVs to mortal */ 1095 | /* mortal target of SP, then increment before function call 1096 | so SP is already calculated before next comparison to not stall CPU */ 1097 | do { 1098 | sv_2mortal(*SP++); 1099 | } while(SP <= endsp); 1100 | } 1101 | return; 1102 | 1103 | SV* 1104 | _get_localization() 1105 | INIT: 1106 | HV* locales = newHV(); 1107 | AV* wdays = newAV(); 1108 | AV* weekdays = newAV(); 1109 | AV* mons = newAV(); 1110 | AV* months = newAV(); 1111 | SV** tmp; 1112 | size_t len; 1113 | char buf[TP_BUF_SIZE]; 1114 | size_t i; 1115 | time_t t = 1325386800; /*1325386800 = Sun, 01 Jan 2012 03:00:00 GMT*/ 1116 | struct tm mytm = *gmtime(&t); 1117 | CODE: 1118 | 1119 | for(i = 0; i < 7; ++i){ 1120 | 1121 | len = strftime(buf, TP_BUF_SIZE, "%a", &mytm); 1122 | av_push(wdays, (SV *) newSVpvn(buf, len)); 1123 | 1124 | len = strftime(buf, TP_BUF_SIZE, "%A", &mytm); 1125 | av_push(weekdays, (SV *) newSVpvn(buf, len)); 1126 | 1127 | ++mytm.tm_wday; 1128 | } 1129 | 1130 | for(i = 0; i < 12; ++i){ 1131 | 1132 | len = strftime(buf, TP_BUF_SIZE, "%b", &mytm); 1133 | av_push(mons, (SV *) newSVpvn(buf, len)); 1134 | 1135 | len = strftime(buf, TP_BUF_SIZE, "%B", &mytm); 1136 | av_push(months, (SV *) newSVpvn(buf, len)); 1137 | 1138 | ++mytm.tm_mon; 1139 | } 1140 | 1141 | tmp = hv_store(locales, "wday", 4, newRV_noinc((SV *) wdays), 0); 1142 | tmp = hv_store(locales, "weekday", 7, newRV_noinc((SV *) weekdays), 0); 1143 | tmp = hv_store(locales, "mon", 3, newRV_noinc((SV *) mons), 0); 1144 | tmp = hv_store(locales, "month", 5, newRV_noinc((SV *) months), 0); 1145 | tmp = hv_store(locales, "alt_month", 9, newRV((SV *) months), 0); 1146 | 1147 | len = strftime(buf, TP_BUF_SIZE, "%p", &mytm); 1148 | tmp = hv_store(locales, "AM", 2, newSVpvn(buf,len), 0); 1149 | len = strftime(buf, TP_BUF_SIZE, "%P", &mytm); 1150 | tmp = hv_store(locales, "am", 2, newSVpvn(buf,len), 0); 1151 | mytm.tm_hour = 18; 1152 | len = strftime(buf, TP_BUF_SIZE, "%p", &mytm); 1153 | tmp = hv_store(locales, "PM", 2, newSVpvn(buf,len), 0); 1154 | len = strftime(buf, TP_BUF_SIZE, "%P", &mytm); 1155 | tmp = hv_store(locales, "pm", 2, newSVpvn(buf,len), 0); 1156 | 1157 | if(tmp == NULL || !SvOK( (SV *) *tmp)){ 1158 | croak("Failed to get localization."); 1159 | } 1160 | 1161 | RETVAL = newRV_noinc((SV *)locales); 1162 | OUTPUT: 1163 | RETVAL 1164 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Time::Piece 2 | 3 | [![CI Tests](https://github.com/Dual-Life/Time-Piece/actions/workflows/ci.yml/badge.svg?branch=master)](https://github.com/Dual-Life/Time-Piece/actions) 4 | 5 | A Perl module that replaces the standard `localtime` and `gmtime` functions with implementations that return objects. 6 | 7 | ## Documentation 8 | 9 | # NAME 10 | 11 | Time::Piece - Object Oriented time objects 12 | 13 | # SYNOPSIS 14 | 15 | use Time::Piece; 16 | 17 | my $t = localtime; 18 | print "Time is $t\n"; 19 | print "Year is ", $t->year, "\n"; 20 | 21 | # DESCRIPTION 22 | 23 | This module replaces the standard `localtime` and `gmtime` functions with 24 | implementations that return objects. It does so in a backwards 25 | compatible manner, so that using localtime/gmtime in the way documented 26 | in perlfunc will still return what you expect. 27 | 28 | The module actually implements most of an interface described by 29 | Larry Wall on the perl5-porters mailing list here: 30 | [https://www.nntp.perl.org/group/perl.perl5.porters/2000/01/msg5283.html](https://www.nntp.perl.org/group/perl.perl5.porters/2000/01/msg5283.html) 31 | 32 | # USAGE 33 | 34 | After importing this module, when you use localtime or gmtime in a scalar 35 | context, rather than getting an ordinary scalar string representing the 36 | date and time, you get a Time::Piece object, whose stringification happens 37 | to produce the same effect as the localtime and gmtime functions. There is 38 | also a new() constructor provided, which is the same as localtime(), except 39 | when passed a Time::Piece object, in which case it's a copy constructor. The 40 | following methods are available on the object: 41 | 42 | $t->sec # also available as $t->second 43 | $t->min # also available as $t->minute 44 | $t->hour # 24 hour 45 | $t->mday # also available as $t->day_of_month 46 | $t->mon # 1 = January 47 | $t->_mon # 0 = January 48 | $t->monname # Feb 49 | $t->month # same as $t->monname 50 | $t->fullmonth # February 51 | $t->year # based at 0 (year 0 AD is, of course 1 BC) 52 | $t->_year # year minus 1900 53 | $t->yy # 2 digit year 54 | $t->wday # 1 = Sunday 55 | $t->_wday # 0 = Sunday 56 | $t->day_of_week # 0 = Sunday 57 | $t->wdayname # Tue 58 | $t->day # same as wdayname 59 | $t->fullday # Tuesday 60 | $t->yday # also available as $t->day_of_year, 0 = Jan 01 61 | $t->isdst # also available as $t->daylight_savings 62 | 63 | $t->hms # 12:34:56 64 | $t->hms(".") # 12.34.56 65 | $t->time # same as $t->hms 66 | 67 | $t->ymd # 2000-02-29 68 | $t->date # same as $t->ymd 69 | $t->mdy # 02-29-2000 70 | $t->mdy("/") # 02/29/2000 71 | $t->dmy # 29-02-2000 72 | $t->dmy(".") # 29.02.2000 73 | $t->datetime # 2000-02-29T12:34:56 (ISO 8601) 74 | $t->cdate # Tue Feb 29 12:34:56 2000 75 | "$t" # same as $t->cdate 76 | 77 | $t->epoch # seconds since the epoch 78 | $t->tzoffset # timezone offset in a Time::Seconds object 79 | 80 | $t->julian_day # number of days since Julian period began 81 | $t->mjd # modified Julian date (JD-2400000.5 days) 82 | 83 | $t->week # week number (ISO 8601) 84 | 85 | $t->is_leap_year # true if it's a leap year 86 | $t->month_last_day # 28-31 87 | 88 | $t->time_separator($s) # set the default separator (default ":") 89 | $t->date_separator($s) # set the default separator (default "-") 90 | $t->day_list(@days) # set the default weekdays 91 | $t->mon_list(@days) # set the default months 92 | 93 | $t->strftime(FORMAT) # same as POSIX::strftime (without the overhead 94 | # of the full POSIX extension) 95 | $t->strftime() # "Tue, 29 Feb 2000 12:34:56 GMT" 96 | 97 | Time::Piece->strptime(STRING, FORMAT) 98 | # see strptime man page. Creates a new 99 | # Time::Piece object 100 | 101 | Note that `localtime` and `gmtime` are not listed above. If called as 102 | methods on a Time::Piece object, they act as constructors, returning a new 103 | Time::Piece object for the current time. In other words: they're not useful as 104 | methods. 105 | 106 | ## Local Locales 107 | 108 | Both wdayname (day) and monname (month) allow passing in a list to use 109 | to index the name of the days against. This can be useful if you need 110 | to implement some form of localisation without actually installing or 111 | using locales. Note that this is a global override and will affect 112 | all Time::Piece instances. 113 | 114 | my @days = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi ); 115 | 116 | my $french_day = localtime->day(@days); 117 | 118 | These settings can be overridden globally too: 119 | 120 | Time::Piece::day_list(@days); 121 | 122 | Or for months: 123 | 124 | Time::Piece::mon_list(@months); 125 | 126 | And locally for months: 127 | 128 | print localtime->month(@months); 129 | 130 | Or to populate with your current system locale call: 131 | Time::Piece->use\_locale(); 132 | 133 | ## Date Calculations 134 | 135 | It's possible to use simple addition and subtraction of objects: 136 | 137 | use Time::Seconds; 138 | 139 | my $seconds = $t1 - $t2; 140 | $t1 += ONE_DAY; # add 1 day (constant from Time::Seconds) 141 | 142 | The following are valid ($t1 and $t2 are Time::Piece objects): 143 | 144 | $t1 - $t2; # returns Time::Seconds object 145 | $t1 - 42; # returns Time::Piece object 146 | $t1 + 533; # returns Time::Piece object 147 | 148 | However adding a Time::Piece object to another Time::Piece object 149 | will cause a runtime error. 150 | 151 | Note that the first of the above returns a Time::Seconds object, so 152 | while examining the object will print the number of seconds (because 153 | of the overloading), you can also get the number of minutes, hours, 154 | days, weeks and years in that delta, using the Time::Seconds API. 155 | 156 | In addition to adding seconds, there are two APIs for adding months and 157 | years: 158 | 159 | $t = $t->add_months(6); 160 | $t = $t->add_years(5); 161 | 162 | The months and years can be negative for subtractions. Note that there 163 | is some "strange" behaviour when adding and subtracting months at the 164 | ends of months. Generally when the resulting month is shorter than the 165 | starting month then the number of overlap days is added. For example 166 | subtracting a month from 2008-03-31 will not result in 2008-02-31 as this 167 | is an impossible date. Instead you will get 2008-03-02. This appears to 168 | be consistent with other date manipulation tools. 169 | 170 | ## Truncation 171 | 172 | Calling the `truncate` method returns a copy of the object but with the 173 | time truncated to the start of the supplied unit. 174 | 175 | $t = $t->truncate(to => 'day'); 176 | 177 | This example will set the time to midnight on the same date which `$t` 178 | had previously. Allowed values for the "to" parameter are: "year", 179 | "quarter", "month", "day", "hour", "minute" and "second". 180 | 181 | ## Date Comparisons 182 | 183 | Date comparisons are also possible, using the full suite of "<", ">", 184 | "<=", ">=", "<=>", "==" and "!=". 185 | 186 | ## Date Parsing 187 | 188 | Time::Piece has a built-in strptime() function (from FreeBSD), allowing 189 | you incredibly flexible date parsing routines. For example: 190 | 191 | my $t = Time::Piece->strptime("Sunday 3rd Nov, 1943", 192 | "%A %drd %b, %Y"); 193 | 194 | print $t->strftime("%a, %d %b %Y"); 195 | 196 | Outputs: 197 | 198 | Wed, 03 Nov 1943 199 | 200 | (see, it's even smart enough to fix my obvious date bug) 201 | 202 | For more information see "man strptime", which should be on all unix 203 | systems. 204 | 205 | Alternatively look here: [http://www.unix.com/man-page/FreeBSD/3/strftime/](http://www.unix.com/man-page/FreeBSD/3/strftime/) 206 | 207 | ### CAVEAT %A, %a, %B, %b, and friends 208 | 209 | Time::Piece::strptime by default can only parse American English date names. 210 | Meanwhile, Time::Piece->strftime() will return date names that use the current 211 | configured system locale. This means dates returned by strftime might not be 212 | able to be parsed by strptime. This is the default behavior and can be 213 | overridden by calling Time::Piece->use\_locale(). This builds a list of the 214 | current locale's day and month names which strptime will use to parse with. 215 | Note this is a global override and will affect all Time::Piece instances. 216 | 217 | For instance with a German locale: 218 | 219 | localtime->day_list(); 220 | 221 | Returns 222 | 223 | ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' ) 224 | 225 | While: 226 | 227 | Time::Piece->use_locale(); 228 | localtime->day_list(); 229 | 230 | Returns 231 | 232 | ( 'So', 'Mo', 'Di', 'Mi', 'Do', 'Fr', 'Sa' ) 233 | 234 | ## YYYY-MM-DDThh:mm:ss 235 | 236 | The ISO 8601 standard defines the date format to be YYYY-MM-DD, and 237 | the time format to be hh:mm:ss (24 hour clock), and if combined, they 238 | should be concatenated with date first and with a capital 'T' in front 239 | of the time. 240 | 241 | ## Week Number 242 | 243 | The _week number_ may be an unknown concept to some readers. The ISO 244 | 8601 standard defines that weeks begin on a Monday and week 1 of the 245 | year is the week that includes both January 4th and the first Thursday 246 | of the year. In other words, if the first Monday of January is the 247 | 2nd, 3rd, or 4th, the preceding days of the January are part of the 248 | last week of the preceding year. Week numbers range from 1 to 53. 249 | 250 | ## Global Overriding 251 | 252 | Finally, it's possible to override localtime and gmtime everywhere, by 253 | including the ':override' tag in the import list: 254 | 255 | use Time::Piece ':override'; 256 | 257 | # CAVEATS 258 | 259 | ## Setting $ENV{TZ} in Threads on Win32 260 | 261 | Note that when using perl in the default build configuration on Win32 262 | (specifically, when perl is built with PERL\_IMPLICIT\_SYS), each perl 263 | interpreter maintains its own copy of the environment and only the main 264 | interpreter will update the process environment seen by strftime. 265 | 266 | Therefore, if you make changes to $ENV{TZ} from inside a thread other than 267 | the main thread then those changes will not be seen by strftime if you 268 | subsequently call that with the %Z formatting code. You must change $ENV{TZ} 269 | in the main thread to have the desired effect in this case (and you must 270 | also call \_tzset() in the main thread to register the environment change). 271 | 272 | Furthermore, remember that this caveat also applies to fork(), which is 273 | emulated by threads on Win32. 274 | 275 | ## Use of epoch seconds 276 | 277 | This module internally uses the epoch seconds system that is provided via 278 | the perl `time()` function and supported by `gmtime()` and `localtime()`. 279 | 280 | If your perl does not support times larger than `2^31` seconds then this 281 | module is likely to fail at processing dates beyond the year 2038. There are 282 | moves afoot to fix that in perl. Alternatively use 64 bit perl. Or if none 283 | of those are options, use the [DateTime](https://metacpan.org/pod/DateTime) module which has support for years 284 | well into the future and past. 285 | 286 | Also, the internal representation of Time::Piece->strftime deviates from the 287 | standard POSIX implementation in that is uses the epoch (instead of separate 288 | year, month, day parts). This change was added in version 1.30. If you must 289 | have a more traditional strftime (which will normally never calculate day 290 | light saving times correctly), you can pass the date parts from Time::Piece 291 | into the strftime function provided by the POSIX module 292 | (see strftime in [POSIX](https://metacpan.org/pod/POSIX) ). 293 | 294 | # AUTHOR 295 | 296 | Matt Sergeant, matt@sergeant.org 297 | Jarkko Hietaniemi, jhi@iki.fi (while creating Time::Piece for core perl) 298 | 299 | # COPYRIGHT AND LICENSE 300 | 301 | Copyright 2001, Larry Wall. 302 | 303 | This module is free software, you may distribute it under the same terms 304 | as Perl. 305 | 306 | # SEE ALSO 307 | 308 | The excellent Calendar FAQ at [http://www.tondering.dk/claus/calendar.html](http://www.tondering.dk/claus/calendar.html) 309 | 310 | # BUGS 311 | 312 | The test harness leaves much to be desired. Patches welcome. 313 | 314 | ## Development Instructions 315 | 316 | The module uses GitHub Actions for continuous integration testing across multiple platforms. 317 | 318 | ### Using Feature Branches 319 | 320 | For development and testing: 321 | 322 | 1. **Setup Git Hooks**: 323 | ```bash 324 | ./setup-hooks.sh 325 | ``` 326 | 327 | 2. **Create a feature branch**: 328 | ```bash 329 | git checkout -b feature/windows-fix 330 | ``` 331 | 332 | You can create any descriptive name after the `feature/` prefix: 333 | ```bash 334 | git checkout -b feature/memory-optimization 335 | git checkout -b feature/strawberry-perl-compatibility 336 | ``` 337 | 338 | 3. **Make your changes and commit them**: 339 | ```bash 340 | # Make changes to your code 341 | git add . 342 | git commit -m "Implement Windows-specific fixes" 343 | ``` 344 | 345 | 4. **Push to GitHub to trigger automatic tests**: 346 | ```bash 347 | git push origin feature/windows-fix 348 | ``` 349 | 350 | 5. **Delete once merge done**: 351 | ```bash 352 | # Delete locally 353 | git branch -D feature/windows-fix 354 | 355 | # Delete from GitHub 356 | git push origin --delete feature/windows-fix 357 | ``` 358 | 359 | ## Installation 360 | 361 | From CPAN: 362 | 363 | ``` 364 | cpan Time::Piece 365 | ``` 366 | 367 | From source: 368 | 369 | ``` 370 | perl Makefile.PL 371 | make 372 | make test 373 | make install 374 | ``` -------------------------------------------------------------------------------- /Seconds.pm: -------------------------------------------------------------------------------- 1 | package Time::Seconds; 2 | use strict; 3 | 4 | our $VERSION = '1.36'; 5 | 6 | use Exporter 5.57 'import'; 7 | 8 | our @EXPORT = qw( 9 | ONE_MINUTE 10 | ONE_HOUR 11 | ONE_DAY 12 | ONE_WEEK 13 | ONE_MONTH 14 | ONE_YEAR 15 | ONE_FINANCIAL_MONTH 16 | LEAP_YEAR 17 | NON_LEAP_YEAR 18 | ); 19 | 20 | our @EXPORT_OK = qw(cs_sec cs_mon); 21 | 22 | use constant { 23 | ONE_MINUTE => 60, 24 | ONE_HOUR => 3_600, 25 | ONE_DAY => 86_400, 26 | ONE_WEEK => 604_800, 27 | ONE_MONTH => 2_629_744, # ONE_YEAR / 12 28 | ONE_YEAR => 31_556_930, # 365.24225 days 29 | ONE_FINANCIAL_MONTH => 2_592_000, # 30 days 30 | LEAP_YEAR => 31_622_400, # 366 * ONE_DAY 31 | NON_LEAP_YEAR => 31_536_000, # 365 * ONE_DAY 32 | # hacks to make Time::Piece compile once again 33 | cs_sec => 0, 34 | cs_mon => 1, 35 | }; 36 | 37 | use overload 38 | 'fallback' => 'undef', 39 | '0+' => \&seconds, 40 | '""' => \&seconds, 41 | '<=>' => \&compare, 42 | '+' => \&add, 43 | '-' => \&subtract, 44 | '-=' => \&subtract_from, 45 | '+=' => \&add_to, 46 | '=' => \© 47 | 48 | sub new { 49 | my $class = shift; 50 | my ($val) = @_; 51 | $val = 0 unless defined $val; 52 | bless \$val, $class; 53 | } 54 | 55 | sub _get_ovlvals { 56 | my ($lhs, $rhs, $reverse) = @_; 57 | $lhs = $lhs->seconds; 58 | 59 | if (UNIVERSAL::isa($rhs, 'Time::Seconds')) { 60 | $rhs = $rhs->seconds; 61 | } 62 | elsif (ref($rhs)) { 63 | die "Can't use non Seconds object in operator overload"; 64 | } 65 | 66 | if ($reverse) { 67 | return $rhs, $lhs; 68 | } 69 | 70 | return $lhs, $rhs; 71 | } 72 | 73 | sub compare { 74 | my ($lhs, $rhs) = _get_ovlvals(@_); 75 | return $lhs <=> $rhs; 76 | } 77 | 78 | sub add { 79 | my ($lhs, $rhs) = _get_ovlvals(@_); 80 | return Time::Seconds->new($lhs + $rhs); 81 | } 82 | 83 | sub add_to { 84 | my $lhs = shift; 85 | my $rhs = shift; 86 | $rhs = $rhs->seconds if UNIVERSAL::isa($rhs, 'Time::Seconds'); 87 | $$lhs += $rhs; 88 | return $lhs; 89 | } 90 | 91 | sub subtract { 92 | my ($lhs, $rhs) = _get_ovlvals(@_); 93 | return Time::Seconds->new($lhs - $rhs); 94 | } 95 | 96 | sub subtract_from { 97 | my $lhs = shift; 98 | my $rhs = shift; 99 | $rhs = $rhs->seconds if UNIVERSAL::isa($rhs, 'Time::Seconds'); 100 | $$lhs -= $rhs; 101 | return $lhs; 102 | } 103 | 104 | sub copy { 105 | Time::Seconds->new(${$_[0]}); 106 | } 107 | 108 | sub seconds { 109 | my $s = shift; 110 | return $$s; 111 | } 112 | 113 | sub minutes { 114 | my $s = shift; 115 | return $$s / 60; 116 | } 117 | 118 | sub hours { 119 | my $s = shift; 120 | $s->minutes / 60; 121 | } 122 | 123 | sub days { 124 | my $s = shift; 125 | $s->hours / 24; 126 | } 127 | 128 | sub weeks { 129 | my $s = shift; 130 | $s->days / 7; 131 | } 132 | 133 | sub months { 134 | my $s = shift; 135 | $s->days / 30.4368541; 136 | } 137 | 138 | sub financial_months { 139 | my $s = shift; 140 | $s->days / 30; 141 | } 142 | 143 | sub years { 144 | my $s = shift; 145 | $s->days / 365.24225; 146 | } 147 | 148 | sub _counted_objects { 149 | my ($n, $counted) = @_; 150 | my $number = sprintf("%d", $n); # does a "floor" 151 | $counted .= 's' if 1 != $number; 152 | return ($number, $counted); 153 | } 154 | 155 | sub pretty { 156 | my $s = shift; 157 | my $str = ""; 158 | if ($s < 0) { 159 | $s = -$s; 160 | $str = "minus "; 161 | } 162 | if ($s >= ONE_MINUTE) { 163 | if ($s >= ONE_HOUR) { 164 | if ($s >= ONE_DAY) { 165 | my ($days, $sd) = _counted_objects($s->days, "day"); 166 | $str .= "$days $sd, "; 167 | $s -= ($days * ONE_DAY); 168 | } 169 | my ($hours, $sh) = _counted_objects($s->hours, "hour"); 170 | $str .= "$hours $sh, "; 171 | $s -= ($hours * ONE_HOUR); 172 | } 173 | my ($mins, $sm) = _counted_objects($s->minutes, "minute"); 174 | $str .= "$mins $sm, "; 175 | $s -= ($mins * ONE_MINUTE); 176 | } 177 | $str .= join " ", _counted_objects($s->seconds, "second"); 178 | return $str; 179 | } 180 | 181 | 1; 182 | __END__ 183 | 184 | =encoding utf8 185 | 186 | =head1 NAME 187 | 188 | Time::Seconds - a simple API to convert seconds to other date values 189 | 190 | =head1 SYNOPSIS 191 | 192 | use Time::Piece; 193 | use Time::Seconds; 194 | 195 | my $t = localtime; 196 | $t += ONE_DAY; 197 | 198 | my $t2 = localtime; 199 | my $s = $t - $t2; 200 | 201 | print "Difference is: ", $s->days, "\n"; 202 | 203 | =head1 DESCRIPTION 204 | 205 | This module is part of the Time::Piece distribution. It allows the user 206 | to find out the number of minutes, hours, days, weeks or years in a given 207 | number of seconds. It is returned by Time::Piece when you delta two 208 | Time::Piece objects. 209 | 210 | Time::Seconds also exports the following constants: 211 | 212 | ONE_DAY 213 | ONE_WEEK 214 | ONE_HOUR 215 | ONE_MINUTE 216 | ONE_MONTH 217 | ONE_YEAR 218 | ONE_FINANCIAL_MONTH 219 | LEAP_YEAR 220 | NON_LEAP_YEAR 221 | 222 | Since perl does not (yet?) support constant objects, these constants are in 223 | seconds only, so you cannot, for example, do this: Cminutes;> 224 | 225 | =head1 METHODS 226 | 227 | The following methods are available: 228 | 229 | my $val = Time::Seconds->new(SECONDS) 230 | $val->seconds; 231 | $val->minutes; 232 | $val->hours; 233 | $val->days; 234 | $val->weeks; 235 | $val->months; 236 | $val->financial_months; # 30 days 237 | $val->years; 238 | $val->pretty; # gives English representation of the delta 239 | 240 | The usual arithmetic (+,-,+=,-=) is also available on the objects. 241 | 242 | The methods make the assumption that there are 24 hours in a day, 7 days in 243 | a week, 365.24225 days in a year and 12 months in a year. 244 | (from The Calendar FAQ at http://www.tondering.dk/claus/calendar.html) 245 | 246 | =head1 AUTHOR 247 | 248 | Matt Sergeant, matt@sergeant.org 249 | 250 | Tobias Brox, tobiasb@tobiasb.funcom.com 251 | 252 | Balázs Szabó (dLux), dlux@kapu.hu 253 | 254 | =head1 COPYRIGHT AND LICENSE 255 | 256 | Copyright 2001, Larry Wall. 257 | 258 | This module is free software, you may distribute it under the same terms 259 | as Perl. 260 | 261 | =head1 Bugs 262 | 263 | Currently the methods aren't as efficient as they could be, for reasons of 264 | clarity. This is probably a bad idea. 265 | 266 | =cut 267 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - test tzoffset 2 | - make more tests (see Devel::Cover) 3 | - clean up xs 4 | - test strptime with '%z' and '%Z' 5 | - timegm(@tm_parts) to get ephoch, then CORE::localtime($epoch) to return right parts 6 | - or return 'needs convert' flag, get epoch from GMT parts, then get parts from localtime() 7 | - allow cdate() to print as different formats 8 | - Document format flags that don't work everywhere (see comments in *.t files) 9 | - Every "return 0" in the strptime case statement in Piece.xs needs to be preceded by a useful error statement 10 | - Check for int and size_t mismatches (like from strlen()) 11 | - _C_time_locale should only get populated when really needed 12 | - use macros or something to get all the strlen stuff out of xs hash fetches 13 | - make sure changing class vars effects all instances 14 | - add better %V support, newer versions of libc seem to have it: 15 | https://opensource.apple.com/source/Libc/Libc-1158.20.4/stdtime/FreeBSD/strptime.c.auto.html 16 | 17 | for population of c_epoch (https://rt.cpan.org/Ticket/Display.html?id=118927) 18 | was done because of ephoch call for strftime change: 19 | 20 | - return _strftime($format, (@$time)[c_sec..c_isdst]); 21 | + 22 | + return _strftime($format, $time->epoch, $time->[c_islocal]); 23 | 24 | causes state change and test suites that called is_deeply would see the change and fail. 25 | so figure out how timelocal(@time_parts) gets ephoch and just move that into c perhaps. 26 | (well that is not going to be so easy... so perhaps just change it back to old behavior and see what breaks on cpan) 27 | (( perhaps check first if c_epoch is defined, if not just call timelocle and not set c_epoch)) 28 | 29 | Document Time::Piece limits: 30 | dates before 1970 31 | strptime doesn't really handle %z %Z or %V 32 | add_months calls _mini_maketm which only uses gmtime, probably wrong 33 | strftime doesn't really handle %s right since it calls system mktime with wrong parameters if given a tm struct built from gmtime (fixed?) 34 | uses epoch everywhere so don't try to calculate stuff before 1970 35 | mktime docs even state it is only for localtime (gets used for stuff from gmtime sometimes) 36 | TP is guaranteed to parse stuff that is returned from strftime, not so much any other random time string 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | on 'test' => sub { 2 | requires 'Test::More', '0.96'; 3 | }; 4 | -------------------------------------------------------------------------------- /rev_deps.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use HTTP::Tiny; 4 | use JSON; 5 | use Data::Dumper; 6 | use Time::Piece; #of course 7 | use MetaCPAN::Client; 8 | 9 | #search cpan for any module that mentions "Time::Piece" 10 | 11 | my $i = 1; 12 | my @total_dists = (); 13 | my @skipped = (); 14 | my $too_old = localtime->strptime( "2011-01-01", "%Y-%m-%d" ); 15 | my $meta = MetaCPAN::Client->new(); 16 | 17 | 18 | while ( 19 | my $response = HTTP::Tiny->new->get( 20 | "https://grep.metacpan.org/api/search?p=$i&q=Time%3A%3APiece&qls=on") 21 | ) 22 | { 23 | ++$i; 24 | die "Failed!\n" unless $response->{success}; 25 | 26 | my $j; 27 | 28 | if ( length $response->{content} ) { 29 | $j = from_json( $response->{content} ); 30 | 31 | } 32 | 33 | unless ( @{ $j->{results} } > 1 ) { 34 | warn "no results from:\n" . Dumper $j; 35 | last; 36 | } 37 | 38 | print "Got " . scalar @{ $j->{results} } . "\n"; 39 | 40 | foreach my $raw_dist ( @{ $j->{results} } ) { 41 | my $dist_date; 42 | my $release; 43 | eval { 44 | $dist_date = localtime->strptime( $meta->release( $raw_dist->{distro} )->date(), 45 | "%Y-%m-%dT%H:%M:%S" ); 46 | }; 47 | 48 | if($@){ 49 | push( @skipped, "$raw_dist->{distro} -" . (split(/\n/, $@))[0] ); 50 | next; 51 | } 52 | 53 | #skip bundled stuff 54 | if ( $raw_dist->{distro} =~ /task|belike/i ) { 55 | push( @skipped, $raw_dist->{distro} ); 56 | next; 57 | } 58 | #or too old 59 | if ( $dist_date < $too_old ) { 60 | push( @skipped, "$raw_dist->{distro} - $dist_date" ); 61 | next; 62 | } 63 | 64 | $raw_dist->{distro} =~ s/-/::/g; 65 | push( @total_dists, $raw_dist->{distro} ); 66 | } 67 | print "total_dists size is now: " . scalar @total_dists . "\n"; 68 | print "Fetching page #$i\n"; 69 | } 70 | 71 | print "\n\nSkipped dists:\n\n"; 72 | foreach my $dist (@skipped) { 73 | print "$dist\n"; 74 | } 75 | 76 | print "\n\nDep dists:\n\n"; 77 | foreach my $dist (@total_dists) { 78 | print "$dist\n"; 79 | } 80 | -------------------------------------------------------------------------------- /reverse_deps.txt: -------------------------------------------------------------------------------- 1 | #These modules depend on Time::Piece. 2 | #You should probably make sure you don't break their 3 | #test cases since they do no telling what with Time::Piece. 4 | #generated by App::ListRevDeps and rev_deps.pl 5 | #needed libs for compiling: 6 | #libxml2-dev libgd-dev uuid-dev libmariadb-dev-compat 7 | #and don't forget PERL_USE_UNSAFE_INC 8 | Acme::CPANAuthors::Japanese 9 | #Acme::Hidek #fails on perl 5.26+ 10 | Acme::Honkidasu 11 | Acme::PrettyCure 12 | Acme::ReturnValue 13 | Acme::Songmu 14 | Ado 15 | Algorithm::Diff::HTMLTable 16 | Amazon::SES 17 | Amon2 18 | AnyEvent::Twitter 19 | #Apache::AxKit::Provider::XMLDOMProvider requires mod_perl: 20 | App::authkeymgr 21 | App::BarnesNoble::WishListMinder 22 | App::BigQuery::Importer::MySQL 23 | #App::BoolFindGrep random failing tests 24 | #App::Chart #bunch of failing deps 25 | App::CPAN::Fresh 26 | App::Dochazka::Common 27 | #App::DualLivedList 28 | App::githook_perltidy 29 | App::Git::Workflow 30 | #App::KGB don't build but doesn't test TP anyway 31 | App::Koyomi 32 | #App::Metabase::Relayd::Plugin::IRC #needs ssl deps (or something) 33 | App::mgen 34 | App::MtAws 35 | App::Munner 36 | #App::Netdisco #needs snmp deps 37 | App::optex 38 | App::OTRS::CreateTicket 39 | App::RunCron 40 | App::scrape 41 | App::TLSMe 42 | App::tt 43 | App::Ylastic::CostAgent 44 | App::YTDL 45 | Armadito::Agent 46 | Astro::Catalog 47 | Astro::Coords 48 | Astro::FITS::HdrTrans 49 | #Astro::SolarParallax #old 50 | Astro::Sunrise 51 | #AxKit::App::TABOO #old 52 | Beam::Emitter 53 | Bencher::Scenarios::DateModules 54 | #Bio::AutomatedAnnotation #lots of failures 55 | Bio::CIPRES 56 | Bootylicious 57 | #Bot::BasicBot::Pluggable::Module::Notes #fails perl 5.26+ 58 | #Bundle::DadaMail 59 | #Bundle::DadaMailXXL 60 | #Bundle::Everything 61 | #Bundle::FinalTest 62 | Business::FedEx::RateRequest 63 | Business::PL::PESEL 64 | Calendar::List 65 | Catalyst::Plugin::File::RotateLogs 66 | Catalyst::Plugin::Log::Dispatch 67 | Catmandu 68 | CA::WAAE 69 | CGI::Application::Search 70 | CGI::Untaint::datetime 71 | #CGI::Wiki #old 72 | #CGI::Wiki::Kwiki #old 73 | Chef::Knife::Cmd 74 | Class::DBI::Plugin::Calendar 75 | Class::DBI::Plugin::TimePiece 76 | Class::Usul 77 | #Convos #old 78 | Cpanel::JSON::XS 79 | #CPAN::Testers::Data::Generator #needs ssl libs 80 | CPAN::Testers::Data::Uploads::Mailer 81 | #CPAN::Testers::WWW::Admin # needs Image::Magick deps 82 | CPAN::Testers::WWW::Reports::Mailer 83 | CPAN::Testers::WWW::Statistics 84 | Crypt::LE 85 | Cv 86 | Dancer::Plugin::Log::DB 87 | #Dancer::SearchApp #needs Elasticsearch 88 | Data::Beacon 89 | Data::Fake 90 | Data::Google::Visualization::DataTable 91 | Data::Random 92 | Data::Sah 93 | Data::XLSX::Parser 94 | Date::Advent 95 | Date::Easy 96 | Date::Holidays::BY 97 | Date::Holidays::KZ 98 | Date::Holidays::RU 99 | Date::Lectionary 100 | Date::Lectionary::Daily 101 | Date::Lectionary::Time 102 | #Date::Piece #failing tests 103 | Date::Range 104 | #old but leave for now 105 | Date::Simple::Range 106 | DateTime 107 | DateTime::Calendar::FrenchRevolutionary 108 | #DateTimeX::Lite #fails on perl 5.26+ 109 | DateTimeX::Moment 110 | Date::Utility 111 | DBI::Easy 112 | DBIx::BulkUtil 113 | DBIx::Class 114 | DBIx::Class::Validation::Structure 115 | DBIx::Custom 116 | DBIx::Schema::Changelog 117 | #DBIx::Skinny::ProxyTable #failing tests 118 | Device::LaCrosse::WS23xx 119 | Email::Date 120 | Email::Folder 121 | Email::FolderType 122 | Email::Store 123 | Enbld 124 | ETLp 125 | Exception::Chain 126 | File::Rotate::Simple 127 | File::RsyBak 128 | #File::SAUCE #old 129 | Finance::Quote 130 | Finance::Robinhood 131 | Flower 132 | Fluent::AgentLite 133 | Fluent::Logger 134 | FormValidator::Simple::Struct 135 | #FusionInventory::Agent #failing tests 136 | Gentoo::Util::VirtualDepend 137 | Git::TagVersion 138 | GrowthForecast 139 | Haineko 140 | HeliosX::Logger::HiRes 141 | HON::EC2::Snapshots::Monitoring 142 | HTTP::Headers::ActionPack 143 | ICC::Profile 144 | IkuSan 145 | Image::ExifTool 146 | Katsubushi::Client 147 | Labyrinth::Plugin::Survey 148 | #Linux::AtaSmart 149 | #Linux::GetPidstat 150 | Log::Dispatch::Config 151 | Log::Dispatch::Pipe 152 | Log::Dump 153 | Log::File::Rolling 154 | Log::LTSV::Instance 155 | Log::Saftpresse 156 | Mail::File 157 | #Mail::MtPolicyd 158 | #Makefile::Parallel #needs GraphViz deps 159 | Marpa::R2 160 | MarpaX::ESLIF 161 | Mercury 162 | Metabase::Fact 163 | Minilla 164 | Minion::Backend::mysql 165 | Module::CoreList 166 | Module::CPANTS::Analyse 167 | Module::Depends 168 | Module::New 169 | Module::Starter::Plugin::CGIApp 170 | Mojolicious 171 | Mojolicious::Plugin::AdditionalValidationChecks 172 | Mojolicious::Plugin::I18NUtils 173 | Mojo::Log::More 174 | Mojo::Webqq 175 | Mojo::WebService::Twitter 176 | Mojo::Weixin 177 | Mojo::XMLRPC 178 | MooseX::Types::Time::Piece 179 | Net::Amazon::DynamoDB::Lite 180 | Net::Amazon::S3 181 | Net::Amazon::Signature::V4 182 | #Net::AWS::SES 183 | Net::Domain::ExpireDate 184 | #Net::DSLProvider #failing tests 185 | Net::Trustico 186 | Nginx::Log::Entry 187 | #OpenGuides 188 | OS::Package 189 | OTRS::OPM::Installer 190 | OTRS::OPM::Maker::Command::changes 191 | OTRS::SphinxSearch 192 | Oxford::Calendar 193 | PagerDuty::Agent 194 | #Parley #won't build, kinda old 195 | Parse::Crontab 196 | Parse::Syslog::Line 197 | PDL::DateTime 198 | #PDL::Graphics::Prima 199 | PDL::IO::CSV 200 | Perl::PrereqScanner::NotQuiteLite 201 | Plack::App::Directory::Apaxy 202 | Plack::Middleware::GitStatus 203 | Plack::Middleware::NeverExpire 204 | Plack::Middleware::TimeOverHTTP 205 | #Plack::Session::Store::RedisFast 206 | #Plucene #old 207 | #Plucene::SearchEngine 208 | #PluceneSimple 209 | #Podcast::ESLPodcast::Splitter 210 | Pod::Cpandoc::Cache 211 | POE::Component::FeedAggregator 212 | #POSIX::1003 test failures 213 | PowerTools::Data 214 | PPI::Prettify 215 | Process::Child::Leash 216 | #Project::Easy 217 | Riji 218 | Rubric 219 | Salvation::TC 220 | Script::Ichigeki 221 | #Script::Nohup 222 | #Seis 223 | #Sendmail::Queue 224 | Sentry::Raven 225 | Setup::Project 226 | Shell::Carapace 227 | Sisimai 228 | Slovo 229 | Smart::Options 230 | SMS::Send::SMSGlobal::HTTP 231 | SMS::SMS77 232 | #SPOPS #old 233 | Spp 234 | Spreadsheet::HTML 235 | stasis 236 | Statocles 237 | String::Errf 238 | String::Template 239 | SVG::Timeline 240 | Sweet::Home 241 | Tangram 242 | #Task::Amon2 243 | #Task::DualLived 244 | #Task::Litmus 245 | Teamcity::Executor 246 | Term::Choose 247 | Term::Choose_HAE 248 | Term::Choose::Util 249 | Term::Form 250 | Term::TablePrint 251 | Test2::Tools::SkipUntil 252 | Test::APIcast 253 | Test::BDD::Cucumber::Harness::Html 254 | Test::BDD::Cucumber::Harness::Nagios 255 | #Test::BDD::Infrastructure #needs Augeas deps 256 | Test::Deep::Between 257 | Test::JsonAPI::Autodoc 258 | Test::MockTime 259 | Test::Sims 260 | Test::Time::At 261 | #Text::Clevery #old 262 | Time::Ago 263 | Time::Crontab 264 | Time::dt 265 | Time::Duration::Concise::Localize 266 | Time::Format::MySQL 267 | Time::List 268 | Time::Moment::Epoch 269 | Time::Moment::Ext 270 | Time::ParseDate 271 | #old but leave for now 272 | Time::Piece::Adaptive 273 | Time::Piece::DayOfWeek 274 | Time::Piece::ISO 275 | Time::Piece::MSSQL 276 | #old but leave for now 277 | Time::Piece::MySQL 278 | Time::Piece::Over24 279 | Time::Piece::Plus 280 | Time::Piece::Range 281 | Time::Random 282 | #old but leave for now 283 | Time::Simple::Range 284 | Time::Stamp 285 | Time::Strptime 286 | Time::Vector 287 | Types::SQL 288 | Ukigumo::Client 289 | Validator::Custom 290 | VCS::Lite::Repository 291 | Web::Machine 292 | Webqq::Client 293 | WebService::Amazon::Signature 294 | WebService::ForecastIO 295 | WebService::Mailgun 296 | Webservice::Shipment 297 | Weixin::Client 298 | Wiki::Toolkit 299 | Wiki::Toolkit::Plugin::JSON 300 | Wiki::Toolkit::Store::Mediawiki 301 | WorkerManager 302 | WorldCat::API 303 | WWW::betfair 304 | WWW::CheckHTML 305 | WWW::GoKGS 306 | WWW::KGS::GameArchives 307 | WWW::Mixi::Scraper 308 | #WWW::NHKProgram::API 309 | WWW::Ohloh::API 310 | WWW::Oxontime 311 | #WWW::Plurk #old 312 | WWW::Scraper::F1 313 | WWW::Topica 314 | #WWW::UsePerl::Journal 315 | #WWW::UsePerl::Journal::Thread 316 | #Wx just no 317 | XML::Atom::SimpleFeed 318 | XML::Compile 319 | -------------------------------------------------------------------------------- /setup-hooks.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | git config core.hooksPath .githooks 3 | echo "Git hooks have been set up successfully!" 4 | echo "The pre-commit hook will automatically update README.md when Piece.pm changes." 5 | echo "Note: You need to have Pod::Markdown installed (cpanm Pod::Markdown)." 6 | -------------------------------------------------------------------------------- /t/01base.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 15; 2 | 3 | BEGIN { use_ok('Time::Piece'); } 4 | 5 | my $t = gmtime(315532800); # 00:00:00 1/1/1980 6 | 7 | isa_ok($t, 'Time::Piece', 'specific gmtime'); 8 | 9 | cmp_ok($t->year, '==', 1980, 'correct year'); 10 | 11 | cmp_ok($t->hour, '==', 0, 'correct hour'); 12 | 13 | cmp_ok($t->mon, '==', 1, 'correct mon'); 14 | 15 | my $g = gmtime; 16 | isa_ok($g, 'Time::Piece', 'current gmtime'); 17 | 18 | my $l = localtime; 19 | isa_ok($l, 'Time::Piece', 'current localtime'); 20 | 21 | #without export 22 | $g = Time::Piece::gmtime; 23 | isa_ok($g, 'Time::Piece', 'fully qualified gmtime'); 24 | 25 | $l = Time::Piece::localtime; 26 | isa_ok($l, 'Time::Piece', 'full qualified localtime'); 27 | 28 | #via new 29 | $l = Time::Piece->new(315532800); 30 | isa_ok($l, 'Time::Piece', 'custom localtime via new'); 31 | 32 | #via new again 33 | $l = $l->new(); 34 | isa_ok($l, 'Time::Piece', 'custom localtime via new again'); 35 | 36 | #via clone 37 | my $l_clone = Time::Piece->new($l); 38 | isa_ok($l, 'Time::Piece', 'custom localtime via clone'); 39 | cmp_ok("$l_clone", 'eq', "$l", 'Clones match'); 40 | 41 | #via clone with gmtime 42 | my $g_clone = Time::Piece->new($g); 43 | isa_ok($g, 'Time::Piece', 'custom gmtime via clone'); 44 | cmp_ok("$g_clone", 'eq', "$g", 'Clones match'); 45 | -------------------------------------------------------------------------------- /t/02core.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 102; 2 | 3 | my $is_qnx = ($^O eq 'qnx'); 4 | my $is_vos = ($^O eq 'vos'); 5 | 6 | use Time::Piece; 7 | use Time::Seconds; 8 | 9 | my $t = gmtime(951831296); # 2000-02-29T13:34:56 10 | 11 | is($t->sec, 56); 12 | is($t->second, 56); 13 | is($t->min, 34); 14 | is($t->minute, 34); 15 | is($t->hour, 13); 16 | is($t->mday, 29); 17 | is($t->day_of_month, 29); 18 | is($t->mon, 2); 19 | is($t->_mon, 1); 20 | is($t->year, 2000); 21 | is($t->_year, 100); 22 | is($t->yy, '00'); 23 | 24 | cmp_ok($t->wday, '==', 3); 25 | cmp_ok($t->_wday, '==', 2); 26 | cmp_ok($t->day_of_week, '==', 2); 27 | cmp_ok($t->yday, '==', 59); 28 | cmp_ok($t->day_of_year, '==', 59); 29 | 30 | # In GMT there should be no daylight savings ever. 31 | cmp_ok($t->isdst, '==', 0); 32 | cmp_ok($t->epoch, '==', 951831296); 33 | cmp_ok($t->hms, 'eq', '13:34:56'); 34 | cmp_ok($t->time, 'eq', '13:34:56'); 35 | cmp_ok($t->ymd, 'eq', '2000-02-29'); 36 | cmp_ok($t->date, 'eq', '2000-02-29'); 37 | cmp_ok($t->mdy, 'eq', '02-29-2000'); 38 | cmp_ok($t->dmy, 'eq', '29-02-2000'); 39 | cmp_ok($t->cdate, 'eq', 'Tue Feb 29 13:34:56 2000'); 40 | cmp_ok("$t", 'eq', 'Tue Feb 29 13:34:56 2000'); 41 | cmp_ok($t->datetime, 'eq','2000-02-29T13:34:56'); 42 | cmp_ok($t->daylight_savings, '==', 0); 43 | 44 | # ->tzoffset? 45 | my $is_pseudo_fork = 0; 46 | if (defined &Win32::GetCurrentProcessId 47 | ? $$ != Win32::GetCurrentProcessId() : $^O eq "MSWin32" && $$ < 0) { 48 | $is_pseudo_fork = 1; 49 | } 50 | SKIP: { 51 | skip "can't register TZ changes in a pseudo-fork", 2 if $is_pseudo_fork; 52 | local $ENV{TZ} = "EST5EDT"; 53 | Time::Piece::_tzset(); # register the environment change 54 | my $lt = localtime(1735880528); #2025-01-03T05:02:08 55 | cmp_ok(scalar($lt->tzoffset), 'eq', '-18000'); 56 | cmp_ok($lt->strftime("%Z"), 'eq', 'EST'); 57 | } 58 | 59 | cmp_ok(($t->julian_day / 2451604.0243 ) - 1, '<', 0.001); 60 | cmp_ok(($t->mjd / 51603.52426) - 1, '<', 0.001); 61 | cmp_ok($t->week, '==', 9); 62 | 63 | # strftime tests 64 | 65 | # %a, %A, %b, %B, %c are locale-dependent 66 | 67 | # %C is unportable: sometimes its like asctime(3) or date(1), 68 | # sometimes it's the century (and whether for 2000 the century is 69 | # 20 or 19, is fun, too..as far as I can read SUSv2 it should be 20.) 70 | cmp_ok($t->strftime('%d'), '==', 29); 71 | 72 | cmp_ok($t->strftime('%D'), 'eq', '02/29/00'); # Yech! 73 | cmp_ok($t->strftime('%e'), 'eq', '29'); 74 | 75 | # %h is locale-dependent 76 | cmp_ok($t->strftime('%H'), 'eq', '13'); 77 | cmp_ok($t->strftime('%k'), 'eq', '13'); 78 | 79 | cmp_ok($t->strftime('%I'), 'eq', '01'); 80 | cmp_ok($t->strftime('%l'), 'eq', ' 1'); 81 | cmp_ok($t->strftime('%j'), '==', 60 ); # why ->yday+1 ? 82 | cmp_ok($t->strftime('%M'), 'eq', '34'); # should test with < 10 83 | 84 | # %p, %P, and %r are not widely implemented, 85 | # and are possibly unportable (am or AM or a.m., and so on) 86 | 87 | cmp_ok($t->strftime('%R'), 'eq', '13:34'); 88 | 89 | ok($t->strftime('%S') eq '56'); # should test with < 10 90 | 91 | cmp_ok($t->strftime('%T'), 'eq', '13:34:56'); # < 12 and > 12 92 | 93 | # There are bugs in the implementation of %u in many platforms. 94 | # (e.g. Linux seems to think, despite the man page, that %u 95 | # 1-based on Sunday...) 96 | 97 | cmp_ok($t->strftime('%U'), 'eq', '09'); # Sun cmp Mon 98 | 99 | SKIP: { 100 | skip "can't strftime %V on QNX or VOS", 1 if $is_qnx or $is_vos; 101 | # is this test really broken on Mac OS? -- rjbs, 2006-02-08 102 | cmp_ok($t->strftime('%V'), 'eq', '09'); # Sun cmp Mon 103 | } 104 | 105 | cmp_ok($t->strftime('%w'), '==', 2); 106 | cmp_ok($t->strftime('%W'), 'eq', '09'); # Sun cmp Mon 107 | 108 | # %x is locale and implementation dependent. 109 | 110 | cmp_ok($t->strftime('%y'), '==', 0); # should test with 1999 111 | cmp_ok($t->strftime('%Y'), 'eq', '2000'); 112 | 113 | # %Z is locale and implementation dependent (s/// to the rescue) 114 | cmp_ok($t->strftime('%z'), 'eq', '+0000'); 115 | cmp_ok($t->strftime('%%z%z'), 'eq', '%z+0000'); 116 | cmp_ok($t->strftime('%Z'), 'eq', 'UTC'); 117 | cmp_ok($t->strftime('%%Z%Z'), 'eq', '%ZUTC'); 118 | 119 | # (there is NO standard for timezone names) 120 | cmp_ok($t->date(""), 'eq', '20000229'); 121 | cmp_ok($t->ymd("") , 'eq', '20000229'); 122 | cmp_ok($t->mdy("/"), 'eq', '02/29/2000'); 123 | cmp_ok($t->dmy("."), 'eq', '29.02.2000'); 124 | cmp_ok($t->date_separator, 'eq', '-'); 125 | 126 | $t->date_separator("/"); 127 | cmp_ok($t->date_separator, 'eq', '/'); 128 | cmp_ok(Time::Piece::date_separator(), 'eq', '/'); 129 | cmp_ok($t->ymd, 'eq', '2000/02/29'); 130 | 131 | $t->date_separator("-"); 132 | cmp_ok($t->time_separator, 'eq', ':'); 133 | cmp_ok($t->hms("."), 'eq', '13.34.56'); 134 | 135 | $t->time_separator("."); 136 | cmp_ok($t->time_separator, 'eq', '.'); 137 | cmp_ok(Time::Piece::time_separator(), 'eq', '.'); 138 | cmp_ok($t->hms, 'eq', '13.34.56'); 139 | 140 | $t->time_separator(":"); 141 | 142 | my @fidays = qw( sunnuntai maanantai tiistai keskiviikko torstai 143 | perjantai lauantai ); 144 | my @frdays = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi ); 145 | 146 | cmp_ok($t->day(@fidays), 'eq', "tiistai"); 147 | my @days = $t->day_list(); 148 | 149 | $t->day_list(@frdays); 150 | 151 | cmp_ok($t->day, 'eq', "Merdi"); 152 | 153 | $t->day_list(@days); 154 | 155 | my @nmdays = Time::Piece::day_list(); 156 | is_deeply (\@nmdays, \@days); 157 | 158 | my @months = $t->mon_list(); 159 | 160 | my @dumonths = qw(januari februari maart april mei juni 161 | juli augustus september oktober november december); 162 | 163 | cmp_ok($t->month(@dumonths), 'eq', "februari"); 164 | 165 | $t->mon_list(@dumonths); 166 | 167 | cmp_ok($t->month, 'eq', "februari"); 168 | 169 | $t->mon_list(@months); 170 | 171 | cmp_ok($t->month, 'eq', "Feb"); 172 | my @nmmonths = Time::Piece::mon_list(); 173 | is_deeply (\@nmmonths, \@months); 174 | 175 | cmp_ok( 176 | $t->datetime(date => '/', T => ' ', time => '-'), 177 | 'eq', 178 | "2000/02/29 13-34-56" 179 | ); 180 | 181 | ok($t->is_leap_year); # should test more with different dates 182 | 183 | cmp_ok($t->month_last_day, '==', 29); # test more 184 | 185 | ok(!Time::Piece::_is_leap_year(1900)); 186 | 187 | ok(!Time::Piece::_is_leap_year(1901)); 188 | 189 | ok(Time::Piece::_is_leap_year(1904)); 190 | 191 | cmp_ok(Time::Piece->strptime("1945", "%Y")->year, '==', 1945, "Year is 1945?"); 192 | 193 | cmp_ok(Time::Piece->strptime("13:00", "%H:%M")->hour, '==', 13, "Hour is 13?"); 194 | 195 | # Test week number 196 | # [from Ilya Martynov] 197 | cmp_ok(Time::Piece->strptime("2002/06/10 0", '%Y/%m/%d %H')->week, '==', 24); 198 | cmp_ok(Time::Piece->strptime("2002/06/10 1", '%Y/%m/%d %H')->week, '==', 24); 199 | cmp_ok(Time::Piece->strptime("2002/06/10 2", '%Y/%m/%d %H')->week, '==', 24); 200 | cmp_ok(Time::Piece->strptime("2002/06/10 12", '%Y/%m/%d %H')->week, '==', 24); 201 | cmp_ok(Time::Piece->strptime("2002/06/10 13", '%Y/%m/%d %H')->week, '==', 24); 202 | cmp_ok(Time::Piece->strptime("2002/06/10 14", '%Y/%m/%d %H')->week, '==', 24); 203 | cmp_ok(Time::Piece->strptime("2002/06/10 23", '%Y/%m/%d %H')->week, '==', 24); 204 | 205 | # Test that strptime populates all relevant fields 206 | cmp_ok(Time::Piece->strptime("2002/07/10", '%Y/%m/%d')->wday, '==', 4); 207 | cmp_ok(Time::Piece->strptime("2002/12/31", '%Y/%m/%d')->yday, '==', 364); 208 | cmp_ok(Time::Piece->strptime("2002/07/10", '%Y/%m/%d')->isdst, '==', 0); 209 | cmp_ok(Time::Piece->strptime("2002/07/10", '%Y/%m/%d')->day_of_week, '==', 3); 210 | 211 | is( 212 | Time::Piece->strptime('12212', "%y%j")->ymd(), 213 | '2012-07-30', 214 | "day of the year parsing", 215 | ); 216 | 217 | cmp_ok( 218 | Time::Piece->strptime("2000/02/29 13:34:56", '%Y/%m/%d %H:%M:%S')->epoch, 219 | '==', 220 | 951831296 221 | ); 222 | 223 | 224 | my $s = Time::Seconds->new(-691050); 225 | is($s->pretty, 'minus 7 days, 23 hours, 57 minutes, 30 seconds'); 226 | 227 | $s = Time::Seconds->new(-90061); 228 | is($s->pretty, 'minus 1 day, 1 hour, 1 minute, 1 second'); 229 | 230 | $s = Time::Seconds->new(10); 231 | is($s->pretty, '10 seconds'); 232 | $s = Time::Seconds->new(130); 233 | is($s->pretty, '2 minutes, 10 seconds'); 234 | $s = Time::Seconds->new(7330); 235 | is($s->pretty, '2 hours, 2 minutes, 10 seconds', "Format correct"); 236 | -------------------------------------------------------------------------------- /t/02core_dst.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | 3 | # Skip if doing a regular install 4 | # Avoids mystery DST bugs [rt 128240], [GH40] 5 | plan skip_all => "DST tests not required for installation" 6 | unless ( $ENV{AUTOMATED_TESTING} ); 7 | 8 | my $is_win32 = ($^O =~ /Win32/); 9 | my $is_qnx = ($^O eq 'qnx'); 10 | my $is_vos = ($^O eq 'vos'); 11 | my $is_linux = ($^O =~ /linux/); 12 | my $is_bsd = ($^O =~ /bsd/); 13 | my $is_mac = ($^O =~ /darwin/); 14 | 15 | use Time::Piece; 16 | use Time::Seconds; 17 | 18 | #test using an epoch that can be DST 19 | #because sometimes funny stuff can occur [cpan #93095] 20 | #https://rt.cpan.org/Ticket/Display.html?id=93095#txn-1482590 21 | 22 | my $t = gmtime(1373360831); # 2013-07-09T09:07:11 23 | 24 | is($t->sec, 11); 25 | is($t->second, 11); 26 | is($t->min, 07); 27 | is($t->minute, 07); 28 | is($t->hour, 9); 29 | is($t->mday, 9); 30 | is($t->day_of_month, 9); 31 | is($t->mon, 7); 32 | is($t->_mon, 6); 33 | is($t->year, 2013); 34 | is($t->_year, 113); 35 | is($t->yy, '13'); 36 | 37 | cmp_ok($t->wday, '==', 3); 38 | cmp_ok($t->_wday, '==', 2); 39 | cmp_ok($t->day_of_week, '==', 2); 40 | cmp_ok($t->yday, '==', 189); 41 | cmp_ok($t->day_of_year, '==', 189); 42 | 43 | # In GMT there should be no daylight savings ever. 44 | cmp_ok($t->isdst, '==', 0); 45 | cmp_ok($t->epoch, '==', 1373360831); 46 | cmp_ok($t->hms, 'eq', '09:07:11'); 47 | cmp_ok($t->time, 'eq', '09:07:11'); 48 | cmp_ok($t->ymd, 'eq', '2013-07-09'); 49 | cmp_ok($t->date, 'eq', '2013-07-09'); 50 | cmp_ok($t->mdy, 'eq', '07-09-2013'); 51 | cmp_ok($t->dmy, 'eq', '09-07-2013'); 52 | cmp_ok($t->cdate, 'eq', 'Tue Jul 9 09:07:11 2013'); 53 | cmp_ok("$t", 'eq', 'Tue Jul 9 09:07:11 2013'); 54 | cmp_ok($t->datetime, 'eq','2013-07-09T09:07:11'); 55 | cmp_ok($t->daylight_savings, '==', 0); 56 | 57 | 58 | cmp_ok($t->week, '==', 28); 59 | 60 | # strftime tests 61 | 62 | # %a, %A, %b, %B, %c are locale-dependent 63 | 64 | # %C is unportable: sometimes its like asctime(3) or date(1), 65 | # sometimes it's the century (and whether for 2000 the century is 66 | # 20 or 19, is fun, too..as far as I can read SUSv2 it should be 20.) 67 | cmp_ok($t->strftime('%d'), '==', 9); 68 | 69 | cmp_ok($t->strftime('%D'), 'eq', '07/09/13'); # Yech! 70 | 71 | SKIP:{ 72 | skip "can't strftime %e on QNX", 1 if $is_qnx; 73 | cmp_ok($t->strftime('%e'), 'eq', ' 9'); 74 | } 75 | 76 | # %h is locale-dependent 77 | cmp_ok($t->strftime('%H'), 'eq', '09'); 78 | cmp_ok($t->strftime('%k'), 'eq', ' 9'); 79 | 80 | cmp_ok($t->strftime('%I'), 'eq', '09'); 81 | cmp_ok($t->strftime('%l'), 'eq', ' 9'); 82 | cmp_ok($t->strftime('%j'), '==', 190 ); # why ->yday+1 ? 83 | cmp_ok($t->strftime('%M'), 'eq', '07'); 84 | 85 | # %p, %P, and %r are not widely implemented, 86 | # and are possibly unportable (am or AM or a.m., and so on) 87 | 88 | SKIP: { 89 | skip "can't strftime %R on Win32 or QNX", 1 if $is_qnx; 90 | cmp_ok($t->strftime('%R'), 'eq', '09:07'); 91 | } 92 | 93 | ok($t->strftime('%S') eq '11'); 94 | 95 | cmp_ok($t->strftime('%T'), 'eq', '09:07:11'); 96 | 97 | # There are bugs in the implementation of %u in many platforms. 98 | # (e.g. Linux seems to think, despite the man page, that %u 99 | # 1-based on Sunday...) 100 | 101 | cmp_ok($t->strftime('%U'), 'eq', '27'); # Sun cmp Mon 102 | 103 | SKIP: { 104 | skip "can't strftime %V on Win32 or QNX or VOS", 1 if $is_qnx or $is_vos; 105 | # is this test really broken on Mac OS? -- rjbs, 2006-02-08 106 | cmp_ok($t->strftime('%V'), 'eq', '28'); # Sun cmp Mon 107 | } 108 | 109 | cmp_ok($t->strftime('%w'), '==', 2); 110 | cmp_ok($t->strftime('%W'), 'eq', '27'); # Sun cmp Mon 111 | 112 | # %x is locale and implementation dependent. 113 | 114 | cmp_ok($t->strftime('%y'), '==', 13); # should test with 1999 115 | cmp_ok($t->strftime('%Y'), 'eq', '2013'); 116 | 117 | ok(not $t->is_leap_year); # should test more with different dates 118 | 119 | cmp_ok($t->month_last_day, '==', 31); # test more 120 | 121 | 122 | SKIP: { 123 | skip "Extra tests for Linux, BSD only.", 9 unless $is_linux or $is_mac or $is_bsd; 124 | 125 | local $ENV{TZ} = "EST5EDT4,M3.2.0/2,M11.1.0/2"; 126 | Time::Piece::_tzset(); 127 | my $lt = localtime(1373360831); #2013-07-09T09:07:11 128 | cmp_ok(scalar($lt->tzoffset), 'eq', '-14400'); 129 | cmp_ok($lt->strftime("%Y-%m-%d %H:%M:%S %Z"), 'eq', '2013-07-09 05:07:11 EDT'); 130 | like ($lt->strftime("%z"), qr/-0400|EDT/); #windows: %Z and %z are the same 131 | is ($lt->strftime("%s"), 1373360831, 'Epoch output is the same with EDT'); 132 | cmp_ok($lt->strptime("2013-07-09 05:07:11 EDT", "%Y-%m-%d %H:%M:%S %Z")->isdst, '==', '1'); 133 | 134 | $lt = localtime(1357733231); #2013-01-09T09:07:11 135 | cmp_ok(scalar($lt->tzoffset), 'eq', '-18000'); 136 | cmp_ok($lt->strftime("%Y-%m-%d %H:%M:%S %Z"), 'eq', '2013-01-09 07:07:11 EST'); 137 | like ($lt->strftime("%z"), qr/-0500|EST/); 138 | is ($lt->strftime("%s"), 1357733231, 'Epoch output is the same with EST'); 139 | } 140 | 141 | done_testing(59); 142 | -------------------------------------------------------------------------------- /t/03compare.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | BEGIN { plan tests => 11 } 3 | use Time::Piece; 4 | 5 | my @t = ('2002-01-01 00:00', 6 | '2002-01-01 01:20'); 7 | 8 | @t = map Time::Piece->strptime($_, '%Y-%m-%d %H:%M'), @t; 9 | 10 | ok($t[0] < $t[1]); 11 | ok($t[0] < $t[1]->epoch); 12 | 13 | ok($t[0] != $t[1]); 14 | 15 | ok($t[0] == $t[0]); 16 | ok($t[0] == $t[0]->epoch); 17 | 18 | ok($t[0] != $t[1]); 19 | 20 | ok($t[0] <= $t[1]); 21 | ok($t[0] <= $t[1]->epoch); 22 | 23 | is($t[0] cmp $t[1], -1); 24 | is($t[1] cmp $t[0], 1); 25 | is($t[0] cmp $t[0], 0); 26 | -------------------------------------------------------------------------------- /t/04mjd.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More tests => 12; 4 | # Test the calculation of (modified) Julian date 5 | use Time::Piece; 6 | 7 | # First a lookup table of epoch and MJD 8 | # Use 3 sig fig in MJD (hence the use of strings) 9 | # This will not work on systems that use a different reference 10 | # epoch to unix time. To be more general we should use strptime 11 | # to parse the reference date. 12 | my %mjd = ( 13 | 951827696 => '51603.524', # 2000-02-29T12:34:56UT 14 | 1000011 => '40598.574', # 1970-01-12T13:46:51UT 15 | 1021605703 => '52411.140', # 2002-05-17T03:21:43UT 16 | 1121605703 => '53568.547', # 2005-07-17T13:08:23UT 17 | 1011590000 => '52295.218', # 2002-01-21T05:13:20UT 18 | 1011605703 => '52295.399', # 2002-01-21T09:35:03 19 | ); 20 | 21 | # Now loop over each MJD 22 | for my $time (keys %mjd) { 23 | 24 | # First check using GMT 25 | my $tp = gmtime( $time ); 26 | is(sprintf("%.3f",$tp->mjd),$mjd{$time}); 27 | 28 | # Now localtime should give the same answer for MJD 29 | # since MJD is always referred to as UT 30 | $tp = localtime( $time ); 31 | is(sprintf("%.3f",$tp->mjd),$mjd{$time}); 32 | 33 | } 34 | 35 | -------------------------------------------------------------------------------- /t/05overload.t: -------------------------------------------------------------------------------- 1 | # Tests for overloads (+,-,<,>, etc) 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More tests => 1; 6 | use Time::Piece; 7 | my $t = localtime; 8 | my $s = Time::Seconds->new(15); 9 | eval { my $result = $t + $s }; 10 | is($@, "", "Adding Time::Seconds does not cause runtime error"); 11 | 12 | -------------------------------------------------------------------------------- /t/06large.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use Time::Piece; 3 | use Time::Seconds; 4 | 5 | # Large tests - test dates outside of the epoch range, 6 | # somewhat silly, but lets see what happens 7 | 8 | my $is_win32 = ( $^O =~ /Win32/ ); 9 | 10 | plan skip_all => "Large time tests not required for installation" 11 | unless ( $ENV{AUTOMATED_TESTING} ); 12 | 13 | my $t = gmtime; 14 | 15 | my $base_year = $t->year; 16 | my $one_year = ONE_YEAR; 17 | 18 | for ( 1 .. 50 ) { 19 | $t = $t + $one_year; 20 | cmp_ok( 21 | $t->year, '==', 22 | $base_year + $_, 23 | "Year is: " . ( $base_year + $_ ) 24 | ); 25 | } 26 | 27 | $t = gmtime(1745187415); # 20 Apr 2025 22:16:55 28 | $base_year = $t->year; 29 | 30 | $t = $t - ( $one_year * 25 ); 31 | cmp_ok( $t->year, '==', $base_year - 25, "Year is: " . ( $base_year - 25 ) ); 32 | $base_year -= 25; 33 | 34 | $t = $t - ( $one_year * 25 ); 35 | cmp_ok( $t->year, '==', $base_year - 25, "Year is: " . ( $base_year - 25 ) ); 36 | $base_year -= 25; 37 | 38 | SKIP: { 39 | skip "No time64 on Win32 if perl < 5.12", 5, if $is_win32 && $] < 5.012; 40 | 41 | $t = $t - ( $one_year * 25 ); 42 | cmp_ok( $t->year, '==', $base_year - 25, "Year is: " . ( $base_year - 25 ) ); 43 | $base_year -= 25; 44 | 45 | $t = $t - ( $one_year * 25 ); 46 | cmp_ok( $t->year, '==', $base_year - 25, "Year is: " . ( $base_year - 25 ) ); 47 | $base_year -= 25; 48 | 49 | $t = $t - ( $one_year * 25 ); 50 | cmp_ok( $t->year, '==', $base_year - 25, "Year is: " . ( $base_year - 25 ) ); 51 | $base_year -= 25; 52 | 53 | $t = $t - ( $one_year * 25 ); 54 | cmp_ok( $t->year, '==', $base_year - 25, "Year is: " . ( $base_year - 25 ) ); 55 | $base_year -= 25; 56 | 57 | $t = $t - ( $one_year * 25 ); 58 | cmp_ok( $t->year, '==', $base_year - 25, "Year is: " . ( $base_year - 25 ) ); 59 | $base_year -= 25; 60 | } 61 | 62 | done_testing(57); 63 | -------------------------------------------------------------------------------- /t/06subclass.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | # This test file exists to show that Time::Piece can be subclassed and that its 6 | # methods will return objects of the class on which they're called. 7 | 8 | use Test::More 'no_plan'; 9 | 10 | use lib "t/lib"; 11 | use Time::Piece::Twin; 12 | 13 | BEGIN { use_ok('Time::Piece'); } 14 | 15 | my $class = 'Time::Piece::Twin'; 16 | 17 | for my $method (qw(new localtime gmtime)) { 18 | my $piece = $class->$method; 19 | isa_ok($piece, $class, "timepiece made via $method"); 20 | } 21 | 22 | { 23 | my $piece = $class->strptime("2005-01-01", "%Y-%m-%d"); 24 | isa_ok($piece, $class, "timepiece made via strptime"); 25 | } 26 | 27 | { 28 | my $piece = $class->new; 29 | isa_ok($piece, $class, "timepiece made via new (again)"); 30 | 31 | my $sum = $piece + 86_400; 32 | isa_ok($sum, $class, "tomorrow via addition operator"); 33 | 34 | my $diff = $piece - 86_400; 35 | isa_ok($diff, $class, "yesterday via subtraction operator"); 36 | } 37 | 38 | { 39 | my $g = $class->gmtime; 40 | my $l = $class->localtime; 41 | 42 | #via clone 43 | my $l_clone = $class->new($l); 44 | isa_ok($l_clone, $class, 'custom localtime via clone'); 45 | cmp_ok("$l_clone", 'eq', "$l", 'Clones match'); 46 | 47 | #via clone with gmtime 48 | my $g_clone = $class->new($g); 49 | isa_ok($g_clone, $class, 'custom gmtime via clone'); 50 | cmp_ok("$g_clone", 'eq', "$g", 'Clones match'); 51 | } 52 | 53 | { 54 | # let's verify that we can use gmtime from T::P without the export magic 55 | my $piece = Time::Piece::gmtime; 56 | isa_ok($piece, "Time::Piece", "object created via full-qualified gmtime"); 57 | isnt(ref $piece, 'Time::Piece::Twin', "it's not a Twin"); 58 | } 59 | 60 | 61 | 62 | { 63 | my $class = "Time::Piece::NumString"; 64 | my $piece = $class->strptime ("2006", "%Y"); 65 | is (2007 - $piece, 1, 66 | "subtract attempts stringify for unrecognized objects."); 67 | } 68 | 69 | ## Below is a package which only changes the stringify function. 70 | { 71 | package Time::Piece::NumString; 72 | use base qw(Time::Piece); 73 | use overload '""' => \&_stringify; 74 | sub _stringify 75 | { 76 | my $self = shift; 77 | return $self->strftime ("%Y"); 78 | } 79 | } 80 | -------------------------------------------------------------------------------- /t/07arith.t: -------------------------------------------------------------------------------- 1 | use Test::More tests => 43; 2 | 3 | BEGIN { use_ok('Time::Piece'); use_ok('Time::Seconds'); } 4 | 5 | ok(1); 6 | 7 | my $t = gmtime(951827696); # 2000-02-29T12:34:56 8 | 9 | is($t->mon, 2); 10 | is($t->mday, 29); 11 | 12 | my $t2 = $t->add_months(1); 13 | is($t2->year, 2000); 14 | is($t2->mon, 3); 15 | is($t2->mday, 29); 16 | 17 | my $t3 = $t->add_months(-1); 18 | is($t3->year, 2000); 19 | is($t3->mon, 1); 20 | is($t3->mday, 29); 21 | 22 | # this one wraps around to March because of the leap year 23 | my $t4 = $t->add_years(1); 24 | is($t4->year, 2001); 25 | is($t4->mon, 3); 26 | is($t4->mday, 1); 27 | 28 | $t = Time::Piece->strptime("01 01 2010","%d %m %Y"); 29 | my $t6 = $t->add_months(-12); 30 | is($t6->year, 2009); 31 | is($t6->mon, 1); 32 | is($t6->mday, 1); 33 | 34 | my $t7 = $t->add_months(-1); 35 | is($t7->year, 2009); 36 | is($t7->mon, 12); 37 | is($t7->mday, 1); 38 | 39 | my $t8 = $t->add_months(-240); 40 | is($t8->year, 1990); 41 | is($t8->mon, 1); 42 | is($t8->mday, 1); 43 | 44 | my $t9 = $t->add_months(-13); 45 | is($t9->year, 2008); 46 | is($t9->mon, 12); 47 | is($t9->mday, 1); 48 | 49 | eval { $t->add_months(); }; 50 | like($@, qr/add_months requires a number of months/); 51 | 52 | # Tests for Time::Seconds start here 53 | my $s = $t - $t7; 54 | is($s->minutes, 44640); 55 | is($s->hours, 744); 56 | is($s->days, 31); 57 | is(int($s->weeks), 4); 58 | is(int($s->months), 1); 59 | is(int($s->years), 0); 60 | 61 | $s2 = $s->copy; 62 | is($s2->minutes, 44640, 'Copy Time::Seconds object'); 63 | $s2 = $s->copy + 60; 64 | is($s2->minutes, 44641, 'Add integer to Time::Seconds object'); 65 | $s2 += ONE_HOUR; 66 | is($s2->minutes, 44701, 'Add exported constant to Time::Seconds object'); 67 | $s2 += $s2; 68 | is($s2->minutes, 89402, 'Add one Time::Seconds object to another'); 69 | 70 | $s2 += 300 * ONE_DAY; 71 | is(int($s2->financial_months), 12); 72 | is(int($s2->months), 11); 73 | 74 | $s2 = Time::Seconds->new(); 75 | is($s2->seconds, 0, 'Empty Time::Seconds constructor is 0s'); 76 | my $s3 = Time::Seconds->new(10); 77 | $s2 = $s2 + $s3; 78 | is($s2->seconds, 10, 'Add 2 Time::Seconds objects'); 79 | $s2 -= $s3; 80 | is($s2->seconds, 0, 'Subtract one Time::Seconds object from another'); 81 | 82 | eval { $s2 = $s2 + $t; }; 83 | like($@, qr/Can't use non Seconds object in operator overload/); 84 | -------------------------------------------------------------------------------- /t/08truncate.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More tests => 24; 4 | 5 | use Time::Piece; 6 | 7 | my $epoch = 1373371631; 8 | my $t = gmtime($epoch); # 2013-07-09T12:07:11 9 | 10 | is ($t->truncate, $t, 'No args, same object'); 11 | is ($t->truncate('foo'), $t, 'No "to" arg, same object'); 12 | eval { $t->truncate('to') }; 13 | like ($@, qr/Invalid value of 'to' parameter/, 14 | 'No "to" value croaks'); 15 | eval { $t->truncate('to' => 'foo') }; 16 | like ($@, qr/Invalid value of 'to' parameter: foo/, 17 | 'Unrecognised "to" value croaks'); 18 | 19 | my $short = $t->truncate(to => 'second'); 20 | my $exp = $epoch; 21 | cmp_ok ($short->epoch, '==', $exp, 'Truncate to second'); 22 | 23 | $short = $t->truncate(to => 'minute'); 24 | $exp -= 11; 25 | cmp_ok ($short->epoch, '==', $exp, 'Truncate to minute'); 26 | 27 | $short = $t->truncate(to => 'hour'); 28 | $exp -= 420; 29 | cmp_ok ($short->epoch, '==', $exp, 'Truncate to hour'); 30 | 31 | $short = $t->truncate(to => 'day'); 32 | $exp -= 43200; 33 | cmp_ok ($short->epoch, '==', $exp, 'Truncate to day'); 34 | 35 | $short = $t->truncate(to => 'month'); 36 | $exp -= 8 * 86400; 37 | cmp_ok ($short->epoch, '==', $exp, 'Truncate to month'); 38 | 39 | $exp = gmtime ($exp)->add_months(-6); 40 | $short = $t->truncate(to => 'year'); 41 | cmp_ok ($short, '==', $exp, 'Truncate to year'); 42 | 43 | is ($t->epoch, $epoch, 'Time unchanged'); 44 | 45 | for my $addmon (0..12) { 46 | my $quarter = $short->add_months ($addmon); 47 | $exp = $quarter->add_months (0 - ($addmon % 3)); 48 | $quarter = $quarter->truncate(to => 'quarter'); 49 | cmp_ok ($quarter, '==', $exp, "Truncate to quarter (month $addmon)"); 50 | 51 | } 52 | -------------------------------------------------------------------------------- /t/09locales.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use Time::Piece; 3 | 4 | # Skip if doing a regular install 5 | # These are mostly for reverse parsing tests, not required for installation 6 | plan skip_all => "Reverse parsing not required for installation" 7 | unless ( $ENV{AUTOMATED_TESTING} ); 8 | 9 | my $t = gmtime(1373371631); # 2013-07-09T12:07:11 10 | 11 | #locale should be undef 12 | is( $t->_locale, undef ); 13 | &Time::Piece::_default_locale(); 14 | 15 | ok( $t->_locale ); 16 | 17 | #use localized names 18 | cmp_ok( $t->monname, 'eq', &Time::Piece::_locale()->{mon}[ $t->_mon ] ); 19 | cmp_ok( $t->month, 'eq', &Time::Piece::_locale()->{mon}[ $t->_mon ] ); 20 | cmp_ok( $t->fullmonth, 'eq', &Time::Piece::_locale()->{month}[ $t->_mon ] ); 21 | 22 | #use localized names 23 | cmp_ok( $t->wdayname, 'eq', &Time::Piece::_locale()->{wday}[ $t->_wday ] ); 24 | cmp_ok( $t->day, 'eq', &Time::Piece::_locale()->{wday}[ $t->_wday ] ); 25 | cmp_ok( $t->fullday, 'eq', &Time::Piece::_locale()->{weekday}[ $t->_wday ] ); 26 | 27 | my @frdays = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi ); 28 | $t->day_list(@frdays); 29 | cmp_ok( $t->day, 'eq', &Time::Piece::_locale()->{wday}[ $t->_wday ] ); 30 | cmp_ok( $t->fullday, 'eq', &Time::Piece::_locale()->{weekday}[ $t->_wday ] ); 31 | 32 | 33 | #load local locale 34 | Time::Piece->use_locale(); 35 | 36 | #test reverse parsing 37 | sub check_parsed 38 | { 39 | my ( $t, $parsed, $t_str, $strp_format ) = @_; 40 | 41 | cmp_ok( $parsed->epoch, '==', $t->epoch, 42 | "Epochs match for $t_str with $strp_format" ); 43 | cmp_ok( 44 | $parsed->strftime($strp_format), 45 | 'eq', 46 | $t->strftime($strp_format), 47 | "Outputs formatted with $strp_format match" 48 | ); 49 | cmp_ok( $parsed->strftime(), 'eq', $t->strftime(), 50 | 'Outputs formatted as default match' ); 51 | } 52 | 53 | my @dates = ( 54 | '%Y-%m-%d %H:%M:%S', 55 | '%Y-%m-%d %T', 56 | '%A, %e %B %Y at %H:%M:%S', 57 | '%a, %e %b %Y at %r', 58 | '%s', 59 | '%c', 60 | '%F %T', 61 | '%D %r', 62 | 63 | #TODO 64 | # '%u %U %Y %T', #%U,W,V currently skipped inside strptime 65 | # '%w %W %y %T', 66 | '%A, %e %B %Y at %I:%M:%S %P', #%I and %p can be locale dependant 67 | '%x %X', #hard coded to American localization 68 | ); 69 | 70 | for my $time ( 71 | time(), # Now, whenever that might be 72 | 1451606400, # 2016-01-01 00:00 73 | 1451653500, # 2016-01-01 13:05 74 | ) 75 | { 76 | my $t = gmtime($time); 77 | 78 | for my $strp_format (@dates) { 79 | my $t_str = $t->strftime($strp_format); 80 | my $parsed = $t->strptime( $t_str, $strp_format ); 81 | 82 | check_parsed( $t, $parsed, $t_str, $strp_format ); 83 | } 84 | 85 | } 86 | 87 | for my $time ( 88 | time(), # Now, whenever that might be 89 | 1451606400, # 2016-01-01 00:00 90 | 1451653500, # 2016-01-01 13:05 91 | ) 92 | { 93 | my $t = localtime($time); 94 | for my $strp_format (@dates) { 95 | 96 | my $t_str = $t->strftime($strp_format); 97 | my $parsed; 98 | SKIP: { 99 | eval { $parsed = $t->strptime( $t_str, $strp_format ); }; 100 | skip "localtime strptime parse failed", 3 if $@; 101 | check_parsed( $t, $parsed, $t_str, $strp_format ); 102 | } 103 | 104 | } 105 | 106 | } 107 | 108 | done_testing(190); 109 | -------------------------------------------------------------------------------- /t/10overload.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Time::Piece; 4 | use Test::More tests => 5; 5 | 6 | eval 'use Math::BigInt'; 7 | plan skip_all => "Math::BigInt required for testing overloaded operands" if $@; 8 | 9 | my $t = Time::Piece->gmtime(315532800); # 00:00:00 1/1/1980 10 | isa_ok $t, 'Time::Piece'; 11 | is $t->cdate, 'Tue Jan 1 00:00:00 1980', 'got expected gmtime with int secs'; 12 | 13 | $t = Time::Piece->gmtime(Math::BigInt->new('315532800')); # 00:00:00 1/1/1980 14 | is $t->cdate, 'Tue Jan 1 00:00:00 1980', 'got same time with overloaded secs'; 15 | 16 | 17 | my $big_hour = Math::BigInt->new('3600'); 18 | 19 | $t = $t + $big_hour; 20 | is $t->cdate, 'Tue Jan 1 01:00:00 1980', 'add overloaded value'; 21 | 22 | $t = $t - $big_hour; 23 | is $t->cdate, 'Tue Jan 1 00:00:00 1980', 'sub overloaded value'; 24 | -------------------------------------------------------------------------------- /t/99legacy.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | no warnings 'deprecated'; 4 | 5 | use Test::More tests => 5; 6 | 7 | BEGIN { use_ok('Time::Piece'); } 8 | 9 | # The parse() legacy method is deprecated and will not be maintained. 10 | # The tests in this script illustrate both its functionality and some of 11 | # its bugs. This script should be removed from the test suite once 12 | # parse() has been deleted from Time::Piece. 13 | 14 | SKIP: { 15 | skip "Linux only", 4 if $^O !~ /linux/i; 16 | 17 | my $timestring = '2000-01-01T06:00:00'; 18 | my $t1 = Time::Piece->parse($timestring); 19 | isnt( $t1->datetime, $timestring, 'LEGACY: parse string months fail' ); 20 | my $t2 = $t1->parse( 0, 0, 6, 1, 0, 100 ); 21 | is( $t2->datetime, $timestring, 'LEGACY: parse array' ); 22 | eval { $t2 = Time::Piece->parse(); }; 23 | is( $t2->datetime, $timestring, 'LEGACY: parse with no args dies' ); 24 | eval { $t2 = Time::Piece::parse( 0, 0, 12, 1, 0, 100 ); }; 25 | is( $t2->datetime, $timestring, 'LEGACY: parse as non-method dies' ); 26 | } 27 | -------------------------------------------------------------------------------- /t/lib/Time/Piece/Twin.pm: -------------------------------------------------------------------------------- 1 | # this package is identical, but will be ->isa('Time::Piece::Twin'); 2 | package Time::Piece::Twin; 3 | use base qw(Time::Piece); 4 | our $VERSION = "1.35"; 5 | --------------------------------------------------------------------------------