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

# Copyright 2008, 2009, 2010, 2011, 2019 Kevin Ryde

# This file is part of Tie-TZ.
#
# Tie-TZ is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Tie-TZ is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License along
# with Tie-TZ.  If not, see .

package Tie::TZ;
# require 5;
use strict;
use Exporter;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS $TZ);

# uncomment this to run the ### lines
#use Smart::Comments;

$VERSION = 10;

@ISA = ('Exporter');
@EXPORT_OK = qw($TZ);
%EXPORT_TAGS = (all => \@EXPORT_OK);
tie $TZ, 'Tie::TZ';

my $tzset_if_available;
$tzset_if_available = sub {

  # Taking \&POSIX::tzset here makes $tzset_if_available the current
  # definition of that func.  If someone assigns *POSIX::tzset to change it
  # later then $tzset_if_available still goes to the old.  That should be
  # ok, since module imports of tzset() end up the same (ie. not tracking a
  # redefinition).  The only time a redefine might matter would be fakery
  # like Test::MockTime.  Stuff like that mainly mangles just the time
  # funcs, not tzset().  If it does change tzset() then it would have to get
  # in before any module imports anyway, which would probably mean the very
  # start of a program, and would be fine for this \&POSIX::tzset too.
  #
  require POSIX;
  $tzset_if_available = \&POSIX::tzset;

  if (! eval { POSIX::tzset(); 1 }) {
    if ($@ =~ /not implemented/) {
      # fail because not implemented, dummy out
      $tzset_if_available = sub {};

    } else {
      # Fail for some other reason, propagate this error and let POSIX give
      # future ones.  The first error is reported against the eval{} here,
      # but the goto in STORE() means subsequent ones are reported directly
      # against the $TZ assignment.  This isn't terribly important though,
      # since success or not-implemented are the only two normal cases.
      die $@;
    }
  }
};

sub TIESCALAR {
  my ($class) = @_;
  my $self = 'Tie::TZ oops, magic not used!';
  return bless \$self, $class;
}

sub FETCH {
  #### TiedTZ fetch: $ENV{'TZ'}
  return $ENV{'TZ'};
}

sub STORE {
  my ($self, $newval) = @_;
  ### TiedTZ store: $newval

  my $oldval = $ENV{'TZ'};
  if (defined $newval) {
    if (defined $oldval && $oldval eq $newval) {
      ### unchanged: $oldval
      return;
    }
    $ENV{'TZ'} = $newval;

  } else {
    if (! defined $oldval) {
      ### unchanged: undef
      return;
    }
    delete $ENV{'TZ'};
  }

  ### tzset() call

  # this was going to be "goto $tzset_if_available", with the incoming args
  # shifted off @_, but it's a call instead to avoid a bug in perl 5.8.9
  # where a goto to an xsub like this provokes a "panic restartop", at least
  # when done in the unwind of a "local" value for $TZ within an eval{}
  # within a caught die().
  #
  &$tzset_if_available();
}

1;
__END__