|
rtfm / perl / Time::Zone / src/Zone.pm
|
|
package Time::Zone; use strict; use Fcntl qw(:DEFAULT :seek); use Exporter (); use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); use vars qw(*TZ %MCACHE); @ISA = qw(Exporter); %EXPORT_TAGS = (); @EXPORT_OK = (); @EXPORT = (); $VERSION = 0.01_00; use integer; use subs qw|time($$;$)|; sub _fclen ($$); sub _fmt2len ($); sub _tm2key (\@); use constant SECOND => 1; use constant MINUTE => 60 * SECOND; use constant HOUR => 60 * MINUTE; use constant DAY => 24 * HOUR; use constant TRUE => (1 == 1); use constant FALSE => (1 == 0); use constant ZERO_TRUE => '0E0'; use constant BLOCKSIZE => 8192; use constant UTCZONE => { map { ($_, 1) } qw(GMT UTC Zulu UCT Universal) }; use constant TMKEY_FMT => '%04d%02d%02d%02d%02d%02d'; # TZ Info file decoding templates: #============================================================================== # data block 0 use constant TZ_IDENT => 'TZif'; use constant TZ_HDR_FMT => 'a4x16N6'; use constant TZ_HDR_LEN => 44; # _fmt2len( TZ_HDR_FMT ); not gonna change use constant TZ_HDR_FLD => qw(- gmt std leap time type char); #============================================================================== # data block 1 # 0) time_t values for ttinfo rules to be applied (we have #time of these) # 1) whichth rule to apply at above time_t values (we have #time of these) # 2) list of TTINFO rules: (we have #type of these) use constant TZ_TTINFO_TIME => 'N'; use constant TZ_TTINFO_INDEX => 'C'; use constant TZ_TTINFO_RULE0 => 'a6'; use constant TZ_TTINFO_RULE1 => 'NCC'; # ttinfo rule fields: use constant TZ_TTINFO_FIELDS => qw(offset dst eidx); #============================================================================== # data block 2 # and then a list of null terminated zone acronyms (#char characters in all, # including the terminating nulls: use constant TZ_ETLA_FMT => 'a'; #============================================================================== # data block 3 # now we have #leap pairs of numbers (longs) describing leap seconds: use constant TZ_LEAP_SPEC0 => 'a8'; use constant TZ_LEAP_SPEC1 => 'NN'; use constant TZ_LEAP_FIELDS => qw(point offset); #============================================================================== # data block 4 # now we have #std boolean (byte) values, indicating "whether the # time_t values for local time type transitions in data block 1 were # std times or wall times": use constant TZ_STD_FLAG => 'C'; #============================================================================== # data block 5 # now we have #gmt boolean (byte) values, indicating "whether the # time_t values for local time type transitions in data block 1 were # std times or wall times": use constant TZ_GMT_FLAG => 'C'; #============================================================================== # post-unpack-munge rules: use constant MUNGE_NOOP => undef(); use constant MUNGE_SLNG => sub { $_[0] = unpack( 'l', pack('L', $_[0]) ) }; use constant MUNGE_RULE => sub { my %h; @h{ (TZ_TTINFO_FIELDS) } = unpack( TZ_TTINFO_RULE1, $_[0] ); (MUNGE_SLNG)->( $h{offset} ); $_[0] = \ %h; }; use constant MUNGE_LEAP => sub { my %h; @h{ (TZ_LEAP_FIELDS) } = map { (MUNGE_SLNG)->($_) } unpack( TZ_LEAP_SPEC1, $_[0] ); $_[0] = \ %h; }; #============================================================================== # now, pull it all together into a coherent ruleset: use constant STRUCT_NAME => 0; use constant HDR_RPT_ELT => 1; use constant DTA_ELT_FMT => 2; use constant POST_OP_FUN => 3; use constant TZ_PARSE_RULE => ( [ transition => time => TZ_TTINFO_TIME , MUNGE_SLNG ] , [ zone_index => time => TZ_TTINFO_INDEX, MUNGE_NOOP ] , [ zone => type => TZ_TTINFO_RULE0, MUNGE_RULE ] , [ etla => char => TZ_ETLA_FMT , MUNGE_NOOP ] , [ leap => leap => TZ_LEAP_SPEC0 , MUNGE_LEAP ] , [ std => std => TZ_STD_FLAG , MUNGE_NOOP ] , [ gmt => gmt => TZ_GMT_FLAG , MUNGE_NOOP ] ); #============================================================================== sub new ($;$) { my $pack = ref( $_[0] ) ? ref( $_[0] ) : $_[0]; my $self = { OPT => ( $_[1] || {} ), # options TZ => {} , # time zone data structures ZONE => undef() , # current zone ( key for TZ ) ERR => undef() , # last error that occurred }; bless( $self, $pack ); $self->init_opts(); return $self; } sub parse_tzdata ($$) { my $self = $_[0]; my $data = $_[1]; my %tzif; my %head; my $skip = TZ_HDR_LEN; @head{ (TZ_HDR_FLD) } = unpack( TZ_HDR_FMT, $data ); TZ_SECTION: foreach ( TZ_PARSE_RULE ) { my $repeat = $head{ $_->[ HDR_RPT_ELT ] } || next TZ_SECTION; my $field = $_->[ STRUCT_NAME ]; my $eltfmt = $_->[ DTA_ELT_FMT ]; my $munge = $_->[ POST_OP_FUN ]; my $format = join ( '', ($eltfmt x $repeat) ); my $skpfmt = sprintf( 'x%d', $skip ); my @data = unpack ( $skpfmt . $format, $data ); if( $munge ) { foreach ( @data ) { $munge->($_) } } $tzif{DATA}{ $field } = \ @data; $skip += _fmt2len( $format ); }; foreach my $z ( @{ $tzif{DATA}{zone} } ) { for(my $i = $z->{eidx}; ord($tzif{DATA}{etla}[$i]); $i++) { $z->{etla} .= $tzif{DATA}{etla}[$i]; } delete( $z->{eidx} ); } $tzif{HEAD} = \%head; return \ %tzif; } sub read_tzfile ($$) { my $buf; my @data; my $tzif; my $self = $_[0]; my $fh = $_[1]; while( sysread($fh, $buf, BLOCKSIZE) ) { push( @data, $buf ) } $tzif = join( '', @data ); return $self->parse_tzdata( $tzif ); } sub init_opts ($) { my $fh; my $self = $_[0]; my $opt = $self->{OPT}; $opt->{tzdir} ||= '/usr/share/zoneinfo'; $opt->{zone} ||= $ENV{TZ} || readlink('/etc/localtime') || 'localtime'; $opt->{mktime_strict} ||= FALSE; if( $opt->{zone} =~ /^:(.*)/ ) { $opt->{zone} = $1 } $self->set_zone( $opt->{zone} ); } # just a stubroutine for now: not sure of all the details of these, # or of the implications/uses/meanings of isstd/isstd flags sub is_tzspec ($$) { my $self = $_[0]; my $spec = $_[1]; return FALSE; } sub set_zone ($$) { my $self = $_[0]; my $zone = $_[1]; if( $self->{TZ}{ $zone } ) { $self->{ZONE} = $zone; return TRUE; } if( my $fh = $self->is_tzfile( $zone ) ) { $self->{TZ}{ $zone } = $self->read_tzfile( $fh ); $self->{ZONE} = $zone; return TRUE; } if( $self->is_tzspec( $zone ) ) { $self->{TZ}{ $zone } = $self->parse_tzspec( $zone ); $self->{ZONE} = $zone; return TRUE; } $self->{ERR} = "Not a timezone or localtime-specification ($zone)"; return FALSE; } sub get_zone ($) { $_[0]->{ZONE} } sub is_tzfile ($$) { local( *TZ ); my %head = (); my $buf = undef(); my $self = $_[0]; my $skip = TZ_HDR_LEN; my $file = ( $_[1] =~ m@^(?:/|\.\.?/)^@ ) ? $_[1] : join( '/', $self->{OPT}{tzdir}, $_[1] ); #warn( "tzcheckfile($file)\n" ); sysopen( TZ, $file, O_RDONLY ) || return FALSE; sysread( TZ, $buf , TZ_HDR_LEN ) == TZ_HDR_LEN || return FALSE; sysseek( TZ, 0 , SEEK_SET ) || return FALSE; @head{ (TZ_HDR_FLD) } = unpack( TZ_HDR_FMT, $buf ); TZ_CHECK: foreach ( TZ_PARSE_RULE ) { my $repeat = $head{ $_->[ HDR_RPT_ELT ] } || next TZ_CHECK; my $eltfmt = $_->[ DTA_ELT_FMT ]; my $format = join ( '', ($eltfmt x $repeat) ); $skip += _fmt2len( $format ); } return ( -s( TZ ) == $skip ) ? *TZ : FALSE; } sub tzinfo ($$;$) { my $N; my $self = $_[0]; my $time = $_[1]; if( defined($_[2]) ) { $self->set_zone( $_[2] ) || return FALSE } my $tzif = $self->{TZ}{ $self->{ZONE} }; my $stdp = $tzif->{DATA}{std}; my $zidx = 0; DEFAULT_ZONE: for( my $x = 0; $x < @{$stdp}; $x++ ) { $stdp->[ $x ] && ( $zidx = $x, last DEFAULT_ZONE); } my $zmap = $tzif->{DATA}{zone_index}; my $trans = $tzif->{DATA}{transition}; if( $tzif->{HEAD}{time} && ($time >= $trans->[ 0 ]) ) { my $maxt = $tzif->{HEAD}{time} - 1; if( $time >= $trans->[ $maxt ] ) { $zidx = $zmap->[ $maxt ] } else { for( my $i = 0; ($i <= $maxt) && ($time >= $trans->[$i]); $i++ ) { $zidx = $zmap->[ $i ]; } } } # if we have leap seconds, copy the zone spec and # calculate the offset ( if necessary, that is ): if( ( $N = $tzif->{HEAD}{leap} ) && ( $tzif->{DATA}{leap}[0]{point} <= $time ) ) { #warn( "\n!!LEAP!!\n" ); my %zi = %{ $tzif->{DATA}{zone}[ $zidx ] }; for( my $x = --$N; $x >= 0; $x-- ) { my $L = $tzif->{DATA}{leap}[ $x ]; if( $L->{point} <= $time ) { $zi{offset} -= $L->{offset}; last } } return \ %zi; } return $tzif->{DATA}{zone}[ $zidx ]; } sub time ($;$$) { use constant TIME_FIELDS => qw(sec min hour mday mon year wday yday dst); my %time = (); my $self = $_[0]; my $time = defined( $_[1] ) ? $_[1] : time(); my $zdef = defined( $_[2] ) ? $_[2] : undef(); my $zone = $self->tzinfo( $time, $zdef ) || return FALSE; @time{ (TIME_FIELDS) } = ( gmtime( $time + $zone->{offset} ), $zone->{dst} ); $time{mm} = $time{mon} + 1; $time{yyyy} = $time{year} + 1900; $time{etla} = $zone->{etla}; return \ %time; } # is this a utc zone? #sub _utczone ($) { (UTCZONE)->{$_[0]} } sub utczone ($;$) { my $zone; my $self = $_[0]; my $ozon = $self->{ZONE}; if( defined($_[1]) ){ $self->set_zone($_[1]) || return FALSE } $zone = $self->{TZ}{ $self->{ZONE} }; $self->{ZONE} = $ozon; return ( $zone->{HEAD}{time} == 0 ) ? TRUE : FALSE; } # return the start of a year/month time as a time_t value # ( or a magic ZERO_TRUE value for 1970-01-01 ) # or false if an error occurs. sub _mstart ($$$) { use constant TIMEFMT => '%04d%02d%02d%02d%02d%02d'; use constant TFMTARG => ( 5, 4, 3, 2, 1, 0 ); my $self = $_[0]; my $y = $_[1]; # full 4 digit year my $m = $_[2]; # 0 - 11 my $K = sprintf( '%04d', $y ); my $C = $MCACHE{$K} ||= []; if( !defined($C->[$m]) ) { my $T = FALSE; eval { my $t = time(); #theoretically, all times are equally good my @T = gmtime(); #might as well optimise for times near present my $d = 0; my $last = ''; my $this = ''; # zoom in on the year: while( $d = $y - $T[5] - 1900 ) { $t += $d * 365 * DAY; @T = gmtime( $t ); $this = sprintf( TIMEFMT, @T[TFMTARG] ); ($this eq $last) ? die("$y/$m out of range\n") : ($last = $this); } # now zoom in on the month: while( $d = $m - $T[4] ) { $t += $d * 27 * DAY; @T = gmtime( $t ); $this = sprintf( TIMEFMT, @T[TFMTARG] ); ($this eq $last) ? die("$y/$m out of range\n") : ($last = $this); } $t -= ( ($T[0] * SECOND) + ($T[1] * MINUTE) + ($T[2] * HOUR ) + (--$T[3] * DAY ) ); $T = $t || ZERO_TRUE; }; if( !$T ) { $self->{ERR} = $@; return FALSE } return $C->[$m] = $T; } return $C->[$m]; } sub _time2utc ($\@) { my $self = $_[0]; my $t = $_[1]; my $m = $self->_mstart( $t->[5], $t->[4] ) || return FALSE; return ( ( $m * SECOND ) + ( $t->[0] * SECOND ) + ( $t->[1] * MINUTE ) + ( $t->[2] * HOUR ) + ( $t->[3] * DAY ) - DAY ); } # return the time_t value for a time spec, or ZERO_TRUE for the epoch, # or FALSE on error: sub mktime ($$$;@) { use constant MKTIME_FIELDS => qw(sec min hour mday mon yyyy); use constant BEFORE => 0; use constant AFTER => 1; my $rmap; my $omap; my $tkey; my $time; my $tzif; my $dst = undef(); my @time = (); my $self = shift( @_ ); my $zdef = shift( @_ ) || $self->{ZONE}; my $x = $_[0]; my $T = FALSE; my $harsh= $self->{OPT}{mktime_strict}; if ( UNIVERSAL::isa($x,'HASH' ) ) { defined( $x->{yyyy} ) || ( $x->{yyyy} = $x->{year} + 1900 ); defined( $x->{mon} ) || ( $x->{mon} = $x->{mm} - 1 ); defined( $x->{dst} ) && ( $dst = $x->{dst} ? TRUE : FALSE ); @time = @{ $x }{ (MKTIME_FIELDS) } } else { if ( UNIVERSAL::isa($x,'ARRAY') ){ @time = @{ $x } } else { @time = @_ } if ( $self->{OPT}{fix_year} ){ $time[5] += 1900 } if ( $self->{OPT}{human_month} ){ $time[4] -= 1 } } $time = $self->_time2utc( \@time ) || return FALSE; $self->utczone( $zdef ) && return ( $time || ZERO_TRUE ); $self->set_zone( $zdef ) || return FALSE; $tzif = $self->{TZ}{ $zdef }; if( !$tzif->{DATA}{rmap} ) { $self->_init_rmap() } $rmap = $tzif->{DATA}{rmap}; $omap = $tzif->{DATA}{omap}; $tkey = _tm2key( @time ); warn( "checking $time/$tkey against rmap\n"); for( my $x = $#{$rmap}; $x >= 0; $x-- ) { # normal time mapping if( ($rmap->[ $x ][ BEFORE ] le $tkey) && ($rmap->[ $x ][ AFTER ] le $tkey) ) { return ( $time - $omap->[ $x ][ AFTER ] ) || ZERO_TRUE; } # time does not exist (zone skips forward over time) if( ($rmap->[ $x ][ BEFORE ] lt $tkey) && ($rmap->[ $x ][ AFTER ] gt $tkey) ) { return $harsh ? FALSE : ( $tzif->{DATA}{transition}[$x] || ZERO_TRUE ); } # time occurs twice in zone: if( ($rmap->[ $x ][ BEFORE ] gt $tkey) && ($rmap->[ $x ][ AFTER ] lt $tkey) ) { if( !defined($dst) ) { return $harsh ? FALSE : ( (($time - $omap->[ $x ][ BEFORE ]) || ZERO_TRUE) , (($time - $omap->[ $x ][ AFTER ]) || ZERO_TRUE) ); } return $dst ? ( ($time - $omap->[ $x ][ BEFORE ]) || ZERO_TRUE ) : ( ($time - $omap->[ $x ][ AFTER ]) || ZERO_TRUE ); } } return ( $time - $omap->[ 0 ][ BEFORE ] ) || ZERO_TRUE; } sub _init_rmap ($) { my $self = $_[0]; my $x; my @rmap; my @omap; my $offs = 0; my $last = 0; my $didx = 0; my $tzif = $self->{TZ}{ $self->{ZONE} }; my $stdp = $tzif->{DATA}{std}; my $midx = $tzif->{HEAD}{time}; for( $x = 0; $x < @{$stdp}; $x++ ) { $stdp->[$x] && ($didx = $x, last) } $offs = $tzif->{DATA}{zone}[ $didx ]{offset}; $#rmap = $#{ $tzif->{DATA}{transition} }; $#omap = $#rmap; for( $x = 0; $x < $midx; $x++ ) { my @t; my $ante; my $post; my $tz; my $t = $tzif->{DATA}{transition}[$x]; # calculate isostamp for transition time in pre-transition zone # (ie use the last offset): @t = gmtime( $t + $offs ); $t[5] += 1900; $ante = _tm2key( @t ); $last = $offs; # get the new offset $tz = $self->tzinfo( $t ); $offs = $tz->{offset}; # calculate isostamp for transition time in post-transition zone @t = gmtime( $t + $offs ); $t[5] += 1900; $post = _tm2key( @t ); $omap[$x] = [ $last, $offs ]; $rmap[$x] = [ $ante, $post ]; } $tzif->{DATA}{omap} = \ @omap; $tzif->{DATA}{rmap} = \ @rmap; } # calculate the length of a <CHAR><DIGIT(S)> pack specification component sub _fclen ($$) { use constant PCLMAP => {qw(a 1 A 1 c 1 C 1 s 2 S 2 l 4 L 4 n 2 N 4 v 2 V 4 q 8 Q 8 x 1 X -1)}; my $l = 0; my $c = $_[0]; my $n = $_[1]; if( $l = (PCLMAP)->{$c} ) { return ($l * $n) } if( $c =~ /b/i ) { no integer; return int( ($n / 8) + 0.875 ) } if( $c =~ /h/i ) { no integer; return int( ($n / 2) + 0.500 ) } return undef(); } # calculate the length in bytes of the data eaten by a pack specification: sub _fmt2len ($) { my $len = 0; my $fmt = $_[0]; eval { while ( $fmt =~ m^([aAZbBhHcCsSiIlLnNvVqQfdpPuUwxX\@/])(\d*)^g ) { my $c = $1; my $n = int( $2 ) || 1; my $l = _fclen( $c, $n ); defined($l) ? ($len += $l) : die("'$c$n' has no defined length\n"); } }; if( $@ ) { warn( $@, $fmt, "\n" ); return undef() } return $len; } sub _tm2key (\@) { my $t = $_[0]; sprintf( TMKEY_FMT, $t->[5], $t->[4], $t->[3], $t->[2], $t->[1], $t->[0] ); } 1; __END__ # Below is stub documentation for your module. You better edit it! =head1 NAME Time::Zone - Perl extension for converting time_t values to local time and back =head1 SYNOPSIS use Time::Zone; my($tzo) = Time::Zone->new({ zone => "Europe/Paris" }); =head1 DESCRIPTION Time::Zone reads tzfile(5) files and then provides methods which allow you to translate time_t values into timezone local time values and back again. (it even gets things right when you ask for a local time spec to be translated back, and the time occurs twice in that zone (eg during a backward jump) or the time doesn't occur at all (during a forward jump)) =head1 EXPORT None by default - Time::Zone provides an OO interface. =head1 METHODS Note that not all the methods are documented here - just the ones intended for external use - if it isn't documented here, there are no guarantees as to its interface or even continued existence. =head2 Time::Zone-E<gt>new( OPT_HASH ) Returns a Time::Zone object. OPT_HASH is a hash reference, which can take the following keys: =over 4 =item zone The name of the timezone you want loaded. If none is specified, /etc/localtime and <tzdir>/localtime are tried in turn. =item tzdir The name of the tzfile(5) directory. Defaults to /usr/local/zoneinfo, which should be the right place on any modern unixoid system. If you are stuck on a machine which doesn't have this, or has an out-of-date or broken tzfile(5) dataset, you can always copy the tzfiles onto the machine in question, and set this option to point at them. =item fix_year Tells L<< mktime|/"$obj->mktime( zone, local_time )" >> to expect years as offsets from 1900, and kludge them up accordingly. Note that this does not effect any other methods. Also, note that this does not have any effect when mktime is passed a data structure like that returned by L<< time|/"$obj->time( time_t [, zone] )" >> =item human_month Tells L<< mktime|/"$obj->mktime( zone, local_time )" >> to expect months in the 1-12 range, instead of the 0-11 range. Does not effect any other methods. Also, note that this does not have any effect when mktime is passed a data structure like that returned by L<< time|/"$obj->time( TIME_T [, ZONE] )" >> =back =head2 $obj-E<gt>set_zone( ZONE ) Set the default timezone to ZONE. =head2 $obj-E<gt>get_zone() Return the current default timezone. =head2 $obj-E<gt>tzinfo( TIME_T [, ZONE] ) Return a tzinfo hash reference, for the time_t value TIME_T, containing the following key/value pairs: =over 4 =item dst Boolean - whether or not we are in daylight savings time. =item offset The offset in seconds (including any leap seconds in effect) from UTC =item etla The appropriate time zone abbreviation to use. =back If ZONE is supplied, set the default zone to ZONE before proceeding. =head2 $obj-E<gt>time( TIME_T [, ZONE] ) Returns a time hash reference, for TIME_T, in the default timezone, which contains the following key/value pairs: =over 4 =item sec seconds [0 - 59] =item min Minutes [0 - 59] =item hour Hours [0 - 23] =item mday Day of the month [1 - 31] =item mon Month [0-11] =item year Year - 1900 =item wday Day of the Week [0 - 6] (maps to Sun - Sat) =item yday Day of the Year [0 - 366] =item dst Boolean - Daylight Saving Time flag. =item mm Month 1 - 12 =item yyyy Year =item etla Time zone acronym. (usu 3-4 letters) =back If ZONE is supplied, set the default zone to that before proceeding. =head2 $obj-E<gt>utczone( TIME_T [, ZONE] ) Is the ZONE (or the default zone, if ZONE is not supplied) one of the many names by which UTC (Universal Coordinate Time) is known? ( The UTC zone has, by definition, no time shifts and no leap seconds. ) Note that, unlike other methds which take a ZONE argument, utczone does not set the default timezone for the object it is called on. This is entirely because I'm too lazy to make the other methods work this way. So there. =head2 $obj-E<gt>mktime( ZONE, LOCAL_TIME ) Returns a time_t value for LOCAL_TIME, where ZONE is a timezone name, or something false, and localtime is one of: =over 4 =item A time structure, as returned by the time method Note that in this case only one of the yyyy or year, and only one of the mon or mm key value pairs, needs to be set. ( And the etla field need not be set either ). The dst flag field may be set, but is only important when a time occurs twice in a zone ( eg during a backward shift overlap ). =item An array (6 elements, in gmtime() order) Note: see the fix_year and human_month options L<< new|/"Time::Zone->new( OPT_HASH )" >> =item An array reference (6 elements, in gmtime() order) Note: see the fix_year and human_month options L<< new|/"Time::Zone->new( OPT_HASH )" >> =back If ZONE is something true, the default zone is set to ZONE before proceeding. There are a couple of "interesting" cases that mktime needs to deal with - the exact behaviour of mktime in these cases is controlled by the L<< mktime_strict|"Time::Zone->new( OPT_HASH )" >> option. Note that even if mktime calculates a time_t value of 0, it will return ZERO_TRUE, so a FALSE (or even false) return value will always indicate an error. =over 4 =item mktime_strict = TRUE If a time does not occur at all in the zone in question (eg due to a forward shift that traverses the time in question), mktime returns FALSE. If a time occurs twice, and mktime cannot determine which time you required, it will return FALSE. =item mktime_strict = FALSE If a time does not occur at all in the zone in question, mktime will return the time_t value corresponding to the transition time. If a time occurs twice, and mktime cannot determine which time you required, ( ie mktime was not called with a L<< time|/"$obj->time( time_t [, zone] )" >> structure ), then mktime will return a list consisting of both time_t values. =back =head1 AUTHOR Vivek Dasmohapatra, E<lt>vivek@etla.orgE<gt> =head1 SEE ALSO L<perl> L<tzfile> =cut |
|
|
|