File Coverage

blib/lib/Time/TZ.pm
Criterion Covered Total %
statement 53 65 81.5
branch 12 20 60.0
condition 5 9 55.5
subroutine 9 10 90.0
pod 6 6 100.0
total 85 110 77.2


line stmt bran cond sub pod time code
1             # Copyright 2007, 2008, 2009, 2010, 2011 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   1679 use strict;
  1         2  
  1         46  
21 1     1   7 use Carp;
  1         3  
  1         85  
22 1     1   683 use Tie::TZ;
  1         2  
  1         39  
23 1     1   6 use vars qw($VERSION);
  1         3  
  1         860  
24              
25             # uncomment this to run the ### lines
26             #use Smart::Comments;
27              
28             $VERSION = 9;
29              
30             sub new {
31 4     4 1 7972 my ($class, %self) = @_;
32 4         16 my $self = bless \%self, $class;
33 4 50       25 unless (delete $self{'defer'}) {
34 4         10 $self->tz;
35             }
36 4         16 return $self;
37             }
38              
39             sub name {
40 1     1 1 4 my ($self) = @_;
41 1         8 return $self->{'name'};
42             }
43              
44             sub tz {
45 8     8 1 21 my ($self) = @_;
46 8         28 my $choose = delete $self->{'choose'};
47 8 100       21 if ($choose) {
48 2         4 foreach (@$choose) {
49 3 100       11 if ($self->tz_known($_)) {
50             ### Time-TZ choose: $_
51 2         9 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         36 return $self->{'tz'};
65             }
66              
67             my %tz_known = (UTC => 1, GMT => 1);
68             my $zonedir;
69             sub tz_known {
70 14     14 1 3463 my ($class_or_self, $tz) = @_;
71             ### tz_known(): $tz
72 14 100 66     82 if (! defined $tz || $tz_known{$tz}) {
73 3         10 return 1;
74             }
75              
76             # EST-10 or EST-10EDT etc
77 11 100       54 if ($tz =~ /^[A-Z]+[0-9+-]+([A-Z]+)?($|,)/) {
78             ### yes, std+offset form
79 5         12 return 1;
80             }
81              
82             {
83 6         7 require File::Spec;
  6         31  
84 6   66     39 $zonedir ||= File::Spec->catdir (File::Spec->rootdir,
85             'usr','share','zoneinfo');
86 6         9 my $filename = $tz;
87 6         695 $filename =~ s/^://;
88 6         129 $filename = File::Spec->rel2abs ($filename, $zonedir);
89             ### $filename
90 6 100       1003 if (-e $filename) {
91             ### yes, file exists
92 3         15 return 1;
93             }
94             }
95              
96             # any hour or minute different from GMT in any of 12 calendar months
97 3         11 my $timet = time();
98 3         19 local $Tie::TZ::TZ = $tz;
99 3         13 foreach (1 .. 12) {
100 36         46 my $mon = $_;
101 36         45 my $delta = $mon * 30 * 86400;
102 36         50 my $t = $timet + $delta;
103 36         131 my ($l_sec,$l_min,$l_hour,$l_mday,$l_mon,$l_year,$l_wday,$l_yday,$l_isdst)
104             = localtime ($t);
105 36         93 my ($g_sec,$g_min,$g_hour,$g_mday,$g_mon,$g_year,$g_wday,$g_yday,$g_isdst)
106             = gmtime ($t);
107 36 50 33     178 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 3         16 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 853 my $self = shift;
126 2         5 my $subr = shift;
127 2         8 local $Tie::TZ::TZ = $self->tz;
128 2         15 return &$subr(@_);
129             }
130              
131             1;
132             __END__