File Coverage

blib/lib/Time/TZ.pm
Criterion Covered Total %
statement 52 65 80.0
branch 11 20 55.0
condition 5 9 55.5
subroutine 9 10 90.0
pod 6 6 100.0
total 83 110 75.4


line stmt bran cond sub pod time code
1             # Copyright 2007, 2008, 2009, 2010, 2011, 2019 Kevin Ryde
2              
3             # This file is part of Tie-TZ.
4             #
5             # Tie-TZ is free software; you can redistribute it and/or modify it under
6             # the terms of the GNU General Public License as published by the Free
7             # Software Foundation; either version 3, or (at your option) any later
8             # version.
9             #
10             # Tie-TZ is distributed in the hope that it will be useful, but WITHOUT ANY
11             # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12             # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
13             # details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Tie-TZ. If not, see .
17              
18             package Time::TZ;
19             # require 5;
20 1     1   644 use strict;
  1         2  
  1         25  
21 1     1   4 use Carp;
  1         1  
  1         44  
22 1     1   372 use Tie::TZ;
  1         2  
  1         34  
23 1     1   5 use vars qw($VERSION);
  1         2  
  1         624  
24              
25             # uncomment this to run the ### lines
26             #use Smart::Comments;
27              
28             $VERSION = 10;
29              
30             sub new {
31 4     4 1 4068 my ($class, %self) = @_;
32 4         19 my $self = bless \%self, $class;
33 4 50       12 unless (delete $self{'defer'}) {
34 4         8 $self->tz;
35             }
36 4         9 return $self;
37             }
38              
39             sub name {
40 1     1 1 4 my ($self) = @_;
41 1         5 return $self->{'name'};
42             }
43              
44             sub tz {
45 8     8 1 16 my ($self) = @_;
46 8         14 my $choose = delete $self->{'choose'};
47 8 100       15 if ($choose) {
48 2         3 foreach (@$choose) {
49 3 100       7 if ($self->tz_known($_)) {
50             ### Time-TZ choose: $_
51 2         10 return ($self->{'tz'} = $_);
52             }
53             }
54 0         0 my $name = $self->name;
55 0 0       0 my $msg = "TZ" . (defined $name ? " '$name'" : '')
56             . ': no zone known to the system among: '
57             . join(' ',@$choose);
58 0 0       0 if (defined (my $tz = delete $self->{'fallback'})) {
59 0         0 warn $msg,", using $tz instead\n";
60 0         0 return ($self->{'tz'} = $tz);
61             }
62 0         0 croak $msg;
63             }
64 6         18 return $self->{'tz'};
65             }
66              
67             my %tz_known = (UTC => 1, GMT => 1);
68             my $zonedir;
69             sub tz_known {
70 14     14 1 4747 my ($class_or_self, $tz) = @_;
71             ### tz_known(): $tz
72 14 100 66     140 if (! defined $tz || $tz_known{$tz}) {
73 3         8 return 1;
74             }
75              
76             # EST-10 or EST-10EDT etc
77 11 100       46 if ($tz =~ /^[A-Z]+[0-9+-]+([A-Z]+)?($|,)/) {
78             ### yes, std+offset form
79 5         13 return 1;
80             }
81              
82             {
83 6         8 require File::Spec;
  6         27  
84 6   66     29 $zonedir ||= File::Spec->catdir (File::Spec->rootdir,
85             'usr','share','zoneinfo');
86 6         7 my $filename = $tz;
87 6         12 $filename =~ s/^://;
88 6         91 $filename = File::Spec->rel2abs ($filename, $zonedir);
89             ### $filename
90 6 50       99 if (-e $filename) {
91             ### yes, file exists
92 0         0 return 1;
93             }
94             }
95              
96             # any hour or minute different from GMT in any of 12 calendar months
97 6         9 my $timet = time();
98 6         23 local $Tie::TZ::TZ = $tz;
99 6         16 foreach (1 .. 12) {
100 72         75 my $mon = $_;
101 72         75 my $delta = $mon * 30 * 86400;
102 72         68 my $t = $timet + $delta;
103 72         153 my ($l_sec,$l_min,$l_hour,$l_mday,$l_mon,$l_year,$l_wday,$l_yday,$l_isdst)
104             = localtime ($t);
105 72         168 my ($g_sec,$g_min,$g_hour,$g_mday,$g_mon,$g_year,$g_wday,$g_yday,$g_isdst)
106             = gmtime ($t);
107 72 50 33     259 if ($l_hour != $g_hour || $l_min != $g_min) {
108             ### yes, different from GMT in mon: $mon
109 0         0 return 1;
110             }
111             }
112              
113             ### no
114 6         22 return 0;
115             }
116              
117             sub localtime {
118 0     0 1 0 my ($self, $timet) = @_;
119 0 0       0 if (! defined $timet) { $timet = time(); }
  0         0  
120 0         0 local $Tie::TZ::TZ = $self->tz;
121 0         0 return localtime ($timet);
122             }
123              
124             sub call {
125 2     2 1 712 my $self = shift;
126 2         2 my $subr = shift;
127 2         5 local $Tie::TZ::TZ = $self->tz;
128 2         8 return &$subr(@_);
129             }
130              
131             1;
132             __END__