File Coverage

blib/lib/Mojar/Cron/Util.pm
Criterion Covered Total %
statement 46 66 69.7
branch 3 16 18.7
condition 3 15 20.0
subroutine 18 27 66.6
pod 20 21 95.2
total 90 145 62.0


line stmt bran cond sub pod time code
1             package Mojar::Cron::Util;
2 8     8   19842 use Mojo::Base -strict;
  8         9  
  8         38  
3              
4             our $VERSION = 0.051;
5              
6 8     8   737 use Carp 'croak';
  8         10  
  8         286  
7 8     8   30 use Exporter 'import';
  8         9  
  8         228  
8 8     8   3144 use POSIX qw(mktime strftime);
  8         37248  
  8         29  
9 8     8   9659 use Time::Local 'timegm';
  8         8829  
  8         8100  
10              
11             our @EXPORT_OK = qw(
12             time_to_zero zero_to_time cron_to_zero zero_to_cron life_to_zero zero_to_life
13             balance normalise_utc normalise_local date_today date_next date_previous
14             date_dow utc_to_ts local_to_ts ts_to_utc ts_to_local local_to_utc utc_to_local
15             tz_offset
16             );
17              
18             # Public functions
19              
20 1504     1504 1 4229 sub time_to_zero { @_[0..2], $_[3] - 1, @_[4..$#_] }
21 1582     1582 1 4965 sub zero_to_time { @_[0..2], $_[3] + 1, @_[4..$#_] }
22              
23 0     0 1 0 sub cron_to_zero { @_[0..2], $_[3] - 1, $_[4] - 1, @_[5..$#_] }
24 0     0 1 0 sub zero_to_cron { @_[0..2], $_[3] + 1, $_[4] + 1, @_[5..$#_] }
25              
26 11     11 1 1115 sub life_to_zero { @_[0..2], $_[3] - 1, $_[4] - 1, $_[5] - 1900, @_[6..$#_] }
27 1     1 1 8 sub zero_to_life { @_[0..2], $_[3] + 1, $_[4] + 1, $_[5] + 1900, @_[6..$#_] }
28              
29             sub balance {
30 1332     1332 1 1446 my @parts = @_;
31 1332         1252 my @Max = (59, 59, 23, undef, 11);
32             # Bring values within range for sec, min, hour, month (zero-based)
33 1332         1238 for (0,1,2,4) {
34 5328         6224 $parts[$_] += $Max[$_] + 1, --$parts[$_ + 1] while $parts[$_] < 0;
35 5328         6833 $parts[$_] -= $Max[$_] + 1, ++$parts[$_ + 1] while $parts[$_] > $Max[$_];
36             }
37 1332         2433 return @parts;
38             }
39              
40             sub normalise_utc {
41 1332     1332 1 1270 my @parts = balance @_;
42 1332         1158 my $days = $parts[3] - 1; # could be negative
43 1332         2383 my $ts = timegm @parts[0..2], 1, @parts[4..$#parts]; # first of the month
44 1332         18071 $ts += $days * 24 * 60 * 60;
45 1332         2905 return gmtime $ts;
46             }
47              
48             sub normalise_local {
49 0     0 1 0 my @parts = balance @_;
50 0         0 my $days = 0;
51 0 0 0     0 if ($parts[3] < 1 or 28 < $parts[3] && $parts[4] == 1 or 30 < $parts[3]) {
      0        
      0        
52 0         0 $days = $parts[3] - 1; # possibly negative
53 0         0 $parts[3] = 1;
54             }
55 0         0 my $ts = mktime @parts;
56 0         0 $ts += $days * 24 * 60 * 60;
57 0         0 return localtime $ts;
58             }
59              
60 3     3 1 1088 sub date_today { strftime '%Y-%m-%d', localtime }
61              
62             sub date_next {
63 3 50   3 1 92 strftime '%Y-%m-%d', 0,0,0, $3 + 1, $2 - 1, $1 - 1900
64             if shift =~ /^(\d{4})-(\d{2})-(\d{2})\b/;
65             }
66              
67             sub date_previous {
68 0 0   0 1 0 strftime '%Y-%m-%d', 0,0,0, $3 - 1, $2 - 1, $1 - 1900
69             if shift =~ /^(\d{4})-(\d{2})-(\d{2})\b/;
70             }
71              
72             sub date_dow {
73 0 0   0 0 0 strftime '%u', 0,0,0, $3 + 1, $2 - 1, $1 - 1900
74             if shift =~ /^(\d{4})-(\d{2})-(\d{2})\b/;
75             }
76              
77 155     155 1 218 sub utc_to_ts { timegm @_ }
78 0     0 1 0 sub local_to_ts { mktime @_ }
79              
80 0     0 1 0 sub ts_to_utc { gmtime $_[0] }
81 1     1 1 221 sub ts_to_local { localtime $_[0] }
82              
83 1     1 1 32 sub local_to_utc { gmtime mktime @_ }
84 0     0 1 0 sub utc_to_local { localtime timegm @_ }
85              
86             my %UnitFactor = (
87             S => 1,
88             M => 60,
89             H => 60 * 60,
90             d => 60 * 60 * 24,
91             w => 60 * 60 * 24 * 7,
92             m => 60 * 60 * 24 * 30,
93             y => 60 * 60 * 24 * 365
94             );
95              
96             sub str_to_delta {
97 0     0 1 0 my ($str) = @_;
98 0 0       0 return 0 unless $str;
99 0 0       0 return $str if $str =~ /^[-+]?\d+S?$/;
100 0 0       0 return $1 * $UnitFactor{$2} if $str =~ /^([-+]?\d+)([MHdwmy])$/;
101 0         0 croak qq{Failed to interpret time period ($str)};
102             }
103              
104             sub tz_offset {
105 6   66 6 1 1730 my $now = shift // time;
106 6         82 my ($lm, $lh, $ly, $ld) = (localtime $now)[1, 2, 5, 7];
107 6         18 my ($um, $uh, $uy, $ud) = (gmtime $now)[1, 2, 5, 7];
108 6   33     27 my $min = $lm - $um + 60 * ($lh - $uh) + 60 * 24 * ($ly - $uy || $ld - $ud);
109 6         10 return _format_offset($min);
110             }
111              
112             # Private function
113              
114             # This is simply to aid unit testing
115             sub _format_offset {
116 10     10   841 my $min = shift;
117 10 100       18 my $sign = $min < 0 ? '-' : '+';
118 10         9 $min = abs $min;
119 10         15 my $hr = int(($min + 0.5) / 60);
120 10         9 $min = $min - 60 * $hr;
121 10         56 return sprintf '%s%02u%02u', $sign, abs($hr), abs($min);
122             }
123              
124             1;
125             __END__