Blame lib/Date/Manip/Obj.pm

Packit 95306a
package Date::Manip::Obj;
Packit 95306a
# Copyright (c) 2008-2017 Sullivan Beck. All rights reserved.
Packit 95306a
# This program is free software; you can redistribute it and/or modify it
Packit 95306a
# under the same terms as Perl itself.
Packit 95306a
Packit 95306a
########################################################################
Packit 95306a
########################################################################
Packit 95306a
Packit 95306a
require 5.010000;
Packit 95306a
use warnings;
Packit 95306a
use strict;
Packit 95306a
use IO::File;
Packit 95306a
use Storable qw(dclone);
Packit 95306a
Packit 95306a
our ($VERSION);
Packit 95306a
$VERSION='6.60';
Packit 95306a
END { undef $VERSION; }
Packit 95306a
Packit 95306a
########################################################################
Packit 95306a
# METHODS
Packit 95306a
########################################################################
Packit 95306a
Packit 95306a
my %classes = ( 'Date::Manip::Base'   => 1,
Packit 95306a
                'Date::Manip::TZ'     => 1,
Packit 95306a
                'Date::Manip::Date'   => 1,
Packit 95306a
                'Date::Manip::Delta'  => 1,
Packit 95306a
                'Date::Manip::Recur'  => 1,
Packit 95306a
              );
Packit 95306a
Packit 95306a
sub new {
Packit 95306a
   my(@args)    = @_;
Packit 95306a
   my(@allargs) = @args;
Packit 95306a
Packit 95306a
   # $old    is the object (if any) being used to create a new object
Packit 95306a
   # $new    is the new object
Packit 95306a
   # $class  is the class of the new object
Packit 95306a
   # $tz     is a Date::Manip::TZ object to base the new object on
Packit 95306a
   #         (only for Date, Delta, Recur objects)
Packit 95306a
   # $base   is the Date::Manip::Base object to base the new object on
Packit 95306a
   # @opts   options to pass to config method
Packit 95306a
Packit 95306a
   my($old,$new,$class,$tz,$base,@opts);
Packit 95306a
Packit 95306a
   # Get the class of the new object
Packit 95306a
Packit 95306a
   if (exists $classes{ $args[0] }) {
Packit 95306a
Packit 95306a
      # $obj = new CLASS
Packit 95306a
      $class = shift(@args);
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
Packit 95306a
      # $obj->new
Packit 95306a
      $class = ref($args[0]);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   # Find out if there are any config options (which will be the
Packit 95306a
   # final argument).
Packit 95306a
Packit 95306a
   if (@args  &&  ref($args[$#args]) eq 'ARRAY') {
Packit 95306a
      @opts = @{ pop(@args) };
Packit 95306a
   }
Packit 95306a
Packit 95306a
   # Get an old object
Packit 95306a
Packit 95306a
   if (ref($args[0]) =~ /^Date::Manip/) {
Packit 95306a
      # $old->new
Packit 95306a
      # new CLASS $old
Packit 95306a
      $old = shift(@args);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   # Additional arguments will be passed to parse.
Packit 95306a
Packit 95306a
   ########################
Packit 95306a
Packit 95306a
   # Get Base/TZ objects from an existing object
Packit 95306a
Packit 95306a
   if ($old) {
Packit 95306a
      if (ref($old) eq 'Date::Manip::Base') {
Packit 95306a
         $base = $old;
Packit 95306a
      } elsif (ref($old) eq 'Date::Manip::TZ') {
Packit 95306a
         $tz   = $old;
Packit 95306a
         $base = $$tz{'base'};
Packit 95306a
Packit 95306a
      # *** I think this is useless code, deprecate
Packit 95306a
      # } elsif (ref($old) eq 'ARRAY') {
Packit 95306a
      #    my %old = @$old;
Packit 95306a
      #    $tz   = $old{'tz'};
Packit 95306a
      #    $base = $$tz{'base'};
Packit 95306a
Packit 95306a
      } else {
Packit 95306a
         $tz   = $$old{'tz'};
Packit 95306a
         $base = $$tz{'base'};
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   # Create a new empty object.
Packit 95306a
Packit 95306a
   $new = {
Packit 95306a
           'data' => {},
Packit 95306a
           'err'  => '',
Packit 95306a
          };
Packit 95306a
Packit 95306a
   # Create Base/TZ objects if necessary
Packit 95306a
Packit 95306a
   if ($base  &&  @opts) {
Packit 95306a
      $base = _clone($base);
Packit 95306a
      $tz   = new Date::Manip::TZ $base  if ($tz);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   my $init = 1;
Packit 95306a
   if ($class eq 'Date::Manip::Base') {
Packit 95306a
      if ($base) {
Packit 95306a
         # new Date::Manip::Base $base
Packit 95306a
         #
Packit 95306a
         # We have to clone it (which we already did if @opts was given)
Packit 95306a
         #
Packit 95306a
         if (@opts) {
Packit 95306a
            $new = $base;
Packit 95306a
         } else {
Packit 95306a
            $new = _clone($base);
Packit 95306a
         }
Packit 95306a
         $init = 0;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } elsif ($class eq 'Date::Manip::TZ') {
Packit 95306a
      if ($tz) {
Packit 95306a
         # new Date::Manip::TZ $tz
Packit 95306a
         if (@opts) {
Packit 95306a
            $new = $tz;
Packit 95306a
         } else {
Packit 95306a
            $new = _clone($tz);
Packit 95306a
         }
Packit 95306a
         $init = 0;
Packit 95306a
      } elsif (! $base) {
Packit 95306a
         $base = new Date::Manip::Base;
Packit 95306a
      }
Packit 95306a
      $$new{'base'} = $base;
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      if (! $tz) {
Packit 95306a
         if ($base) {
Packit 95306a
            $tz = new Date::Manip::TZ $base;
Packit 95306a
         } else {
Packit 95306a
            $tz = new Date::Manip::TZ;
Packit 95306a
         }
Packit 95306a
      }
Packit 95306a
      $$new{'tz'} = $tz;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   $$new{'args'} = [ @args ];
Packit 95306a
   bless $new,$class;
Packit 95306a
Packit 95306a
   $new->_init()        if ($init);
Packit 95306a
   $new->config(@opts)  if (@opts);
Packit 95306a
   $new->_init_args()   if (@args);
Packit 95306a
   $new->_init_final();
Packit 95306a
   return $new;
Packit 95306a
}
Packit 95306a
Packit 95306a
# This clones an object.  Currently, it only clones a Base or TZ
Packit 95306a
# object, but dclone can't handle stored regexps so we have to copy
Packit 95306a
# them manually.
Packit 95306a
#
Packit 95306a
sub _clone {
Packit 95306a
   my($obj) = @_;
Packit 95306a
Packit 95306a
   if (ref($obj) eq 'Date::Manip::Base') {
Packit 95306a
Packit 95306a
      my $tmp              = $$obj{'data'}{'rx'};
Packit 95306a
      delete $$obj{'data'}{'rx'};
Packit 95306a
      my $new              = dclone($obj);
Packit 95306a
      $$obj{'data'}{'rx'}  = $tmp;
Packit 95306a
      $$new{'data'}{'rx'}  = $tmp;
Packit 95306a
      return $new;
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
Packit 95306a
      my $base = $$obj{'base'};
Packit 95306a
      delete $$obj{'base'};
Packit 95306a
Packit 95306a
      my @rx = qw(namerx zonerx abbrx offrx zrx offabbrx orrparrx);
Packit 95306a
      my @tmp;
Packit 95306a
      foreach my $rx (@rx) {
Packit 95306a
         push(@tmp,$$obj{'data'}{$rx});
Packit 95306a
         delete $$obj{'data'}{$rx};
Packit 95306a
      }
Packit 95306a
Packit 95306a
      my $new  = dclone($obj);
Packit 95306a
Packit 95306a
      foreach my $rx (@rx) {
Packit 95306a
         my $r = shift(@tmp);
Packit 95306a
         $$obj{'data'}{$rx}  = $r;
Packit 95306a
         $$new{'data'}{$rx} = $r;
Packit 95306a
      }
Packit 95306a
Packit 95306a
      $$obj{'base'} = $base;
Packit 95306a
      $$new{'base'} = $base;
Packit 95306a
      return $new;
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
# Only called if extra @args exist
Packit 95306a
sub _init_args {
Packit 95306a
   my($self) = @_;
Packit 95306a
Packit 95306a
   my @args = @{ $$self{'args'} };
Packit 95306a
   warn "WARNING: [new] invalid arguments: @args\n";
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _init_final {
Packit 95306a
   my($self) = @_;
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub new_config {
Packit 95306a
   my(@args) = @_;
Packit 95306a
Packit 95306a
   # Make sure that @opts is passed in as the final argument.
Packit 95306a
Packit 95306a
   if (! @args  ||
Packit 95306a
       ! (ref($args[$#args]) eq 'ARRAY')) {
Packit 95306a
      push(@args,['ignore','ignore']);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return new(@args);
Packit 95306a
}
Packit 95306a
Packit 95306a
sub new_date {
Packit 95306a
   my(@args) = @_;
Packit 95306a
   require Date::Manip::Date;
Packit 95306a
   return new Date::Manip::Date @args;
Packit 95306a
}
Packit 95306a
sub new_delta {
Packit 95306a
   my(@args) = @_;
Packit 95306a
   require Date::Manip::Delta;
Packit 95306a
   return new Date::Manip::Delta @args;
Packit 95306a
}
Packit 95306a
sub new_recur {
Packit 95306a
   my(@args) = @_;
Packit 95306a
   require Date::Manip::Recur;
Packit 95306a
   return new Date::Manip::Recur @args;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub base {
Packit 95306a
   my($self) = @_;
Packit 95306a
   my $t = ref($self);
Packit 95306a
   if ($t eq 'Date::Manip::Base') {
Packit 95306a
      return undef;
Packit 95306a
   } elsif ($t eq 'Date::Manip::TZ') {
Packit 95306a
      return $$self{'base'};
Packit 95306a
   } else {
Packit 95306a
      my $dmt = $$self{'tz'};
Packit 95306a
      return $$dmt{'base'};
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
sub tz {
Packit 95306a
   my($self) = @_;
Packit 95306a
   my $t = ref($self);
Packit 95306a
Packit 95306a
   if ($t eq 'Date::Manip::Base'  ||
Packit 95306a
       $t eq 'Date::Manip::TZ') {
Packit 95306a
      return undef;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return $$self{'tz'};
Packit 95306a
}
Packit 95306a
Packit 95306a
sub config {
Packit 95306a
   my($self,@opts) = @_;
Packit 95306a
   my $obj;
Packit 95306a
   if (ref($self) eq 'Date::Manip::Base'  ||
Packit 95306a
       ref($self) eq 'Date::Manip::TZ') {
Packit 95306a
      $obj = $self;
Packit 95306a
   } else {
Packit 95306a
      $obj = $$self{'tz'};
Packit 95306a
   }
Packit 95306a
Packit 95306a
   while (@opts) {
Packit 95306a
      my $var = shift(@opts);
Packit 95306a
      my $val = shift(@opts);
Packit 95306a
      $obj->_config_var($var,$val);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub get_config {
Packit 95306a
   my($self,@args) = @_;
Packit 95306a
Packit 95306a
   my $base;
Packit 95306a
   my $t = ref($self);
Packit 95306a
   if ($t eq 'Date::Manip::Base') {
Packit 95306a
      $base = $self;
Packit 95306a
   } elsif ($t eq 'Date::Manip::TZ') {
Packit 95306a
      $base = $$self{'base'};
Packit 95306a
   } else {
Packit 95306a
      my $dmt = $$self{'tz'};
Packit 95306a
      $base = $$dmt{'base'};
Packit 95306a
   }
Packit 95306a
Packit 95306a
   if (@args) {
Packit 95306a
      my @ret;
Packit 95306a
      foreach my $var (@args) {
Packit 95306a
         # uncoverable branch false
Packit 95306a
         if (exists $$base{'data'}{'sections'}{'conf'}{lc($var)}) {
Packit 95306a
            push @ret,$$base{'data'}{'sections'}{'conf'}{lc($var)};
Packit 95306a
         } else {
Packit 95306a
            # uncoverable statement
Packit 95306a
            warn "ERROR: [config] invalid config variable: $var\n";
Packit 95306a
            # uncoverable statement
Packit 95306a
            return '';
Packit 95306a
         }
Packit 95306a
      }
Packit 95306a
Packit 95306a
      if (@ret == 1) {
Packit 95306a
         return $ret[0];
Packit 95306a
      } else {
Packit 95306a
         return @ret;
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   my @ret = sort keys %{ $$base{'data'}{'sections'}{'conf'} };
Packit 95306a
   return @ret;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub err {
Packit 95306a
   my($self,$arg) = @_;
Packit 95306a
   if ($arg) {
Packit 95306a
      $$self{'err'} = '';
Packit 95306a
      return;
Packit 95306a
   } else {
Packit 95306a
      return $$self{'err'};
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
sub is_date {
Packit 95306a
   return 0;
Packit 95306a
}
Packit 95306a
sub is_delta {
Packit 95306a
   return 0;
Packit 95306a
}
Packit 95306a
sub is_recur {
Packit 95306a
   return 0;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub version {
Packit 95306a
   my($self,$flag) = @_;
Packit 95306a
   if ($flag  &&  ref($self) ne 'Date::Manip::Base') {
Packit 95306a
      my $dmt;
Packit 95306a
      if (ref($self) eq 'Date::Manip::TZ') {
Packit 95306a
         $dmt = $self;
Packit 95306a
      } else {
Packit 95306a
         $dmt  = $$self{'tz'};
Packit 95306a
      }
Packit 95306a
      my $tz = $dmt->_now('systz');
Packit 95306a
      return "$VERSION [$tz]";
Packit 95306a
   } else {
Packit 95306a
      return $VERSION;
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
1;
Packit 95306a
# Local Variables:
Packit 95306a
# mode: cperl
Packit 95306a
# indent-tabs-mode: nil
Packit 95306a
# cperl-indent-level: 3
Packit 95306a
# cperl-continued-statement-offset: 2
Packit 95306a
# cperl-continued-brace-offset: 0
Packit 95306a
# cperl-brace-offset: 0
Packit 95306a
# cperl-brace-imaginary-offset: 0
Packit 95306a
# cperl-label-offset: 0
Packit 95306a
# End: