File Coverage

blib/lib/Date/Object.pm

Criterion	Covered	Total	%
statement	497	1030	48.2
branch	211	618	34.1
condition	103	314	32.8
subroutine	66	164	40.2
pod	75	141	53.1
total	952	2267	41.9

#############################################################################
## This file was generated automatically by Class::HPLOO/0.18
##
## Original file:    ./lib/Date/Object.hploo
## Generation date:  2005-01-05 20:52:25
##
## ** Do not change this file, use the original HPLOO source! **
#############################################################################

#############################################################################
## Name:        Object.pm
## Purpose:     Date::Object
## Author:      Graciliano M. P.
## Modified by:
## Created:     2004-03-19
## RCS-ID:
## Copyright:   (c) 2004 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################


sub Date::O       { Date::Object->new(@_) ;}
sub Date::O_gmt   { Date::Object->new_gmt(@_) ;}
sub Date::O_local { Date::Object->new_local(@_) ;}
sub Date::O_zone  { Date::Object->new_zone(@_) ;}
sub Date::check   { Date::Object::check(@_) ;}
sub Date::timelocal  { Date::Object::timelocal(@_) ;}

{ package Date::Object ;

  use strict qw(vars) ; no warnings ;

  use vars qw(%CLASS_HPLOO @ISA $VERSION) ;

  $VERSION = '0.06' ;

  @ISA = qw(Class::HPLOO::Base UNIVERSAL) ;

  my $CLASS = 'Date::Object' ; sub __CLASS__ { 'Date::Object' } ;

  sub new {
    if ( !defined &Object && @ISA > 1 ) {
    foreach my $ISA_i ( @ISA ) {
    return &{"$ISA_i\::new"}(@_) if defined &{"$ISA_i\::new"} ;
    } }  my $class = shift ;
    $class = ref($class) if ref($class) ;
    my $this = new_call_BEGIN($class , @_) ;
    $this = bless({} , $class) if !ref($this) || !UNIVERSAL::isa($this,$class) ;
    no warnings ;
    my $undef = \'' ;
    sub UNDEF {$undef} ;
    if ( $CLASS_HPLOO{ATTR} ) {
    CLASS_HPLOO_TIE_KEYS($this) }  my $ret_this = defined &Object ? $this->Object(@_) : undef ;
    if ( ref($ret_this) && UNIVERSAL::isa($ret_this,$class) ) {
    $this = $ret_this ;
    if ( $CLASS_HPLOO{ATTR} && UNIVERSAL::isa($this,'HASH') ) {
    CLASS_HPLOO_TIE_KEYS($this) } } elsif ( $ret_this == $undef ) {
    $this = undef }  new_call_END($this,@_) ;
    return $this ;
    }  sub CLASS_HPLOO_TIE_KEYS {
    my $this = shift ;
    if ( $CLASS_HPLOO{ATTR} ) {
    foreach my $Key ( keys %{$CLASS_HPLOO{ATTR}} ) {
    tie( $this->{$Key} => 'Date::Object::HPLOO_TIESCALAR' , $this , $Key , $CLASS_HPLOO{ATTR}{$Key}{tp} , $CLASS_HPLOO{ATTR}{$Key}{pr} , \$this->{CLASS_HPLOO_ATTR}{$Key} , \$this->{CLASS_HPLOO_CHANGED} , 'Date::Object' ) if !exists $this->{$Key} ;
    } } }   sub SUPER {
    eval('package Class::HPLOO::Base ;
    ') if !defined *{'Class::HPLOO::Base::'} ;
    my ($prev_pack , undef , undef , $sub0) = caller(1) ;
    $prev_pack = undef if $prev_pack eq 'Class::HPLOO::Base' ;
    my ($pack,$sub) = ( $sub0 =~ /^(?:(.*?)::|)(\w+)$/ );
    my $sub_is_new_hploo = $sub0 =~ /^(.*?(?:::)?$sub)\::$sub$/ ? 1 : undef ;
    unshift(@_ , $prev_pack) if ( $sub_is_new_hploo && $prev_pack && ((!ref($_[0]) && $_[0] ne $prev_pack && !UNIVERSAL::isa($_[0] , $prev_pack)) || (ref($_[0]) && !UNIVERSAL::isa($_[0] , $prev_pack)) ) ) ;
    if ( defined @{"$pack\::ISA"} ) {
    my $isa_sub = ISA_FIND_NEW($pack, ($sub_is_new_hploo?'new':$sub) ,1) ;
    my ($sub_name) = ( $isa_sub =~ /(\w+)$/gi );
    if ( $sub0 ne $isa_sub && !ref($_[0]) && $isa_sub =~ /^(.*?(?:::)?$sub_name)\::$sub_name$/ ) {
    @_ = ( bless({},$_[0]) , @_[1..$#_] ) ;
    } if ( $sub0 eq $isa_sub && UNIVERSAL::isa($_[0] , $pack) ) {
    my @isa = Class::HPLOO::Base::FIND_SUPER_WALK( ref($_[0]) , $pack ) ;
    my $pk = $isa[-1] ;
    if ( $sub_is_new_hploo ) {
    if ( UNIVERSAL::isa($pk , 'Class::HPLOO::Base') ) {
    ($sub) = ( $pk =~ /(\w+)$/gi );
    } else {
    $sub = 'new' ;
    } } my $isa_sub = $pk->can($sub) ;
    return &$isa_sub( ARGS_WRAPPER(@_) ) if $isa_sub ;
    } return &$isa_sub(@_) if $isa_sub && defined &$isa_sub && $sub0 ne $isa_sub ;
    } $sub = $sub_is_new_hploo ? 'new' : $sub ;
    die("Can't find SUPER method for $sub0!") if "$pack\::$sub" eq $sub0 ;
    return &{"$pack\::$sub"}(@_) ;
    }  sub FIND_SUPER_WALK {
    my $class_main = shift ;
    my $class_end = shift ;
    my $only_stak = shift ;
    my (@stack) ;
    my $stack = $only_stak || {} ;
    my $found ;
    foreach my $isa_i ( @{"$class_main\::ISA"} ) {
    next if $$stack{$isa_i}++ ;
    $found = 1 if $isa_i eq $class_end ;
    push(@stack , $isa_i , FIND_SUPER_WALK($isa_i , $class_end , $stack) );
    }  return ($found ? @stack : ()) if $only_stak ;
    return @stack ;
    }  sub ISA_FIND_NEW {
    my $pack = shift ;
    my $sub = shift ;
    my $look_deep = shift ;
    my $count = shift ;
    return if $count > 100 ;
    my ($sub_name) ;
    if ( UNIVERSAL::isa($pack , 'Class::HPLOO::Base') ) {
    ($sub_name) = $sub eq 'new' ? ( $pack =~ /(\w+)$/ ) : ($sub) ;
    } else {
    $sub_name = $sub ;
    }  my $isa_sub = "$pack\::$sub_name" ;
    if ( $look_deep || !defined &$isa_sub ) {
    foreach my $isa_i ( @{"$pack\::ISA"} ) {
    next if $isa_i eq $pack || $isa_i eq 'Class::HPLOO::Base' ;
    last if $isa_i eq 'UNIVERSAL' ;
    $isa_sub = ISA_FIND_NEW($isa_i , $sub , 0 , $count+1) ;
    last if $isa_sub ;
    } }  $isa_sub = undef if !defined &$isa_sub ;
    return $isa_sub ;
    }  sub new_call_BEGIN {
    my $class = shift ;
    my $this = $class ;
    foreach my $ISA_i ( @ISA ) {
    last if $ISA_i eq 'Class::HPLOO::Base' ;
    my $ret ;
    my ($sub) = ( $ISA_i =~ /(\w+)$/ );
    $sub = "$ISA_i\::$sub\_BEGIN" ;
    $ret = &$sub($this,@_) if defined &$sub ;
    $this = $ret if UNIVERSAL::isa($ret,$class) ;
    } return $this ;
    }  sub new_call_END {
    my $class = shift ;
    foreach my $ISA_i ( @ISA ) {
    last if $ISA_i eq 'Class::HPLOO::Base' ;
    my $ret ;
    my ($sub) = ( $ISA_i =~ /(\w+)$/ );
    $sub = "$ISA_i\::$sub\_END" ;
    &$sub(@_) if defined &$sub ;
    } return ;
  }


  sub GET_CLASS_HPLOO_HASH {
    return \%CLASS_HPLOO } ;
    sub ATTRS {
    return @{[@{ $CLASS_HPLOO{ATTR_ORDER} }]} } ;
    sub CLASS_HPLOO_ATTR {
    my @attrs = split(/\s*,\s*/ , $_[0]) ;
    foreach my $attrs_i ( @attrs ) {
    $attrs_i =~ s/^\s+//s ;
    $attrs_i =~ s/\s+$//s ;
    my ($name) = ( $attrs_i =~ /(\w+)$/gi ) ;
    my ($type) = ( $attrs_i =~ /^((?:\w+\s+)*?&?\w+|(?:\w+\s+)*?\w+(?:(?:::|\.)\w+)*)\s+\w+$/gi ) ;
    my $type0 = $type ;
    $type0 =~ s/\s+/ /gs ;
    $type = lc($type) ;
    $type =~ s/(?:^|\s*)bool$/boolean/gs ;
    $type =~ s/(?:^|\s*)int$/integer/gs ;
    $type =~ s/(?:^|\s*)float$/floating/gs ;
    $type =~ s/(?:^|\s*)str$/string/gs ;
    $type =~ s/(?:^|\s*)sub$/sub_$name/gs ;
    $type =~ s/\s//gs ;
    $type = 'any' if $type !~ /^(?:(?:ref)|(?:ref)?(?:array|hash)(?:boolean|integer|floating|string|sub_\w+|any|&\w+)|(?:ref)?(?:array|hash)|(?:array|hash)?(?:boolean|integer|floating|string|sub_\w+|any|&\w+))$/ ;
    if ( $type eq 'any' && $type0 =~ /^((?:ref\s*)?(?:array|hash) )?(\w+(?:(?:::|\.)\w+)*)$/ ) {
    my ($tp1 , $tp2) = ($1 , $2) ;
    $tp1 =~ s/\s+//gs ;
    $tp2 = 'UNIVERSAL' if $tp2 =~ /^(?:obj|object)$/i ;
    $tp2 =~ s/\.+/::/gs ;
    $type = "$tp1$tp2" ;
    }  my $parse_ref = $type =~ /^(?:array|hash)/ ? 1 : 0 ;
    push(@{ $CLASS_HPLOO{ATTR_ORDER} } , $name) if !$CLASS_HPLOO{ATTR}{$name} ;
    $CLASS_HPLOO{ATTR}{$name}{tp} = $type ;
    $CLASS_HPLOO{ATTR}{$name}{pr} = $parse_ref ;
    my $return ;
    if ( $type =~ /^sub_(\w+)$/ ) {
    my $sub = $1 ;
    $return = qq~ return (&$sub(\$this,\@_))[0] if defined &$sub ;
    return undef ;
    ~ ;
    } else {
    $return = $parse_ref ? qq~ ref(\$this->{CLASS_HPLOO_ATTR}{$name}) eq 'ARRAY' ? \@{\$this->{CLASS_HPLOO_ATTR}{$name}} : ref(\$this->{CLASS_HPLOO_ATTR}{$name}) eq 'HASH' ? \%{\$this->{CLASS_HPLOO_ATTR}{$name}} : \$this->{CLASS_HPLOO_ATTR}{$name} ~ : "\$this->{CLASS_HPLOO_ATTR}{$name}" ;
    }  eval(qq~ sub set_$name {
    my \$this = shift ;
    if ( !defined \$this->{$name} ) {
    tie( \$this->{$name} => 'Date::Object::HPLOO_TIESCALAR' , \$this , '$name' , '$type' , $parse_ref , \\\$this->{CLASS_HPLOO_ATTR}{$name} , \\\$this->{CLASS_HPLOO_CHANGED} , 'Date::Object' ) ;
    }  \$this->{CLASS_HPLOO_CHANGED}{$name} = 1 ;
    \$this->{CLASS_HPLOO_ATTR}{$name} = CLASS_HPLOO_ATTR_TYPE( ref(\$this) , '$type',\@_) ;
    } ~) if !defined &{"set_$name"} ;
    eval(qq~ sub get_$name {
    my \$this = shift ;
    $return ;
    } ~) if !defined &{"get_$name"} ;
    } }  { package Date::Object::HPLOO_TIESCALAR ;
    sub TIESCALAR {
    shift ;
    my $obj = shift ;
    my $this = bless( {
    nm => $_[0] , tp => $_[1] , pr => $_[2] , rf => $_[3] , rfcg => $_[4] , pk => ($_[5] || scalar caller) } , __PACKAGE__ ) ;
    if ( $this->{tp} =~ /^sub_(\w+)$/ ) {
    my $CLASS_HPLOO = Date::Object::GET_CLASS_HPLOO_HASH() ;
    if ( !ref($$CLASS_HPLOO{OBJ_TBL}) ) {
    eval {
    require Hash::NoRef } ;
    if ( !$@ ) {
    $$CLASS_HPLOO{OBJ_TBL} = {} ;
    tie( %{$$CLASS_HPLOO{OBJ_TBL}} , 'Hash::NoRef') ;
    } else {
    $@ = undef } }  $$CLASS_HPLOO{OBJ_TBL}{ ++$$CLASS_HPLOO{OBJ_TBL}{x} } = $obj ;
    $this->{oid} = $$CLASS_HPLOO{OBJ_TBL}{x} ;
    }  return $this ;
    }  sub STORE {
    my $this = shift ;
    my $ref = $this->{rf} ;
    my $ref_changed = $this->{rfcg} ;
    if ( $ref_changed ) {
    if ( ref $$ref_changed ne 'HASH' ) {
    $$ref_changed = {} } $$ref_changed->{$this->{nm}} = 1 ;
    }  if ( $this->{pr} ) {
    my $tp = $this->{tp} =~ /^ref/ ? $this->{tp} : 'ref' . $this->{tp} ;
    $$ref = &{"$this->{pk}::CLASS_HPLOO_ATTR_TYPE"}($this->{pk} , $tp , @_) ;
    } else {
    $$ref = &{"$this->{pk}::CLASS_HPLOO_ATTR_TYPE"}($this->{pk} , $this->{tp} , @_) ;
    } }  sub FETCH {
    my $this = shift ;
    my $ref = $this->{rf} ;
    if ( $this->{tp} =~ /^sub_(\w+)$/ ) {
    my $CLASS_HPLOO = Date::Object::GET_CLASS_HPLOO_HASH() ;
    my $sub = $this->{pk} . '::' . $1 ;
    my $obj = $$CLASS_HPLOO{OBJ_TBL}{ $this->{oid} } ;
    return (&$sub($obj,@_))[0] if defined &$sub ;
    } else {
    if ( $this->{tp} =~ /^(?:ref)?(?:array|hash)/ ) {
    my $ref_changed = $this->{rfcg} ;
    if ( $ref_changed ) {
    if ( ref $$ref_changed ne 'HASH' ) {
    $$ref_changed = {} } $$ref_changed->{$this->{nm}} = 1 ;
    } } return $$ref ;
    } return undef ;
    } sub UNTIE {} sub DESTROY {} }  sub CLASS_HPLOO_ATTR_TYPE {
    my $class = shift ;
    my $type = shift ;
    if ($type eq 'any') {
    return $_[0] } elsif ($type eq 'string') {
    return "$_[0]" ;
    } elsif ($type eq 'boolean') {
    return if $_[0] =~ /^(?:false|null|undef)$/i ;
    return 1 if $_[0] ;
    return ;
    } elsif ($type eq 'integer') {
    my $val = $_[0] ;
    my ($sig) = ( $val =~ /^(-)/ );
    $val =~ s/[^0-9]//gs ;
    $val = "$sig$val" ;
    return $val ;
    } elsif ($type eq 'floating') {
    my $val = $_[0] ;
    $val =~ s/[\s_]+//gs ;
    if ( $val !~ /^\d+\.\d+$/ ) {
    ($val) = ( $val =~ /(\d+)/ ) ;
    $val .= '.0' ;
    } return $val ;
    } elsif ($type =~ /^sub_(\w+)$/) {
    my $sub = $1 ;
    return (&$sub(@_))[0] if defined &$sub ;
    } elsif ($type =~ /^&(\w+)$/) {
    my $sub = $1 ;
    return (&$sub(@_))[0] if defined &$sub ;
    } elsif ($type eq 'ref') {
    my $val = $_[0] ;
    return $val if ref($val) ;
    } elsif ($type eq 'array') {
    my @val = @_ ;
    return \@val ;
    } elsif ($type eq 'hash') {
    my %val = @_ ;
    return \%val ;
    } elsif ($type eq 'refarray') {
    my $val = $_[0] ;
    return $val if ref($val) eq 'ARRAY' ;
    } elsif ($type eq 'refhash') {
    my $val = $_[0] ;
    return $val if ref($val) eq 'HASH' ;
    } elsif ($type =~ /^array(&?[\w:]+)/ ) {
    my $tp = $1 ;
    my @val = @_ ;
    my $accept_undef = $tp =~ /^(?:any|string|boolean|integer|floating|sub_\w+|&\w+)$/ ? 1 : undef ;
    if ( $accept_undef ) {
    return [map {
    CLASS_HPLOO_ATTR_TYPE($class , $tp , $_) } @val] ;
    } else {
    return [map {
    CLASS_HPLOO_ATTR_TYPE($class , $tp , $_) || () } @val] ;
    } } elsif ($type =~ /^hash(&?[\w:]+)/ ) {
    my $tp = $1 ;
    my %val = @_ ;
    foreach my $Key ( keys %val ) {
    $val{$Key} = CLASS_HPLOO_ATTR_TYPE($class , $tp , $val{$Key}) ;
    } return \%val ;
    } elsif ($type =~ /^refarray(&?[\w:]+)/ ) {
    my $tp = $1 ;
    return undef if ref($_[0]) ne 'ARRAY' ;
    my $ref = CLASS_HPLOO_ATTR_TYPE($class , "array$tp" , @{$_[0]}) ;
    @{$_[0]} = @{$ref} ;
    return $_[0] ;
    } elsif ($type =~ /^refhash(&?[\w:]+)/ ) {
    my $tp = $1 ;
    return undef if ref($_[0]) ne 'HASH' ;
    my $ref = CLASS_HPLOO_ATTR_TYPE($class , "hash$tp" , %{$_[0]}) ;
    %{$_[0]} = %{$ref} ;
    return $_[0] ;
    } elsif ($type =~ /^\w+(?:::\w+)*$/ ) {
    return( UNIVERSAL::isa($_[0] , $type) ? $_[0] : undef ) ;
    } return undef ;
  }

  no warnings ;

  use overload (
  '""' => '_OVER_string' ,
  '0+'  => '_OVER_number' ,
  'fallback' => 1 ,
  ) ;

  sub _OVER_string { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->date ;}
  sub _OVER_number { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->time ;}

  CLASS_HPLOO_ATTR('
        int time , int sec , int min , int hour , int day , int month , int year , int wday , int yday , int isdst , int zone ,
        sub zone_gmt ,
        sub s , sub m , sub h , sub d , sub mo , sub y , sub z ,
        sub serial ,
        sub date , sub date_zone ,
        sub hms , sub ymd , sub mdy , sub dmy ') ;

  my @MONTHS_DAYS = ('',31,28,31,30,31,30,31,31,30,31,30,31) ;

  sub Object {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my ( $year , $month , $day , $hour , $min , $sec , $zone , $time ) ;

    if ( $#_ == 0 && ref($_[0]) eq 'ARRAY' ) {
      ($zone , @_) = @{$_[0]} ;
    }

    my $time ;
    if ( !@_ ) { $time = time ;}
    elsif ( $#_ == 0 || $#_ == 1 ) {
      if ( ref($_[0]) && UNIVERSAL::isa($_[0],'Date::Object') ) {
        $time = $_[0]->time ;
        $zone = $_[0]->zone if $zone eq '' ;
      }
      elsif ( length($_[0]) >= 14 && $_[0] =~ /^\d+$/ ) {
        return new_serial('Date::Object',$_[0]) ;
      }
      elsif ( $_[0] =~ /^\s*(\d+)\D+(\d+)\D+(\d+)(?:\s+(\d\d?)\D+(\d\d?)(?:\D+(\d\d?))?)?/ ) {
        my ( $d , $m , $y , $h , $min , $s ) ;
        my @match = ($1 , $2 , $3 , $4 , $5 , $6) ;

        if ( $_[1] =~ /mdy/i ) {
          ( $m , $d , $y , $h , $min , $s ) = @match ;
        }
        elsif ( $_[1] =~ /dmy/i ) {
          ( $d , $m , $y , $h , $min , $s ) = @match ;
        }
        elsif ( $_[1] =~ /ymd/i ) {
          ( $y , $m , $d , $h , $min , $s ) = @match ;
        }
        else {
          ( $y , $m , $d , $h , $min , $s ) = @match ;
        }

        $time = $this->timelocal($y , $m , $d , $h , $min , $s , 0 ) ;
      }
      elsif ( $_[0] >= 0 ) { $time = $_[0] ;}
      else { $time = 0 ;}
    }
    else {
      if ($zone eq '') { $zone = $#_ >= 6 ? $_[6] : 0 ;}
      $time = $this->timelocal(@_[0..5] , $zone) ;
    }

    return UNDEF if $time == undef ;

    $this->{time} = $time ;

    if ( $zone ne '' ) { $this->set_zone($zone) ;}
    else { $this->set_gmt($time) ;}
  }

  sub new_gmt {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $class = shift ;
    new($class , [0,@_]) ;
  }

  sub new_local {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $class = shift ;
    my $zone = _calc_timezone() ;
    my $obj = new($class , [$zone , @_]) ;
    return $obj ;
  }

  sub new_zone {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $class = shift ;
    my $zone = shift ;
    my $obj = new($class , [$zone , @_]) ;
    return $obj ;
  }

  sub new_serial {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $class = shift ;
    my $serial = shift ;

    my ($time , $zone) = ( $serial =~ /^(\d+)(\d{4})$/ );

    if ( $zone > 1200 ) { $zone -= 1200 ;}
    elsif ( $zone == 1200 ) { $zone = 0 ;}
    else { $zone *= -1 ;}

    $zone =~ s/(\d\d)$/\.$1/ ;
    $zone =~ s/\.00$// ;
    $zone *= 1 ;

    my $obj = new($class , [$zone , $time]) ;
    return $obj ;
  }

  sub clone {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $clone = Date::Object->new_zone($this->zone , $this) ;
    return $clone ;
  }

  sub set_gmt {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $time = shift(@_) ;

    ($this->{sec} , $this->{min} , $this->{hour} , $this->{day} , $this->{month} , $this->{year} , $this->{wday} , $this->{yday} , $this->{isdst} ) = $this->gmtime($time) ;
    $this->{zone} = 0 ;
    $this->{time} = $time ;
    return $this ;
  }

  sub set_local {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $time = shift(@_) ;
    my $local_zone = shift(@_) ;

    ($this->{sec} , $this->{min} , $this->{hour} , $this->{day} , $this->{month} , $this->{year} , $this->{wday} , $this->{yday} , $this->{isdst} ) = $this->localtime($time) ;
    $this->{zone} = $this->_calc_timezone if $local_zone eq '' ;
    $this->{time} = $this->timelocal($this->{year} , $this->{month} , $this->{day} , $this->{hour} , $this->{min} , $this->{sec} , $this->{zone} ) ;
    return $this ;
  }

  sub set_zone {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $zone = shift(@_) ;
    my $time = shift(@_) ;

    $zone = $this->_format_zone($zone) if $zone ;

    $zone ||= $this->zone || 0 ;
    $time ||= $this->time ;

    $this->{zone} = $zone ;

    my $time_gmt = $time + (60*60*$zone) ;

    ($this->{sec} , $this->{min} , $this->{hour} , $this->{day} , $this->{month} , $this->{year} , $this->{wday} , $this->{yday} , $this->{isdst} ) = $this->gmtime($time_gmt) ;

    if ( $zone ) {
      my $local_zone = $this->_calc_timezone ;
      if ( $zone == $local_zone ) {
        ( $this->{isdst} ) = ($this->localtime($time))[8] ;
      }
      else { $this->{isdst} = 0 ;}
    }

    $this->{time} = $time ;
    return $this ;
  }

  sub set_serial {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $serial = shift(@_) ;

    my ($time , $zone) = ( $serial =~ /^(\d+)(\d{4})$/ );

    if ( $zone > 1200 ) { $zone -= 1200 ;}
    elsif ( $zone == 1200 ) { $zone = 0 ;}
    else { $zone *= -1 ;}

    $zone =~ s/(\d\d)$/\.$1/ ;
    $zone =~ s/\.00$// ;
    $zone *= 1 ;

    $this->set_zone($zone , $time) ;

    return $this ;
  }

  sub set {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $y = shift(@_) ;
    my $mo = shift(@_) ;
    my $d = shift(@_) ;
    my $h = shift(@_) ;
    my $m = shift(@_) ;
    my $s = shift(@_) ;

    $y = $this->{y} if !defined $y ;
    $mo = $this->{mo} if !defined $mo ;
    $d = $this->{d} if !defined $d ;
    $h = $this->{h} if !defined $h ;
    $m = $this->{m} if !defined $m ;
    $s = $this->{s} if !defined $s ;

    if ( $d > $this->check($mo) ) { $d = $this->check($mo) ;}

    my $new_date = Date::Object->new_zone( $this->zone , $y , $mo , $d , $h , $m , $s ) ;
    $this->set_serial( $new_date->serial ) ;

    return $this ;
  }

  sub _format_zone {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $zone = shift(@_) ;

    $zone ||= 0 ;
    if ( $zone > 12 ) { $zone = 12 ;}
    if ( $zone < -12 ) { $zone = -12 ;}
    $zone =~ s/(\.\d{1,2})\d*/$1/ ;
    return $zone ;
  }

  sub _calc_timezone {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $d0 = Date::Object->new(time) ;

    my ($sec,$min,$hour,$mday,$mon,$year) = $d0->localtime ;
    my $d1 = Date::Object->new($year , $mon , $mday , $hour , $min ,$sec) ;

    my $zone = $d1->time - $d0->time ;
    $zone /= 60*60 ;

    $zone =~ s/(\.\d\d)\d*/$1/ ;

    return $zone ;
  }

  sub zone { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{zone} ;}

  sub zone_gmt {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my ($sign,$h,$m) = ( $this->{zone} =~ /^([\+\-]?)(\d{1,2})\d*(?:\.(\d{1,2})\d*)?$/ );

    $sign ||= '+' ;

    $h = "0$h" while length($h) < 2 ;
    $m = "0$m" while length($m) < 2 ;

    my $z = "$sign$h$m" ;
    return $z ;
  }

  sub time { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{time} ;}

  sub sec { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{sec} ;}
  sub min { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{min} ;}
  sub hour { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{hour} ;}
  sub day { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{day} ;}
  sub month { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{month} ;}
  sub year { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{year} ;}
  sub wday { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{wday} ;}
  sub yday { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{yday} ;}
  sub isdst { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{isdst} ;}

  sub s { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{sec} ;}
  sub m { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{min} ;}
  sub h { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{hour} ;}
  sub d { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{day} ;}
  sub mo { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{month} ;}
  sub y { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{year} ;}
  sub z { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->{zone} ;}

  sub serial {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $z = $this->zone_gmt ;
    if    ( $z =~ /^-(\d+)/ ) { $z = $1 ;}
    elsif ( $z =~ /^[\+]?(\d+)/ ) { $z = $1 + 1200 ;}
    my $serial = $this->time . $z ;
    while( length($serial) < 14 ) { $serial = "0$serial" ;}
    return $serial ;
  }

  sub add_sec {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $secs = shift(@_) ;

    $secs ||= 1 ;
    $this->{time} += $secs ;
    $this->set_zone ;
  }

  sub add_min {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $mins = shift(@_) ;

    $mins ||= 1 ;
    $this->{time} += 60*$mins ;
    $this->set_zone ;
  }

  sub add_hour {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $hours = shift(@_) ;

    $hours ||= 1 ;
    $this->{time} += 60*60*$hours ;
    $this->set_zone ;
  }

  sub add_day {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $days = shift(@_) ;

    $days ||= 1 ;
    $this->{time} += 60*60*24*$days ;
    $this->set_zone ;
  }

  sub add_week {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $weeks = shift(@_) ;

    $weeks ||= 1 ;
    $this->add_day(7*$weeks) ;
  }

  sub add_month {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $months = shift(@_) ;

    $months ||= 1 ;

    if ( $months < 0 ) { return $this->sub_month($months*-1) ;}

    my $y = $this->y ;
    my $mo = $this->mo ;

    for my $i (1..$months) {
      ++$mo ;
      if ( $mo > 12 ) { $mo = 1 ; ++$y ;}
    }

    $this->{time} = $this->timelocal( $y , $mo , $this->d , $this->h , $this->m , $this->s , $this->z ) ;
    $this->set_zone ;
  }

  sub sub_month {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $months = shift(@_) ;

    $months ||= 1 ;

    if ( $months < 0 ) { return $this->add_month($months*-1) ;}

    my $y = $this->y ;
    my $mo = $this->mo ;

    for my $i (1..$months) {
      --$mo ;
      if ( $mo < 1 ) { $mo = 12 ; --$y ;}
    }

    $this->{time} = $this->timelocal( $y , $mo , $this->d , $this->h , $this->m , $this->s , $this->z ) ;
    $this->set_zone ;
  }

  sub add_year {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $years = shift(@_) ;

    $years ||= 1 ;
    $this->add_month(12*$years) ;
  }

  sub sub_sec { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ;my $n = shift(@_) ; $n ||= 1 ; $this->add_sec(  $n*-1 ) ;}
  sub sub_min { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ;my $n = shift(@_) ; $n ||= 1 ; $this->add_min(  $n*-1 ) ;}
  sub sub_hour { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ;my $n = shift(@_) ; $n ||= 1 ; $this->add_hour( $n*-1 ) ;}
  sub sub_day { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ;my $n = shift(@_) ; $n ||= 1 ; $this->add_day(  $n*-1 ) ;}
  sub sub_week { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ;my $n = shift(@_) ; $n ||= 1 ; $this->add_week( $n*-1 ) ;}
  sub sub_year { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ;my $n = shift(@_) ; $n ||= 1 ; $this->add_year( $n*-1 ) ;}

  sub gmtime {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $time = shift(@_) ;

    $time ||= $this->{time} || time ;
    return _fix_vars_time( gmtime($time) ) ;
  }

  sub localtime {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $time = shift(@_) ;

    $time ||= $this->{time} || time ;
    return _fix_vars_time( localtime($time) ) ;
  }

  sub _fix_vars_time {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $sec = shift(@_) ;
    my $min = shift(@_) ;
    my $hour = shift(@_) ;
    my $mday = shift(@_) ;
    my $mon = shift(@_) ;
    my $year = shift(@_) ;
    my $wday = shift(@_) ;
    my $yday = shift(@_) ;
    my $isdst = shift(@_) ;

    ++$mon ;
    $year += 1900 ;
    ++$yday ;

    $sec  = "0$sec"  if $sec  < 10 ;
    $min  = "0$min"  if $min  < 10 ;
    $hour = "0$hour" if $hour < 10 ;
    $mday = "0$mday" if $mday < 10 ;
    $mon  = "0$mon"  if $mon  < 10 ;

    return ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) ;
  }

  sub timelocal {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $year = shift(@_) ;
    my $mon = shift(@_) ;
    my $day = shift(@_) ;
    my $hour = shift(@_) ;
    my $min = shift(@_) ;
    my $sec = shift(@_) ;
    my $zone = shift(@_) ;


    $zone = _format_zone($zone) ;

    my $year_0 = (gmtime(1))[5] + 1900 ;

    my ($now_sec,$now_min,$now_hour,$now_mday,$now_mon,$now_year) = $this->gmtime ;

    if (!$year || $year eq '*' || $year < $year_0) { $year = $now_year ;}

    my $year_bisexto = 0 ;
    if ( $this->is_leap_year($year) ) { $year_bisexto = 1 ;}

    if (!$mon || $mon eq '*') { $mon = $now_mon }
    elsif ($mon < 1 || $mon > 12 ) { return }

    elsif (!$day || $day eq '*') { $day = $now_mday }
    elsif ($day < 1 || $day > 31 ) { return }
    elsif ($mon == 2 && $day > 28) {
      $day = 28 if !$this->check($year,$mon,$day) ;
    }
    elsif ($day > $this->check($mon) ) { return }

    if    ($hour eq '') { $hour = 0 }
    elsif ($hour eq '*') { $hour = $now_hour }
    elsif ($hour == 24) { $hour = 0 }
    elsif ($hour < 0 || $hour > 24 ) { return }

    if    ($min eq '') { $min = 0 }
    elsif ($min eq '*') { $min = $now_min }
    elsif ($min == 60) { $min = 59 }
    elsif ($min < 0 || $min > 60 ) { return }

    if    ($sec eq '') { $sec = 0 }
    elsif ($sec eq '*') { $sec = $now_sec }
    elsif ($sec == 60) { $sec = 59 }
    elsif ($sec < 0 || $sec > 60 ) { return }

    my $timelocal ;

    my $time_day = 60*60*24 ;
    my $time_year = $time_day * 365 ;

    for my $y ($year_0..($year-1)) {
      $timelocal += $time_year ;
      if ( $this->is_leap_year($y) ) { $timelocal += $time_day ;}
    }

    for my $m (1..($mon-1)) {
      my $month_days = &check($m) ;
      $timelocal += $month_days * $time_day ;
    }

    if ($year_bisexto == 1 && $mon > 2) { $timelocal += $time_day ;}

    $timelocal += $time_day * ($day-1) ;

    $timelocal += 60*60 * $hour ;
    $timelocal += 60 * $min ;
    $timelocal += $sec ;

    $timelocal += 60*60*($zone*-1) if $zone ;

    return $timelocal ;
  }

  sub check {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    shift if $_[0] !~ /^\d+$/ ;

    my ( $year , $month , $day ) ;

    if ($#_ == 2) { ( $year , $month , $day ) = @_ ;}
    if ($#_ == 1) { ( $month , $day ) = @_ ;}
    if ($#_ == 0) { ( $month ) = @_ ;}

    if ($#_ > 0) {
      if ($year eq '')  { $year = 1970 }
      if ($month eq '') { $month = 1 }
      if ($day eq '')   { $day = 1 }

      my @months_days = @MONTHS_DAYS ;

      if ( $this->is_leap_year($year) ) { $months_days[2] = 29 ;}

      if ($day <= $months_days[$month]) { return 1 ;}
      else { return ;}
    }
    elsif ($#_ == 0) {
      if ($month eq '') { return ; }
      return $MONTHS_DAYS[$month] ;
    }

    return undef ;
  }

  # The Egyptians called it 365 and left it at that. But their calendar got out of step with the seasons, so that
  # after around 750 years of this they were celebrating The Fourth of July in the middle of the winter.
  #
  # The Romans wised up and added the leap day every four years to get the 365.25 day Julian year. Much better,
  # but notice that this time the year is longer than it ought to be. The small difference between this and the
  # true length of the year caused the seasons to creep through the calendar once again, only slower and in the
  # other direction. After about 23000 years of this, July Fourth would once again fall in mid-winter.
  #
  # Fortunately things never reached that sad state. By 1582 the calendar was about ten days out of whack, so
  # Pope Gregory XIII included the correction that's still in use today.
  #
  # "If the year is divisible by 100, it's not a leap year UNLESS it is also divisible by 400."
  #
  # More recently, proposals for fixes have gotten even better than that. One suggested change is to add on "if
  # the year is also divisible by 4000, it's not a leap year."

  sub is_leap_year {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $year = shift(@_) ;

    $year = $this->{year} if $year eq '' ;

    if    ($year == 0) { return 1 ;}
    elsif (($year % 4000) == 0) { return 0 ;}
    elsif (($year % 400) == 0) { return 1 ;}
    elsif (($year % 100) == 0) { return 0 ;}
    elsif (($year % 4) == 0) { return 1 ;}
    return 0 ;
  }

  sub secs_from {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $time_0 = $this->time ;
    my $time_1 = Date::Object->new(@_)->time ;

    my $delay = $time_0 - $time_1 ;
    return $delay ;
  }

  sub min_from {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $delay = $this->secs_from(@_) ;
    my $min = int($delay / (60)) ;
    return $min ;
  }

  sub hours_from {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $delay = $this->secs_from(@_) ;
    my $hours = int($delay / (60*60)) ;
    return $hours ;
  }

  sub days_from {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $delay = $this->secs_from(@_) ;
    my $days = int($delay / (60*60*24)) ;
    return $days ;
  }

  sub weeks_from {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $days = $this->days_from(@_) ;
    my $weeks = int($days / 7) ;
    return $weeks ;
  }

  sub months_from {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $days = $this->days_from(@_) ;
    my $months = int($days / 30) ;
    return $months ;
  }

  sub years_from {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $days = $this->days_from(@_) ;
    my $years = int($days / 365) ;
    return $years ;
  }

  sub secs_until { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->secs_from(@_) * -1 ;}
  sub min_until { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->min_from(@_) * -1 ;}
  sub hours_until { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->hours_from(@_) * -1 ;}
  sub days_until { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->days_from(@_) * -1 ;}
  sub weeks_until { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->weeks_from(@_) * -1 ;}
  sub months_until { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->months_from(@_) * -1 ;}
  sub years_until { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->years_from(@_) * -1 ;}

  sub secs_between { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; my $r = $this->secs_from(@_) ; $r < 0 ? ($r*-1) : $r ;}
  sub min_between { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; my $r = $this->min_from(@_) ; $r < 0 ? ($r*-1) : $r ;}
  sub hours_between { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; my $r = $this->hours_from(@_) ; $r < 0 ? ($r*-1) : $r ;}
  sub days_between { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; my $r = $this->days_from(@_) ; $r < 0 ? ($r*-1) : $r ;}
  sub weeks_between { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; my $r = $this->weeks_from(@_) ; $r < 0 ? ($r*-1) : $r ;}
  sub months_between { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; my $r = $this->months_from(@_) ; $r < 0 ? ($r*-1) : $r ;}
  sub years_between { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; my $r = $this->years_from(@_) ; $r < 0 ? ($r*-1) : $r ;}

  sub date {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $date = "$this->{year}-$this->{month}-$this->{day} $this->{hour}:$this->{min}:$this->{sec}" ;
    return $date ;
  }

  sub date_zone {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $z = $this->zone_gmt ;
    my $date = "$this->{year}-$this->{month}-$this->{day} $this->{hour}:$this->{min}:$this->{sec} $z" ;
    return $date ;
  }

  sub hour {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $date = "$this->{hour}:$this->{min}:$this->{sec}" ;
    return $date ;
  }

  sub hms { my $this = ref($_[0]) ? shift : undef ;my $CLASS = ref($this) || __PACKAGE__ ; $this->hour }

  sub ymd {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $date = "$this->{year}-$this->{month}-$this->{day}" ;
    return $date ;
  }

  sub mdy {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $date = "$this->{month}-$this->{day}-$this->{year}" ;
    return $date ;
  }

  sub dmy {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;

    my $date = "$this->{day}-$this->{month}-$this->{year}" ;
    return $date ;
  }

  sub STORABLE_freeze {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $cloning = shift(@_) ;

    return $this->serial ;
  }

  sub STORABLE_thaw {
    my $this = ref($_[0]) ? shift : undef ;
    my $CLASS = ref($this) || __PACKAGE__ ;
    my $cloning = shift(@_) ;
    my $serial = shift(@_) ;

    $this->set_serial($serial) ;
    return ;
  }


}



1;

__END__