|
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:
|