File Coverage

blib/lib/Tie/TZ.pm
Criterion Covered Total %
statement 23 23 100.0
branch 6 6 100.0
condition 3 3 100.0
subroutine 6 6 100.0
pod n/a
total 38 38 100.0


line stmt bran cond sub pod time code
1             # Copyright 2008, 2009, 2010, 2011, 2019, 2020 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 Tie::TZ;
19             # require 5;
20 7     7   196723 use strict;
  7         44  
  7         171  
21 7     7   29 use Exporter;
  7         11  
  7         264  
22 7     7   36 use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS $TZ);
  7         11  
  7         2781  
23              
24             # uncomment this to run the ### lines
25             #use Smart::Comments;
26              
27             $VERSION = 11;
28              
29             @ISA = ('Exporter');
30             @EXPORT_OK = qw($TZ);
31             %EXPORT_TAGS = (all => \@EXPORT_OK);
32             tie $TZ, 'Tie::TZ';
33              
34             my $tzset_if_available;
35             $tzset_if_available = sub {
36              
37             # Taking \&POSIX::tzset here makes $tzset_if_available the current
38             # definition of that func. If someone assigns *POSIX::tzset to change it
39             # later then $tzset_if_available still goes to the old. That should be
40             # ok, since module imports of tzset() end up the same (ie. not tracking a
41             # redefinition). The only time a redefine might matter would be fakery
42             # like Test::MockTime. Stuff like that mainly mangles just the time
43             # funcs, not tzset(). If it does change tzset() then it would have to get
44             # in before any module imports anyway, which would probably mean the very
45             # start of a program, and would be fine for this \&POSIX::tzset too.
46             #
47             require POSIX;
48             $tzset_if_available = \&POSIX::tzset;
49              
50             if (! eval { POSIX::tzset(); 1 }) {
51             if ($@ =~ /not implemented/) {
52             # fail because not implemented, dummy out
53             $tzset_if_available = sub {};
54              
55             } else {
56             # Fail for some other reason, propagate this error and let POSIX give
57             # future ones. The first error is reported against the eval{} here,
58             # but the goto in STORE() means subsequent ones are reported directly
59             # against the $TZ assignment. This isn't terribly important though,
60             # since success or not-implemented are the only two normal cases.
61             die $@;
62             }
63             }
64             };
65              
66             sub TIESCALAR {
67 7     7   16 my ($class) = @_;
68 7         10 my $self = 'Tie::TZ oops, magic not used!';
69 7         19 return bless \$self, $class;
70             }
71              
72             sub FETCH {
73             #### TiedTZ fetch: $ENV{'TZ'}
74 39     39   15315 return $ENV{'TZ'};
75             }
76              
77             sub STORE {
78 53     53   15991 my ($self, $newval) = @_;
79             ### TiedTZ store: $newval
80              
81 53         84 my $oldval = $ENV{'TZ'};
82 53 100       124 if (defined $newval) {
83 31 100 100     110 if (defined $oldval && $oldval eq $newval) {
84             ### unchanged: $oldval
85 1         3 return;
86             }
87 30         126 $ENV{'TZ'} = $newval;
88              
89             } else {
90 22 100       45 if (! defined $oldval) {
91             ### unchanged: undef
92 7         25 return;
93             }
94 15         45 delete $ENV{'TZ'};
95             }
96              
97             ### tzset() call
98              
99             # this was going to be "goto $tzset_if_available", with the incoming args
100             # shifted off @_, but it's a call instead to avoid a bug in perl 5.8.9
101             # where a goto to an xsub like this provokes a "panic restartop", at least
102             # when done in the unwind of a "local" value for $TZ within an eval{}
103             # within a caught die().
104             #
105 45         603 &$tzset_if_available();
106             }
107              
108             1;
109             __END__