home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Object.pm < prev    next >
Encoding:
Perl POD Document  |  2002-09-29  |  43.5 KB  |  1,697 lines
  1.  
  2. ###############################################################################
  3. ##                                                                           ##
  4. ##    Copyright (c) 2000 - 2002 by Steffen Beyer.                            ##
  5. ##    All rights reserved.                                                   ##
  6. ##                                                                           ##
  7. ##    This package is free software; you can redistribute it                 ##
  8. ##    and/or modify it under the same terms as Perl itself.                  ##
  9. ##                                                                           ##
  10. ###############################################################################
  11.  
  12. ###############################################################################
  13. ##                                                                           ##
  14. ## Mottos of this module:                                                    ##
  15. ##                                                                           ##
  16. ## 1) Small is beautiful.                                                    ##
  17. ##                                                                           ##
  18. ## 2) Make frequent things easy and infrequent or hard things possible.      ##
  19. ##                                                                           ##
  20. ###############################################################################
  21.  
  22. package Date::Calc::Object;
  23.  
  24. use strict;
  25. use vars qw(@ISA @AUXILIARY @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  26.  
  27. use Carp::Clan qw(^Date::);
  28.  
  29. BEGIN # Re-export imports from Date::Calc:
  30. {
  31.     require Exporter;
  32.     require Date::Calc;
  33.     @ISA         = qw(Exporter Date::Calc);
  34.     @AUXILIARY   = qw(shift_year shift_date shift_time shift_datetime);
  35.     @EXPORT      = @Date::Calc::EXPORT;
  36.     @EXPORT_OK   = (@Date::Calc::EXPORT_OK,@AUXILIARY);
  37.     %EXPORT_TAGS = (all => [@Date::Calc::EXPORT_OK],
  38.                     aux => [@AUXILIARY],
  39.                     ALL => [@EXPORT_OK]);
  40.     $VERSION     = '5.3';
  41.     Date::Calc->import(@Date::Calc::EXPORT,@Date::Calc::EXPORT_OK);
  42. }
  43.  
  44. sub shift_year
  45. {
  46.     croak("internal error - parameter is not an ARRAY ref") if (ref($_[0]) ne 'ARRAY');
  47.  
  48.     if (ref($_[0][0]))
  49.     {
  50.         if (ref($_[0][0]) eq 'ARRAY')
  51.         {
  52.             if (@{$_[0][0]} == 3) # otherwise anonymous array is pointless
  53.             {
  54.                 return ${shift(@{$_[0]})}[0];
  55.             }
  56.             else
  57.             {
  58.                 croak("wrong number of elements in date constant");
  59.             }
  60.         }
  61.         elsif (ref($_[0][0]) =~ /[^:]::[^:]/)
  62.         {
  63.             return shift(@{$_[0]})->year();
  64.         }
  65.         else
  66.         {
  67.             croak("input parameter is neither ARRAY ref nor object");
  68.         }
  69.     }
  70.     else
  71.     {
  72.         if (@{$_[0]} >= 1)
  73.         {
  74.             return shift(@{$_[0]});
  75.         }
  76.         else
  77.         {
  78.             croak("not enough input parameters for a year");
  79.         }
  80.     }
  81. }
  82.  
  83. sub shift_date
  84. {
  85.     croak("internal error - parameter is not an ARRAY ref") if (ref($_[0]) ne 'ARRAY');
  86.  
  87.     if (ref($_[0][0]))
  88.     {
  89.         if (ref($_[0][0]) eq 'ARRAY')
  90.         {
  91.             if (@{$_[0][0]} == 3)
  92.             {
  93.                 return( @{shift(@{$_[0]})} );
  94.             }
  95.             else
  96.             {
  97.                 croak("wrong number of elements in date constant");
  98.             }
  99.         }
  100.         elsif (ref($_[0][0]) =~ /[^:]::[^:]/)
  101.         {
  102.             return( shift(@{$_[0]})->date() );
  103.         }
  104.         else
  105.         {
  106.             croak("input parameter is neither ARRAY ref nor object");
  107.         }
  108.     }
  109.     else
  110.     {
  111.         if (@{$_[0]} >= 3)
  112.         {
  113.             return( shift(@{$_[0]}), shift(@{$_[0]}), shift(@{$_[0]}) );
  114.         }
  115.         else
  116.         {
  117.             croak("not enough input parameters for a date");
  118.         }
  119.     }
  120. }
  121.  
  122. sub shift_time
  123. {
  124.     croak("internal error - parameter is not an ARRAY ref") if (ref($_[0]) ne 'ARRAY');
  125.  
  126.     if (ref($_[0][0]))
  127.     {
  128.         if (ref($_[0][0]) eq 'ARRAY')
  129.         {
  130.             if (@{$_[0][0]} == 3)
  131.             {
  132.                 return( @{shift(@{$_[0]})} );
  133.             }
  134.             else
  135.             {
  136.                 croak("wrong number of elements in time constant");
  137.             }
  138.         }
  139.         elsif (ref($_[0][0]) =~ /[^:]::[^:]/)
  140.         {
  141.             return( (shift(@{$_[0]})->datetime())[3,4,5] );
  142.         }
  143.         else
  144.         {
  145.             croak("input parameter is neither ARRAY ref nor object");
  146.         }
  147.     }
  148.     else
  149.     {
  150.         if (@{$_[0]} >= 3)
  151.         {
  152.             return( shift(@{$_[0]}), shift(@{$_[0]}), shift(@{$_[0]}) );
  153.         }
  154.         else
  155.         {
  156.             croak("not enough input parameters for time values");
  157.         }
  158.     }
  159. }
  160.  
  161. sub shift_datetime
  162. {
  163.     croak("internal error - parameter is not an ARRAY ref") if (ref($_[0]) ne 'ARRAY');
  164.  
  165.     if (ref($_[0][0]))
  166.     {
  167.         if (ref($_[0][0]) eq 'ARRAY')
  168.         {
  169.             if (@{$_[0][0]} == 6)
  170.             {
  171.                 return( @{shift(@{$_[0]})} );
  172.             }
  173.             else
  174.             {
  175.                 croak("wrong number of elements in date-time constant");
  176.             }
  177.         }
  178.         elsif (ref($_[0][0]) =~ /[^:]::[^:]/)
  179.         {
  180.             return( shift(@{$_[0]})->datetime() );
  181.         }
  182.         else
  183.         {
  184.             croak("input parameter is neither ARRAY ref nor object");
  185.         }
  186.     }
  187.     else
  188.     {
  189.         if (@{$_[0]} >= 6)
  190.         {
  191.             return( shift(@{$_[0]}), shift(@{$_[0]}), shift(@{$_[0]}),
  192.                     shift(@{$_[0]}), shift(@{$_[0]}), shift(@{$_[0]}) );
  193.         }
  194.         else
  195.         {
  196.             croak("not enough input parameters for a date and time");
  197.         }
  198.     }
  199. }
  200.  
  201. package Date::Calc;
  202.  
  203. use strict;
  204.  
  205. use Carp::Clan qw(^Date::);
  206.  
  207. use overload
  208.       '0+' => 'number',
  209.       '""' => 'string',
  210.     'bool' => 'is_valid',
  211.      'neg' => '_unary_minus_',
  212.      'abs' => 'number',
  213.      '<=>' => '_compare_date_',
  214.      'cmp' => '_compare_date_time_',
  215.       '==' => '_equal_date_',
  216.       '!=' => '_not_equal_date_',
  217.       'eq' => '_equal_date_time_',
  218.       'ne' => '_not_equal_date_time_',
  219.        '+' => '_plus_',
  220.        '-' => '_minus_',
  221.       '+=' => '_plus_equal_',
  222.       '-=' => '_minus_equal_',
  223.       '++' => '_increment_',
  224.       '--' => '_decrement_',
  225.        'x' => '_times_',
  226.       'x=' => '_times_equal_',
  227.        '=' => 'clone',
  228. 'nomethod' => 'OVERLOAD', # equivalent of AUTOLOAD ;-)
  229. 'fallback' =>  undef;
  230.  
  231. # Report unimplemented overloaded operators:
  232.  
  233. sub OVERLOAD
  234. {
  235.     croak("operator '$_[3]' is unimplemented");
  236. }
  237.  
  238. # Prevent nearly infinite loops:
  239.  
  240. sub _times_
  241. {
  242.     $_[3] = 'x';
  243.     goto &OVERLOAD;
  244. }
  245.  
  246. sub _times_equal_
  247. {
  248.     $_[3] = 'x=';
  249.     goto &OVERLOAD;
  250. }
  251.  
  252. my $ACCURATE_MODE = 1;
  253. my $NUMBER_FORMAT = 0;
  254. my $DELTA_FORMAT = 0;
  255. my $DATE_FORMAT = 0;
  256.  
  257. sub accurate_mode
  258. {
  259.     my($flag) = $ACCURATE_MODE;
  260.  
  261.     if (@_ > 1)
  262.     {
  263.         $ACCURATE_MODE = $_[1] || 0;
  264.     }
  265.     return $flag;
  266. }
  267.  
  268. sub number_format
  269. {
  270.     my($flag) = $NUMBER_FORMAT;
  271.  
  272.     if (@_ > 1)
  273.     {
  274.         $NUMBER_FORMAT = $_[1] || 0;
  275.     }
  276.     return $flag;
  277. }
  278.  
  279. sub delta_format
  280. {
  281.     my($self) = shift;
  282.     my($flag);
  283.  
  284.     if (ref $self) # object method
  285.     {
  286.         $flag = defined($self->[0][1]) ? $self->[0][1] : undef;
  287.         if (@_ > 0)
  288.         {
  289.             $self->[0][1] = defined($_[0]) ? $_[0] : undef;
  290.         }
  291.     }
  292.     else           # class method
  293.     {
  294.         $flag = $DELTA_FORMAT;
  295.         if (@_ > 0)
  296.         {
  297.             $DELTA_FORMAT = $_[0] || 0;
  298.         }
  299.     }
  300.     return $flag;
  301. }
  302.  
  303. sub date_format
  304. {
  305.     my($self) = shift;
  306.     my($flag);
  307.  
  308.     if (ref $self) # object method
  309.     {
  310.         $flag = defined($self->[0][2]) ? $self->[0][2] : undef;
  311.         if (@_ > 0)
  312.         {
  313.             $self->[0][2] = defined($_[0]) ? $_[0] : undef;
  314.         }
  315.     }
  316.     else           # class method
  317.     {
  318.         $flag = $DATE_FORMAT;
  319.         if (@_ > 0)
  320.         {
  321.             $DATE_FORMAT = $_[0] || 0;
  322.         }
  323.     }
  324.     return $flag;
  325. }
  326.  
  327. sub language
  328. {
  329.     my($self) = shift;
  330.     my($lang,$temp);
  331.  
  332.     eval
  333.     {
  334.         if (ref $self) # object method
  335.         {
  336.             $lang = defined($self->[0][3]) ? Language_to_Text($self->[0][3]) : undef;
  337.             if (@_ > 0)
  338.             {
  339.                 if (defined $_[0])
  340.                 {
  341.                     $temp = $_[0];
  342.                     if ($temp !~ /^\d+$/)
  343.                         { $temp = Decode_Language($temp); }
  344.                     if ($temp > 0 and $temp <= Languages())
  345.                         { $self->[0][3] = $temp; }
  346.                     else
  347.                         { die "no such language '$_[0]'"; }
  348.                 }
  349.                 else { $self->[0][3] = undef; }
  350.             }
  351.         }
  352.         else           # class method
  353.         {
  354.             $lang = Language_to_Text(Language());
  355.             if (@_ > 0)
  356.             {
  357.                 $temp = $_[0];
  358.                 if ($temp !~ /^\d+$/)
  359.                     { $temp = Decode_Language($temp); }
  360.                 if ($temp > 0 and $temp <= Languages())
  361.                     { Language($temp); }
  362.                 else
  363.                     { die "no such language '$_[0]'"; }
  364.             }
  365.         }
  366.     };
  367.     if ($@)
  368.     {
  369.         $@ =~ s!^.*[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\(\):\s*!!;
  370.         $@ =~ s!\s+at\s+\S.*\s*$!!;
  371.         croak($@);
  372.     }
  373.     return $lang;
  374. }
  375.  
  376. sub is_delta
  377. {
  378.     my($self) = @_;
  379.     my($bool) = undef;
  380.  
  381.     eval
  382.     {
  383.         if (defined($self->[0]) and
  384.             ref($self->[0]) eq 'ARRAY' and
  385.             defined($self->[0][0]))
  386.         { $bool = ($self->[0][0] ? 1 : 0); }
  387.     };
  388.     if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  389.     return $bool;
  390. }
  391.  
  392. sub is_date
  393. {
  394.     my($self) = @_;
  395.     my($bool) = undef;
  396.  
  397.     eval
  398.     {
  399.         if (defined($self->[0]) and
  400.             ref($self->[0]) eq 'ARRAY' and
  401.             defined($self->[0][0]))
  402.         { $bool = ($self->[0][0] ? 0 : 1); }
  403.     };
  404.     if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  405.     return $bool;
  406. }
  407.  
  408. sub is_short
  409. {
  410.     my($self) = @_;
  411.     my($bool) = undef;
  412.  
  413.     eval
  414.     {
  415.         if    (@{$self} == 4) { $bool = 1; }
  416.         elsif (@{$self} == 7) { $bool = 0; }
  417.     };
  418.     if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  419.     return $bool;
  420. }
  421.  
  422. sub is_long
  423. {
  424.     my($self) = @_;
  425.     my($bool) = undef;
  426.  
  427.     eval
  428.     {
  429.         if    (@{$self} == 7) { $bool = 1; }
  430.         elsif (@{$self} == 4) { $bool = 0; }
  431.     };
  432.     if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  433.     return $bool;
  434. }
  435.  
  436. sub is_valid
  437. {
  438.     my($self) = @_;
  439.     my($bool);
  440.  
  441.     $bool = eval
  442.     {
  443.         if (defined($self->[0]) and
  444.             ref($self->[0]) eq 'ARRAY' and
  445.             @{$self->[0]} > 0 and
  446.             defined($self->[0][0]) and
  447.             not ref($self->[0][0]) and
  448.             ($self->[0][0] == 0 or $self->[0][0] == 1) and
  449.             (@{$self} == 4 or @{$self} == 7))
  450.         {
  451.             if ($self->[0][0]) # is_delta
  452.             {
  453.                 return 0 unless
  454.                 (
  455.                     defined($self->[1]) and not ref($self->[1]) and
  456.                     defined($self->[2]) and not ref($self->[2]) and
  457.                     defined($self->[3]) and not ref($self->[3])
  458.                 );
  459.                 if (@{$self} > 4) # is_long
  460.                 {
  461.                     return 0 unless
  462.                     (
  463.                         defined($self->[4]) and not ref($self->[4]) and
  464.                         defined($self->[5]) and not ref($self->[5]) and
  465.                         defined($self->[6]) and not ref($self->[6])
  466.                     );
  467.                 }
  468.                 return 1;
  469.             }
  470.             else # is_date
  471.             {
  472.                 return 0 unless
  473.                 (
  474.                     defined($self->[1]) and not ref($self->[1]) and
  475.                     defined($self->[2]) and not ref($self->[2]) and
  476.                     defined($self->[3]) and not ref($self->[3]) and
  477.                     check_date(@{$self}[1..3])
  478.                 );
  479.                 if (@{$self} > 4) # is_long
  480.                 {
  481.                     return 0 unless
  482.                     (
  483.                         defined($self->[4]) and not ref($self->[4]) and
  484.                         defined($self->[5]) and not ref($self->[5]) and
  485.                         defined($self->[6]) and not ref($self->[6]) and
  486.                         check_time(@{$self}[4..6])
  487.                     );
  488.                 }
  489.                 return 1;
  490.             }
  491.         }
  492.         return undef;
  493.     };
  494.     if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  495.     return $bool;
  496. }
  497.  
  498. sub normalize
  499. {
  500.     my($self) = shift;
  501.     my($quot);
  502.  
  503.     if ($self->is_valid())
  504.     {
  505.         if ($self->is_delta())
  506.         {
  507.             if ($self->is_long())
  508.             {
  509.                 splice( @{$self}, 3, 4, Normalize_DHMS(@{$self}[3..6]) );
  510.             }
  511.             unless ($ACCURATE_MODE) # YMD_MODE
  512.             {
  513.                 if ($self->[2] and ($quot = int($self->[2] / 12)))
  514.                 {
  515.                     $self->[1] += $quot;
  516.                     $self->[2] -= $quot * 12;
  517.                 }
  518.                 if
  519.                 (
  520.                     $self->[2] < 0 and
  521.                   ( $self->[3] > 0 or
  522.                     $self->[4] > 0 or
  523.                     $self->[5] > 0 or
  524.                     $self->[6] > 0 )
  525.                 )
  526.                 {
  527.                     $self->[1]--;
  528.                     $self->[2] += 12;
  529.                 }
  530.                 elsif
  531.                 (
  532.                     $self->[2] > 0 and
  533.                   ( $self->[3] < 0 or
  534.                     $self->[4] < 0 or
  535.                     $self->[5] < 0 or
  536.                     $self->[6] < 0 )
  537.                 )
  538.                 {
  539.                     $self->[1]++;
  540.                     $self->[2] -= 12;
  541.                 }
  542.             }
  543.         }
  544.         else
  545.         {
  546.             carp("normalizing a date is a no-op") if ($^W);
  547.         }
  548.     }
  549.     return $self;
  550. }
  551.  
  552. sub new
  553. {
  554.     my($class,$list,$type,$self);
  555.  
  556.     if (@_)
  557.     {
  558.         $class = shift;
  559.         if (@_ == 1 and ref($_[0]) eq 'ARRAY') { $list = $_[0]; } else { $list = \@_; }
  560.     }
  561.     croak("wrong number of arguments")
  562.         unless (defined($list) and
  563.         (@$list == 0 or @$list == 1 or @$list == 3 or @$list == 4 or @$list == 6 or @$list == 7));
  564.     if (@$list == 1 or @$list == 4 or @$list == 7)
  565.     {
  566.         $type = (shift(@$list) ? 1 : 0);
  567.         $self = [ [$type], @$list ];
  568.     }
  569.     elsif (@$list == 3 or @$list == 6)
  570.     {
  571.         $self = [ [0], @$list ];
  572.     }
  573.     else
  574.     {
  575.         $self = [ [] ];
  576.     }
  577.     bless($self, ref($class) || $class || 'Date::Calc');
  578.     return $self;
  579. }
  580.  
  581. sub clone
  582. {
  583.     my($self) = @_;
  584.     my($this);
  585.  
  586.     croak("invalid date/time") unless ($self->is_valid());
  587.     $this = $self->new();
  588.     @{$this} = @{$self};
  589.     $this->[0] = [];
  590.     @{$this->[0]} = @{$self->[0]};
  591.     return $this;
  592. }
  593.  
  594. sub copy
  595. {
  596.     my($self) = shift;
  597.     my($this);
  598.  
  599.     eval
  600.     {
  601.         if (@_ == 1 and ref($_[0])) { $this = $_[0]; } else { $this = \@_; }
  602.         @{$self} = @{$this};
  603.         $self->[0] = [];
  604.         if (defined $this->[0])
  605.         {
  606.             if (ref($this->[0]) eq 'ARRAY') { @{$self->[0]} = @{$this->[0]}; }
  607.             else                            { $self->[0][0] = $this->[0]; }
  608.         }
  609.     };
  610.     if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  611.     croak("invalid date/time") unless ($self->is_valid());
  612.     return $self;
  613. }
  614.  
  615. sub date
  616. {
  617.     my($self,$list);
  618.  
  619.     if (@_)
  620.     {
  621.         $self = shift;
  622.         if (@_ == 1 and ref($_[0]) eq 'ARRAY') { $list = $_[0]; } else { $list = \@_; }
  623.     }
  624.     croak("wrong number of arguments")
  625.         unless (defined($list) and
  626.         (@$list == 0 or @$list == 1 or @$list == 3 or @$list == 4 or @$list == 6 or @$list == 7));
  627.     eval
  628.     {
  629.         if (@$list == 1 or @$list == 4 or @$list == 7)
  630.         {
  631.             $self->[0][0] = (shift(@$list) ? 1 : 0);
  632.         }
  633.         if (@$list == 3 or @$list == 6)
  634.         {
  635.             splice( @{$self}, 1, scalar(@$list), @$list );
  636.         }
  637.     };
  638.     if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  639.     croak("invalid date/time") unless ($self->is_valid());
  640.     return (@{$self}[1..3]);
  641. }
  642.  
  643. sub time
  644. {
  645.     my($self,$list);
  646.  
  647.     if (@_)
  648.     {
  649.         $self = shift;
  650.         if (@_ == 1 and ref($_[0]) eq 'ARRAY') { $list = $_[0]; } else { $list = \@_; }
  651.     }
  652.     croak("wrong number of arguments")
  653.         unless (defined($list) and
  654.         (@$list == 0 or @$list == 1 or @$list == 3 or @$list == 4));
  655.     eval
  656.     {
  657.         if (@$list == 1 or @$list == 4)
  658.         {
  659.             $self->[0][0] = (shift(@$list) ? 1 : 0);
  660.         }
  661.         if (@$list == 3)
  662.         {
  663.             splice( @{$self}, 4, 3, @$list );
  664.         }
  665.     };
  666.     if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  667.     croak("invalid date/time") unless ($self->is_valid());
  668.     if (@{$self} == 7) { return (@{$self}[4..6]); }
  669.     else               { return (); }
  670. }
  671.  
  672. sub datetime
  673. {
  674.     my($self,$list);
  675.  
  676.     if (@_)
  677.     {
  678.         $self = shift;
  679.         if (@_ == 1 and ref($_[0]) eq 'ARRAY') { $list = $_[0]; } else { $list = \@_; }
  680.     }
  681.     croak("wrong number of arguments")
  682.         unless (defined($list) and
  683.         (@$list == 0 or @$list == 1 or @$list == 3 or @$list == 4 or @$list == 6 or @$list == 7));
  684.     eval
  685.     {
  686.         if (@$list == 1 or @$list == 4 or @$list == 7)
  687.         {
  688.             $self->[0][0] = (shift(@$list) ? 1 : 0);
  689.         }
  690.         if (@$list == 3)
  691.         {
  692.             splice( @{$self}, 1, 6, @$list, 0,0,0 );
  693.         }
  694.         elsif (@$list == 6)
  695.         {
  696.             splice( @{$self}, 1, 6, @$list );
  697.         }
  698.     };
  699.     if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  700.     croak("invalid date/time") unless ($self->is_valid());
  701.     if (@{$self} == 7) { return (@{$self}[1..6]); }
  702.     else               { return (@{$self}[1..3],0,0,0); }
  703. }
  704.  
  705. sub today
  706. {
  707.     my($self) = shift;
  708.     my($gmt)  = shift || 0;
  709.  
  710.     if (ref $self) # object method
  711.     {
  712.         $self->date( 0, Today($gmt) );
  713.         return $self;
  714.     }
  715.     else           # class method
  716.     {
  717.         $self ||= 'Date::Calc';
  718.         return $self->new( 0, Today($gmt) );
  719.     }
  720. }
  721.  
  722. sub now
  723. {
  724.     my($self) = shift;
  725.     my($gmt)  = shift || 0;
  726.  
  727.     if (ref $self) # object method
  728.     {
  729.         $self->time( 0, Now($gmt) );
  730.         return $self;
  731.     }
  732.     else           # class method
  733.     {
  734.         $self ||= 'Date::Calc';
  735.         return $self->new( 0, Today_and_Now($gmt) );
  736.     }
  737. }
  738.  
  739. sub today_and_now
  740. {
  741.     my($self) = shift;
  742.     my($gmt)  = shift || 0;
  743.  
  744.     if (ref $self) # object method
  745.     {
  746.         $self->date( 0, Today_and_Now($gmt) );
  747.         return $self;
  748.     }
  749.     else           # class method
  750.     {
  751.         $self ||= 'Date::Calc';
  752.         return $self->new( 0, Today_and_Now($gmt) );
  753.     }
  754. }
  755.  
  756. sub gmtime
  757. {
  758.     my($self) = shift;
  759.     my(@date);
  760.  
  761.     eval
  762.     {
  763.         @date = (Gmtime(@_))[0..5];
  764.     };
  765.     if ($@)
  766.     {
  767.         $@ =~ s!^.*[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\(\):\s*!!;
  768.         $@ =~ s!\s+at\s+\S.*\s*$!!;
  769.         croak($@);
  770.     }
  771.     if (ref $self) # object method
  772.     {
  773.         $self->date( 0, @date );
  774.         return $self;
  775.     }
  776.     else           # class method
  777.     {
  778.         $self ||= 'Date::Calc';
  779.         return $self->new( 0, @date );
  780.     }
  781. }
  782.  
  783. sub localtime
  784. {
  785.     my($self) = shift;
  786.     my(@date);
  787.  
  788.     eval
  789.     {
  790.         @date = (Localtime(@_))[0..5];
  791.     };
  792.     if ($@)
  793.     {
  794.         $@ =~ s!^.*[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\(\):\s*!!;
  795.         $@ =~ s!\s+at\s+\S.*\s*$!!;
  796.         croak($@);
  797.     }
  798.     if (ref $self) # object method
  799.     {
  800.         $self->date( 0, @date );
  801.         return $self;
  802.     }
  803.     else           # class method
  804.     {
  805.         $self ||= 'Date::Calc';
  806.         return $self->new( 0, @date );
  807.     }
  808. }
  809.  
  810. sub mktime
  811. {
  812.     my($self) = @_;
  813.     my($time);
  814.  
  815.     if (ref $self) # object method
  816.     {
  817.         croak("invalid date/time")            unless ($self->is_valid());
  818.         croak("can't mktime from a delta vector") if ($self->is_delta()); # add [1970,1,1,0,0,0] first!
  819.         eval
  820.         {
  821.             $time = Mktime( $self->datetime() );
  822.         };
  823.         if ($@)
  824.         {
  825.             $@ =~ s!^.*[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\(\):\s*!!;
  826.             $@ =~ s!\s+at\s+\S.*\s*$!!;
  827.             croak($@);
  828.         }
  829.         return $time;
  830.     }
  831.     else           # class method
  832.     {
  833.         return CORE::time();
  834.     }
  835. }
  836.  
  837. sub tzoffset
  838. {
  839.     my($self) = shift;
  840.     my(@diff);
  841.  
  842.     eval
  843.     {
  844.         @diff = (Timezone(@_))[0..5];
  845.     };
  846.     if ($@)
  847.     {
  848.         $@ =~ s!^.*[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\(\):\s*!!;
  849.         $@ =~ s!\s+at\s+\S.*\s*$!!;
  850.         croak($@);
  851.     }
  852.     if (ref $self) # object method
  853.     {
  854.         $self->date( 1, @diff );
  855.         return $self;
  856.     }
  857.     else           # class method
  858.     {
  859.         $self ||= 'Date::Calc';
  860.         return $self->new( 1, @diff );
  861.     }
  862. }
  863.  
  864. sub date2time
  865. {
  866.     my($self) = @_;
  867.     my($time);
  868.  
  869.     if (ref $self) # object method
  870.     {
  871.         croak("invalid date/time")               unless ($self->is_valid());
  872.         croak("can't make time from a delta vector") if ($self->is_delta()); # add [1970,1,1,0,0,0] first!
  873.         eval
  874.         {
  875.             $time = Date_to_Time( $self->datetime() );
  876.         };
  877.         if ($@)
  878.         {
  879.             $@ =~ s!^.*[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\(\):\s*!!;
  880.             $@ =~ s!\s+at\s+\S.*\s*$!!;
  881.             croak($@);
  882.         }
  883.         return $time;
  884.     }
  885.     else           # class method
  886.     {
  887.         return CORE::time();
  888.     }
  889. }
  890.  
  891. sub time2date
  892. {
  893.     my($self) = shift;
  894.     my(@date);
  895.  
  896.     eval
  897.     {
  898.         @date = Time_to_Date(@_);
  899.     };
  900.     if ($@)
  901.     {
  902.         $@ =~ s!^.*[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\(\):\s*!!;
  903.         $@ =~ s!\s+at\s+\S.*\s*$!!;
  904.         croak($@);
  905.     }
  906.     if (ref $self) # object method
  907.     {
  908.         $self->date( 0, @date );
  909.         return $self;
  910.     }
  911.     else           # class method
  912.     {
  913.         $self ||= 'Date::Calc';
  914.         return $self->new( 0, @date );
  915.     }
  916. }
  917.  
  918. sub year
  919. {
  920.     my($self) = shift;
  921.  
  922.     if (@_ > 0)
  923.     {
  924.         eval { $self->[1] = $_[0] || 0; };
  925.         if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  926.     }
  927.     croak("invalid date/time") unless ($self->is_valid());
  928.     return $self->[1];
  929. }
  930.  
  931. sub month
  932. {
  933.     my($self) = shift;
  934.  
  935.     if (@_ > 0)
  936.     {
  937.         eval { $self->[2] = $_[0] || 0; };
  938.         if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  939.     }
  940.     croak("invalid date/time") unless ($self->is_valid());
  941.     return $self->[2];
  942. }
  943.  
  944. sub day
  945. {
  946.     my($self) = shift;
  947.  
  948.     if (@_ > 0)
  949.     {
  950.         eval { $self->[3] = $_[0] || 0; };
  951.         if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  952.     }
  953.     croak("invalid date/time") unless ($self->is_valid());
  954.     return $self->[3];
  955. }
  956.  
  957. sub hours
  958. {
  959.     my($self) = shift;
  960.  
  961.     if (@_ > 0)
  962.     {
  963.         eval
  964.         {
  965.             if (@{$self} == 4)
  966.             {
  967.                 $self->[4] = 0;
  968.                 $self->[5] = 0;
  969.                 $self->[6] = 0;
  970.             }
  971.             if (@{$self} == 7)
  972.             {
  973.                 $self->[4] = $_[0] || 0;
  974.             }
  975.         };
  976.         if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  977.     }
  978.     croak("invalid date/time") unless ($self->is_valid());
  979.     if (@{$self} == 7) { return $self->[4]; }
  980.     else               { return undef; }
  981. }
  982.  
  983. sub minutes
  984. {
  985.     my($self) = shift;
  986.  
  987.     if (@_ > 0)
  988.     {
  989.         eval
  990.         {
  991.             if (@{$self} == 4)
  992.             {
  993.                 $self->[4] = 0;
  994.                 $self->[5] = 0;
  995.                 $self->[6] = 0;
  996.             }
  997.             if (@{$self} == 7)
  998.             {
  999.                 $self->[5] = $_[0] || 0;
  1000.             }
  1001.         };
  1002.         if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  1003.     }
  1004.     croak("invalid date/time") unless ($self->is_valid());
  1005.     if (@{$self} == 7) { return $self->[5]; }
  1006.     else               { return undef; }
  1007. }
  1008.  
  1009. sub seconds
  1010. {
  1011.     my($self) = shift;
  1012.  
  1013.     if (@_ > 0)
  1014.     {
  1015.         eval
  1016.         {
  1017.             if (@{$self} == 4)
  1018.             {
  1019.                 $self->[4] = 0;
  1020.                 $self->[5] = 0;
  1021.                 $self->[6] = 0;
  1022.             }
  1023.             if (@{$self} == 7)
  1024.             {
  1025.                 $self->[6] = $_[0] || 0;
  1026.             }
  1027.         };
  1028.         if ($@) { $@ =~ s!\s+at\s+\S.*\s*$!!; croak($@); }
  1029.     }
  1030.     croak("invalid date/time") unless ($self->is_valid());
  1031.     if (@{$self} == 7) { return $self->[6]; }
  1032.     else               { return undef; }
  1033. }
  1034.  
  1035. ###############################
  1036. ##                           ##
  1037. ##    Selector constants     ##
  1038. ##    for formatting         ##
  1039. ##    callback functions:    ##
  1040. ##                           ##
  1041. ###############################
  1042. ##                           ##
  1043. ##    IS_SHORT   =  0x00;    ##
  1044. ##    IS_LONG    =  0x01;    ##
  1045. ##    IS_DATE    =  0x00;    ##
  1046. ##    IS_DELTA   =  0x02;    ##
  1047. ##    TO_NUMBER  =  0x00;    ##
  1048. ##    TO_STRING  =  0x04;    ##
  1049. ##                           ##
  1050. ###############################
  1051.  
  1052. sub number
  1053. {
  1054.     my($self,$format) = @_;
  1055.     my($number,$sign,@temp);
  1056.  
  1057.     if ($self->is_valid())
  1058.     {
  1059.         eval
  1060.         {
  1061.             $format = $NUMBER_FORMAT unless (defined $format); # because of overloading!
  1062.             if ($self->[0][0]) # is_delta
  1063.             {
  1064. #               carp("returning a fictitious number of days for delta vector")
  1065. #                   if ((($self->[1] != 0) or ($self->[2] != 0)) and $^W);
  1066.                 if (@{$self} == 4) # is_short
  1067.                 {
  1068.                     if (ref($format) eq 'CODE')
  1069.                     {
  1070.                         $number = &{$format}( $self, 0x02 ); # = TO_NUMBER | IS_DELTA | IS_SHORT
  1071.                     }
  1072.                     else
  1073.                     {
  1074.                         $number = ($self->[1]*12+$self->[2])*31+$self->[3];
  1075.                     }
  1076.                 }
  1077.                 else # is_long
  1078.                 {
  1079.                     if (ref($format) eq 'CODE')
  1080.                     {
  1081.                         $number = &{$format}( $self, 0x03 ); # = TO_NUMBER | IS_DELTA | IS_LONG
  1082.                     }
  1083.                     elsif ($format == 2)
  1084.                     {
  1085.                         $number = ($self->[1]*12+$self->[2])*31+$self->[3] +
  1086.                             ((($self->[4]*60+$self->[5])*60+$self->[6])/86400);
  1087.                     }
  1088.                     else
  1089.                     {
  1090.                         local($_);
  1091.                         $sign = 0;
  1092.                         @temp = @{$self}[3..6];
  1093.                         $temp[0] += ($self->[1] * 12 + $self->[2]) * 31;
  1094.                         @temp = map( $_ < 0 ? $sign = -$_ : $_, Normalize_DHMS(@temp) );
  1095.                         $number = sprintf( "%s%d.%02d%02d%02d", $sign ? '-' : '', @temp );
  1096.                     }
  1097.                 }
  1098.             }
  1099.             else # is_date
  1100.             {
  1101.                 if (@{$self} == 4) # is_short
  1102.                 {
  1103.                     if (ref($format) eq 'CODE')
  1104.                     {
  1105.                         $number = &{$format}( $self, 0x00 ); # = TO_NUMBER | IS_DATE | IS_SHORT
  1106.                     }
  1107.                     elsif ($format == 2 or $format == 1)
  1108.                     {
  1109.                         $number = Date_to_Days( @{$self}[1..3] );
  1110.                     }
  1111.                     else
  1112.                     {
  1113.                         $number = sprintf( "%04d%02d%02d",
  1114.                             @{$self}[1..3] );
  1115.                     }
  1116.                 }
  1117.                 else # is_long
  1118.                 {
  1119.                     if (ref($format) eq 'CODE')
  1120.                     {
  1121.                         $number = &{$format}( $self, 0x01 ); # = TO_NUMBER | IS_DATE | IS_LONG
  1122.                     }
  1123.                     elsif ($format == 2)
  1124.                     {
  1125.                         $number = Date_to_Days( @{$self}[1..3] ) +
  1126.                             ((($self->[4]*60+$self->[5])*60+$self->[6])/86400);
  1127.                     }
  1128.                     elsif ($format == 1)
  1129.                     {
  1130.                         $number = Date_to_Days( @{$self}[1..3] ) .
  1131.                             sprintf( ".%02d%02d%02d", @{$self}[4..6] );
  1132.                     }
  1133.                     else
  1134.                     {
  1135.                         $number = sprintf( "%04d%02d%02d.%02d%02d%02d",
  1136.                             @{$self}[1..6] );
  1137.                     }
  1138.                 }
  1139.             }
  1140.         };
  1141.         if ($@)
  1142.         {
  1143.             $@ =~ s!^.*[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\(\):\s*!!;
  1144.             $@ =~ s!\s+at\s+\S.*\s*$!!;
  1145.             croak($@);
  1146.         }
  1147.         return $number;
  1148.     }
  1149.     return undef;
  1150. }
  1151.  
  1152. sub string
  1153. {
  1154.     my($self,$format,$language) = @_;
  1155.     my($restore,$string);
  1156.  
  1157.     if ($self->is_valid())
  1158.     {
  1159.         eval
  1160.         {
  1161.             if (defined($language) and $language ne '') # because of overloading!
  1162.             {
  1163.                 if ($language =~ /^\d+$/)  { $restore = Language($language); }
  1164.                 else                       { $restore = Language(Decode_Language($language)); }
  1165.             }
  1166.             else
  1167.             {
  1168.                 if (defined $self->[0][3]) { $restore = Language($self->[0][3]); }
  1169.                 else                       { $restore = undef; }
  1170.             }
  1171.         };
  1172.         if ($@)
  1173.         {
  1174.             $@ =~ s!^.*[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\(\):\s*!!;
  1175.             $@ =~ s!\s+at\s+\S.*\s*$!!;
  1176.             croak($@);
  1177.         }
  1178.         eval
  1179.         {
  1180.             if ($self->[0][0]) # is_delta
  1181.             {
  1182.                 $format = defined($self->[0][1]) ? $self->[0][1] : $DELTA_FORMAT
  1183.                     unless (defined $format); # because of overloading!
  1184.                 if (@{$self} == 4) # is_short
  1185.                 {
  1186.                     if (ref($format) eq 'CODE')
  1187.                     {
  1188.                         $string = &{$format}( $self, 0x06 ); # = TO_STRING | IS_DELTA | IS_SHORT
  1189.                     }
  1190.                     elsif ($format == 3)
  1191.                     {
  1192.                         $string = sprintf( "%+d Y %+d M %+d D",
  1193.                             @{$self}[1..3] );
  1194.                     }
  1195.                     elsif ($format == 2)
  1196.                     {
  1197.                         $string = sprintf( "%+dY %+dM %+dD",
  1198.                             @{$self}[1..3] );
  1199.                     }
  1200.                     elsif ($format == 1)
  1201.                     {
  1202.                         $string = sprintf( "%+d %+d %+d",
  1203.                             @{$self}[1..3] );
  1204.                     }
  1205.                     else
  1206.                     {
  1207.                         $string = sprintf( "%+d%+d%+d",
  1208.                             @{$self}[1..3] );
  1209.                     }
  1210.                 }
  1211.                 else # is_long
  1212.                 {
  1213.                     if (ref($format) eq 'CODE')
  1214.                     {
  1215.                         $string = &{$format}( $self, 0x07 ); # = TO_STRING | IS_DELTA | IS_LONG
  1216.                     }
  1217.                     elsif ($format == 3)
  1218.                     {
  1219.                         $string = sprintf( "%+d Y %+d M %+d D %+d h %+d m %+d s",
  1220.                             @{$self}[1..6] );
  1221.                     }
  1222.                     elsif ($format == 2)
  1223.                     {
  1224.                         $string = sprintf( "%+dY %+dM %+dD %+dh %+dm %+ds",
  1225.                             @{$self}[1..6] );
  1226.                     }
  1227.                     elsif ($format == 1)
  1228.                     {
  1229.                         $string = sprintf( "%+d %+d %+d %+d %+d %+d",
  1230.                             @{$self}[1..6] );
  1231.                     }
  1232.                     else
  1233.                     {
  1234.                         $string = sprintf( "%+d%+d%+d%+d%+d%+d",
  1235.                             @{$self}[1..6] );
  1236.                     }
  1237.                 }
  1238.             }
  1239.             else # is_date
  1240.             {
  1241.                 $format = defined($self->[0][2]) ? $self->[0][2] : $DATE_FORMAT
  1242.                     unless (defined $format); # because of overloading!
  1243.                 if (@{$self} == 4) # is_short
  1244.                 {
  1245.                     if (ref($format) eq 'CODE')
  1246.                     {
  1247.                         $string = &{$format}( $self, 0x04 ); # = TO_STRING | IS_DATE | IS_SHORT
  1248.                     }
  1249.                     elsif ($format == 3)
  1250.                     {
  1251.                         $string = Date_to_Text_Long( @{$self}[1..3] );
  1252.                     }
  1253.                     elsif ($format == 2)
  1254.                     {
  1255.                         $string = Date_to_Text( @{$self}[1..3] );
  1256.                     }
  1257.                     elsif ($format == 1)
  1258.                     {
  1259.                         $string = sprintf( "%02d-%.3s-%04d",
  1260.                             $self->[3],
  1261.                             Month_to_Text($self->[2]),
  1262.                             $self->[1] );
  1263.                     }
  1264.                     else
  1265.                     {
  1266.                         $string = sprintf( "%04d%02d%02d",
  1267.                             @{$self}[1..3] );
  1268.                     }
  1269.                 }
  1270.                 else # is_long
  1271.                 {
  1272.                     if (ref($format) eq 'CODE')
  1273.                     {
  1274.                         $string = &{$format}( $self, 0x05 ); # = TO_STRING | IS_DATE | IS_LONG
  1275.                     }
  1276.                     elsif ($format == 3)
  1277.                     {
  1278.                         $string = Date_to_Text_Long( @{$self}[1..3] ) .
  1279.                             sprintf( " %02d:%02d:%02d", @{$self}[4..6] );
  1280.                     }
  1281.                     elsif ($format == 2)
  1282.                     {
  1283.                         $string = Date_to_Text( @{$self}[1..3] ) .
  1284.                             sprintf( " %02d:%02d:%02d", @{$self}[4..6] );
  1285.                     }
  1286.                     elsif ($format == 1)
  1287.                     {
  1288.                         $string = sprintf( "%02d-%.3s-%04d %02d:%02d:%02d",
  1289.                             $self->[3],
  1290.                             Month_to_Text($self->[2]),
  1291.                             $self->[1],
  1292.                             @{$self}[4..6] );
  1293.                     }
  1294.                     else
  1295.                     {
  1296.                         $string = sprintf( "%04d%02d%02d%02d%02d%02d",
  1297.                             @{$self}[1..6] );
  1298.                     }
  1299.                 }
  1300.             }
  1301.         };
  1302.         Language($restore) if (defined $restore);
  1303.         if ($@)
  1304.         {
  1305.             $@ =~ s!^.*[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\(\):\s*!!;
  1306.             $@ =~ s!\s+at\s+\S.*\s*$!!;
  1307.             croak($@);
  1308.         }
  1309.         return $string;
  1310.     }
  1311.     return undef;
  1312. }
  1313.  
  1314. sub _process_
  1315. {
  1316.     my($self,$this,$flag,$code) = @_;
  1317.     my($result,$val1,$val2,$len1,$len2,$last,$item);
  1318.  
  1319.     croak("invalid date/time") unless ($self->is_valid());
  1320.     if ($code == 0)
  1321.     {
  1322.         croak("can't apply unary minus to a date")
  1323.             unless ($self->is_delta());
  1324.         $result = $self->new();
  1325.         $result->[0][0] = $self->[0][0];
  1326.         for ( $item = 1; $item < @{$self}; $item++ )
  1327.         {
  1328.             $result->[$item] = -$self->[$item];
  1329.         }
  1330.         return $result;
  1331.     }
  1332.     if (defined $this and ref($this) =~ /[^:]::[^:]/)
  1333.     {
  1334.         croak("invalid date/time") unless ($this->is_valid());
  1335.     }
  1336.     elsif (defined $this and ref($this) eq 'ARRAY')
  1337.     {
  1338.         if (@{$this} == 3 or @{$this} == 6)
  1339.         {
  1340.             if ($code == 6)
  1341.             {
  1342.                 $this = $self->new(0,@{$this});
  1343.             }
  1344.             elsif ($code == 5)
  1345.             {
  1346.                 $this = $self->new($self->is_date(),@{$this});
  1347.             }
  1348.             else
  1349.             {
  1350.                 $this = $self->new($self->is_delta(),@{$this});
  1351.             }
  1352.         }
  1353.         else
  1354.         {
  1355.             $this = $self->new(@{$this});
  1356.         }
  1357.         croak("invalid date/time") unless ($this->is_valid());
  1358.     }
  1359.     elsif (defined $this and not ref($this))
  1360.     {
  1361.         $this = $self->new(1,0,0,$this || 0);
  1362.         croak("invalid date/time") unless ($this->is_valid());
  1363.     }
  1364.     else { croak("illegal operand type"); }
  1365.     $val1 = $self->is_date();
  1366.     $val2 = $this->is_date();
  1367.     if ($code == 6 or $code == 5)
  1368.     {
  1369.         if ($code == 6)
  1370.         {
  1371.             croak("can't subtract a date from a delta vector")
  1372.                 if ((not $val1 and $val2 and not $flag) or
  1373.                     ($val1 and not $val2 and $flag));
  1374.         }
  1375.         else
  1376.         {
  1377.             croak("can't add two dates")
  1378.                 if ($val1 and $val2);
  1379.         }
  1380.         $len1 = $self->is_long();
  1381.         $len2 = $this->is_long();
  1382.         if ($len1 or $len2) { $last = 7; }
  1383.         else                { $last = 4; }
  1384.         if (defined $flag) { $result = $self->new((0) x $last); }
  1385.         else               { $result = $self; }
  1386.         if (not $val1 and not $val2)
  1387.         {
  1388.             $result->[0][0] = 1;
  1389.             for ( $item = 1; $item < $last; $item++ )
  1390.             {
  1391.                 if ($code == 6)
  1392.                 {
  1393.                     if ($flag)
  1394.                     {
  1395.                         $result->[$item] =
  1396.                             ($this->[$item] || 0) -
  1397.                             ($self->[$item] || 0);
  1398.                     }
  1399.                     else
  1400.                     {
  1401.                         $result->[$item] =
  1402.                             ($self->[$item] || 0) -
  1403.                             ($this->[$item] || 0);
  1404.                     }
  1405.                 }
  1406.                 else
  1407.                 {
  1408.                     $result->[$item] =
  1409.                         ($self->[$item] || 0) +
  1410.                         ($this->[$item] || 0);
  1411.                 }
  1412.             }
  1413.         }
  1414.         return ($result,$this,$val1,$val2,$len1,$len2);
  1415.     }
  1416.     elsif ($code <= 4 and $code >= 1)
  1417.     {
  1418.         croak("can't compare a date and a delta vector")
  1419.             if ($val1 xor $val2);
  1420.         if ($code >= 3)
  1421.         {
  1422.             if ($code == 4) { $last = 7; }
  1423.             else            { $last = 4; }
  1424.             $result = 1;
  1425.             ITEM:
  1426.             for ( $item = 1; $item < $last; $item++ )
  1427.             {
  1428.                 if (($self->[$item] || 0) !=
  1429.                     ($this->[$item] || 0))
  1430.                 { $result = 0; last ITEM; }
  1431.             }
  1432.             return $result;
  1433.         }
  1434.         else # ($code <= 2)
  1435.         {
  1436. #           croak("can't compare two delta vectors")
  1437. #               if (not $val1 and not $val2);
  1438.             if ($code == 2)
  1439.             {
  1440.                 $len1 = $self->number();
  1441.                 $len2 = $this->number();
  1442.             }
  1443.             else
  1444.             {
  1445.                 $len1 = int($self->number());
  1446.                 $len2 = int($this->number());
  1447.             }
  1448.             if ($flag) { return $len2 <=> $len1; }
  1449.             else       { return $len1 <=> $len2; }
  1450.         }
  1451.     }
  1452.     else { croak("unexpected internal error; please contact author"); }
  1453. }
  1454.  
  1455. sub _unary_minus_
  1456. {
  1457.     my($self,$this,$flag) = @_;
  1458.  
  1459.     return $self->_process_($this,$flag,0);
  1460. }
  1461.  
  1462. sub _compare_date_
  1463. {
  1464.     my($self,$this,$flag) = @_;
  1465.  
  1466.     return $self->_process_($this,$flag,1);
  1467. }
  1468.  
  1469. sub _compare_date_time_
  1470. {
  1471.     my($self,$this,$flag) = @_;
  1472.  
  1473.     return $self->_process_($this,$flag,2);
  1474. }
  1475.  
  1476. sub _equal_date_
  1477. {
  1478.     my($self,$this,$flag) = @_;
  1479.  
  1480.     return $self->_process_($this,$flag,3);
  1481. }
  1482.  
  1483. sub _not_equal_date_
  1484. {
  1485.     my($self,$this,$flag) = @_;
  1486.  
  1487.     return $self->_process_($this,$flag,3) ^ 1;
  1488. }
  1489.  
  1490. sub _equal_date_time_
  1491. {
  1492.     my($self,$this,$flag) = @_;
  1493.  
  1494.     return $self->_process_($this,$flag,4);
  1495. }
  1496.  
  1497. sub _not_equal_date_time_
  1498. {
  1499.     my($self,$this,$flag) = @_;
  1500.  
  1501.     return $self->_process_($this,$flag,4) ^ 1;
  1502. }
  1503.  
  1504. sub _date_time_
  1505. {
  1506.     my($self) = @_;
  1507.  
  1508.     if (@{$self} == 7) { return (@{$self}[1..6]); }
  1509.     else               { return (@{$self}[1..3],0,0,0); }
  1510. }
  1511.  
  1512. sub _add_
  1513. {
  1514.     my($result,$self,$this,$flag,$val1,$val2,$len1,$len2) = @_;
  1515.  
  1516.     if ($val1) # date + delta => date
  1517.     {
  1518.         if ($len1 or $len2)
  1519.         {
  1520.             splice( @{$result}, 1, 6,
  1521.                 Add_Delta_YMDHMS( $self->_date_time_(),
  1522.                                   $this->_date_time_() ) );
  1523.         }
  1524.         else # short
  1525.         {
  1526.             splice( @{$result}, 1, 3,
  1527.                 Add_Delta_YMD( @{$self}[1..3], @{$this}[1..3] ) );
  1528.         }
  1529.     }
  1530.     else # delta + date => date
  1531.     {
  1532.         if ($len1 or $len2)
  1533.         {
  1534.             splice( @{$result}, 1, 6,
  1535.                 Add_Delta_YMDHMS( $this->_date_time_(),
  1536.                                   $self->_date_time_() ) );
  1537.         }
  1538.         else # short
  1539.         {
  1540.             splice( @{$result}, 1, 3,
  1541.                 Add_Delta_YMD( @{$this}[1..3], @{$self}[1..3] ) );
  1542.         }
  1543.         carp("implicitly changed object type from delta vector to date")
  1544.             if (not defined $flag and $^W);
  1545.     }
  1546.     $result->[0][0] = 0;
  1547. }
  1548.  
  1549. sub _plus_
  1550. {
  1551.     my($self,$this,$flag) = @_;
  1552.     my($result,$val1,$val2,$len1,$len2);
  1553.  
  1554.     ($result,$this,$val1,$val2,$len1,$len2) = $self->_process_($this,$flag,5);
  1555.     if ($val1 or $val2)
  1556.     {
  1557.         $result->_add_($self,$this,$flag,$val1,$val2,$len1,$len2);
  1558.     }
  1559.     return $result;
  1560. }
  1561.  
  1562. sub _minus_
  1563. {
  1564.     my($self,$this,$flag) = @_;
  1565.     my($result,$val1,$val2,$len1,$len2,$temp,$item);
  1566.  
  1567.     ($result,$this,$val1,$val2,$len1,$len2) = $self->_process_($this,$flag,6);
  1568.     if ($val1 or $val2)
  1569.     {
  1570.         if ($val1 and $val2) # date - date => delta
  1571.         {
  1572.             if ($len1 or $len2)
  1573.             {
  1574.                 if ($ACCURATE_MODE)
  1575.                 {
  1576.                     if ($flag)
  1577.                     {
  1578.                         splice( @{$result}, 1, 6, 0, 0,
  1579.                             Delta_DHMS( $self->_date_time_(),
  1580.                                         $this->_date_time_() ) );
  1581.                     }
  1582.                     else
  1583.                     {
  1584.                         splice( @{$result}, 1, 6, 0, 0,
  1585.                             Delta_DHMS( $this->_date_time_(),
  1586.                                         $self->_date_time_() ) );
  1587.                     }
  1588.                 }
  1589.                 else # YMD_MODE
  1590.                 {
  1591.                     if ($flag)
  1592.                     {
  1593.                         splice( @{$result}, 1, 6,
  1594.                             Delta_YMDHMS( $self->_date_time_(),
  1595.                                           $this->_date_time_() ) );
  1596.                     }
  1597.                     else
  1598.                     {
  1599.                         splice( @{$result}, 1, 6,
  1600.                             Delta_YMDHMS( $this->_date_time_(),
  1601.                                           $self->_date_time_() ) );
  1602.                     }
  1603.                 }
  1604.             }
  1605.             else # short
  1606.             {
  1607.                 if ($ACCURATE_MODE)
  1608.                 {
  1609.                     if ($flag)
  1610.                     {
  1611.                         splice( @{$result}, 1, 3, 0, 0,
  1612.                             Delta_Days( @{$self}[1..3], @{$this}[1..3] ) );
  1613.                     }
  1614.                     else
  1615.                     {
  1616.                         splice( @{$result}, 1, 3, 0, 0,
  1617.                             Delta_Days( @{$this}[1..3], @{$self}[1..3] ) );
  1618.                     }
  1619.                 }
  1620.                 else # YMD_MODE
  1621.                 {
  1622.                     if ($flag)
  1623.                     {
  1624.                         splice( @{$result}, 1, 3,
  1625.                             Delta_YMD( @{$self}[1..3], @{$this}[1..3] ) );
  1626.                     }
  1627.                     else
  1628.                     {
  1629.                         splice( @{$result}, 1, 3,
  1630.                             Delta_YMD( @{$this}[1..3], @{$self}[1..3] ) );
  1631.                     }
  1632.                 }
  1633.             }
  1634.             carp("implicitly changed object type from date to delta vector")
  1635.                 if (not defined $flag and $^W);
  1636.             $result->[0][0] = 1;
  1637.         }
  1638.         else # date - delta => date
  1639.         {
  1640.             if ($val1)
  1641.             {
  1642.                 $temp = $this->new();
  1643.                 $temp->[0][0] = $this->[0][0];
  1644.                 for ( $item = 1; $item < @{$this}; $item++ )
  1645.                 {
  1646.                     $temp->[$item] = -$this->[$item];
  1647.                 }
  1648.                 $result->_add_($self,$temp,$flag,$val1,$val2,$len1,$len2);
  1649.             }
  1650.             else
  1651.             {
  1652.                 $temp = $self->new();
  1653.                 $temp->[0][0] = $self->[0][0];
  1654.                 for ( $item = 1; $item < @{$self}; $item++ )
  1655.                 {
  1656.                     $temp->[$item] = -$self->[$item];
  1657.                 }
  1658.                 $result->_add_($temp,$this,$flag,$val1,$val2,$len1,$len2);
  1659.             }
  1660.         }
  1661.     }
  1662.     return $result;
  1663. }
  1664.  
  1665. sub _plus_equal_
  1666. {
  1667.     my($self,$this) = @_;
  1668.  
  1669.     return $self->_plus_($this,undef);
  1670. }
  1671.  
  1672. sub _minus_equal_
  1673. {
  1674.     my($self,$this) = @_;
  1675.  
  1676.     return $self->_minus_($this,undef);
  1677. }
  1678.  
  1679. sub _increment_
  1680. {
  1681.     my($self) = @_;
  1682.  
  1683.     return $self->_plus_(1,undef);
  1684. }
  1685.  
  1686. sub _decrement_
  1687. {
  1688.     my($self) = @_;
  1689.  
  1690.     return $self->_minus_(1,undef);
  1691. }
  1692.  
  1693. 1;
  1694.  
  1695. __END__
  1696.  
  1697.