File Coverage

blib/lib/fixedtime.pm
Criterion Covered Total %
statement 22 22 100.0
branch n/a
condition 11 18 61.1
subroutine 10 10 100.0
pod 1 1 100.0
total 44 51 86.2


line stmt bran cond sub pod time code
1             package fixedtime;
2 4     4   66180 use 5.010; # this is a user-defined pragma and needs perl 5.10 or higher
  4         10  
3 4     4   14 use warnings;
  4         4  
  4         81  
4 4     4   11 use strict;
  4         10  
  4         718  
5              
6             our $VERSION = 0.05;
7              
8             =head1 NAME
9              
10             fixedtime - lexical pragma to fix the epoch offset for time related functions
11              
12             =head1 SYNOPSIS
13              
14             use Test::More 'no_plan';
15              
16             use constant EPOCH_OFFSET => 1204286400; # 29 Feb 2008 12:00:00 GMT
17              
18             {
19             use fixedtime epoch_offset => EPOCH_OFFSET;
20              
21             my $fixstamp = time;
22             is $fixstamp, EPOCH_OFFSET, "Fixed point in time ($fixstamp)";
23             is scalar gmtime, "Fri Feb 29 12:00:00 2008",
24             "@{[ scalar gmtime ]}";
25              
26             no fixedtime;
27             isnt time, EPOCH_OFFSET, "time() is back to normal";
28             }
29              
30             isnt time, EPOCH_OFFSET, "time() is back to normal";
31              
32             =head1 DESCRIPTION
33              
34             This pragma demonstrates the new perl 5.10 user-defined lexical pragma
35             capability. It uses the C<$^H{fixedtime}> hintshash entry to store the
36             epochoffset. Whenever C<$^H{fixedtime}> is undefined, the praga is
37             assumed not to be in effect.
38              
39             The C pragma affects L, L and
40             L only when called without an argument.
41              
42             =head2 use fixedtime [epoch_offset => epoch_offset];
43              
44             This will enable the pragma in the current lexical scope. When the
45             B argument is omitted, C is taken. While
46             the pragma is in effect the epochoffset is not changed.
47              
48             B: If you use a variable to set the epoch offset, make sure
49             it is initialized at compile time.
50              
51             my $epoch_offset = 1204286400;
52             use fixedtime epoch_offset => $epoch_offset; # Will not work as expected
53              
54             You will need something like:
55              
56             use constant EPOCH_OFFSET => 1204286400;
57             use fixedtime epoch_offset => EPOCH_OFFSET;
58              
59             =begin private
60              
61             =head2 fixedtime->import( [epoch_offset => EPOCH_OFFSET] )
62              
63             C is called on compile-time whenever C is called.
64              
65             Saves the status of the pragma (an epoch offset) in $^H{fixedtime}.
66              
67             =end private
68              
69             =cut
70              
71             sub import {
72 6     6   26 shift;
73 6         13 my %args = @_;
74             # we do not care about autoviv
75 6   33     477 $^H{fixedtime} = $args{epoch_offset} // CORE::time;
76             }
77              
78             =head2 no fixedtime;
79              
80             This will disable the pragma in the current lexical scope.
81              
82             =begin private
83              
84             =head2 fixedtime->unimport
85              
86             C is called on compile time whenever C is called.
87              
88             Stores undef as the pragma status to mean that it is not in effect.
89              
90             =end private
91              
92             =cut
93              
94 4     4   4294 sub unimport { $^H{fixedtime} = undef }
95              
96             =begin private
97              
98             =head2 fixedtime::epoch_offset
99              
100             C returns the runtime status of the progma.
101              
102             =end private
103              
104             =cut
105            
106             sub epoch_offset {
107 28     28 1 117 my $ctrl_h = ( caller 1 )[10];
108 28         145 return $ctrl_h->{fixedtime};
109             }
110              
111             # redefine the time related functions
112             # this works because:
113             # * pragma in effect -> fixedtime::epoch_offset() is defined
114             # * pragma not in effect -> fixedtime::epoch_offset() is not defined
115             # * the // makes sure that for undef CORE::time is used
116             # NB: for gmtime and localtime:
117             # when an epoch offset is passed, normal operation is in effect
118             BEGIN {
119             *CORE::GLOBAL::time = sub {
120 6   66 6   1541 return fixedtime::epoch_offset() // CORE::time;
121 4     4   14 };
122              
123             *CORE::GLOBAL::gmtime = sub (;$) {
124 12   66 12   709 my $stamp = shift // fixedtime::epoch_offset() // CORE::time;
      66        
125 12         90 CORE::gmtime( $stamp );
126 4         9 };
127              
128             *CORE::GLOBAL::localtime = sub (;$) {
129 10   66 10   144 my $stamp = shift // fixedtime::epoch_offset() // CORE::time;
      66        
130 10         145 CORE::localtime( $stamp );
131 4         63 };
132             }
133              
134             1;
135              
136             __END__