projects / OpenSPARC-T2-DV / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 design and verification files.
[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Date / Calc / Object.pm
CommitLineData
86530b38
AT		 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
22package Date::Calc::Object;
23
24use strict;
25use vars qw(@ISA @AUXILIARY @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
26
27use Carp::Clan qw(^Date::);
28
29BEGIN # 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
44sub 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
83sub 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
122sub 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
161sub 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
201package Date::Calc;
202
203use strict;
204
205use Carp::Clan qw(^Date::);
206
207use 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
233sub OVERLOAD
234{
235 croak("operator '$_[3]' is unimplemented");
236}
237
238# Prevent nearly infinite loops:
239
240sub _times_
241{
242 $_[3] = 'x';
243 goto &OVERLOAD;
244}
245
246sub _times_equal_
247{
248 $_[3] = 'x=';
249 goto &OVERLOAD;
250}
251
252my $ACCURATE_MODE = 1;
253my $NUMBER_FORMAT = 0;
254my $DELTA_FORMAT = 0;
255my $DATE_FORMAT = 0;
256
257sub accurate_mode
258{
259 my($flag) = $ACCURATE_MODE;
260
261 if (@_ > 1)
262 {
263 $ACCURATE_MODE = $_[1] || 0;
264 }
265 return $flag;
266}
267
268sub number_format
269{
270 my($flag) = $NUMBER_FORMAT;
271
272 if (@_ > 1)
273 {
274 $NUMBER_FORMAT = $_[1] || 0;
275 }
276 return $flag;
277}
278
279sub 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
303sub 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
327sub 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
376sub 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
392sub 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
408sub 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
422sub 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
436sub 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
498sub 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
552sub 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
581sub 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
594sub 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
615sub 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
643sub 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
672sub 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
705sub 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
722sub 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
739sub 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
756sub 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
783sub 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
810sub 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
837sub 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
864sub 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
891sub 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
918sub 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
931sub 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
944sub 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
957sub 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
983sub 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
1009sub 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
1052sub 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
1152sub 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
1314sub _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
1455sub _unary_minus_
1456{
1457 my($self,$this,$flag) = @_;
1458
1459 return $self->_process_($this,$flag,0);
1460}
1461
1462sub _compare_date_
1463{
1464 my($self,$this,$flag) = @_;
1465
1466 return $self->_process_($this,$flag,1);
1467}
1468
1469sub _compare_date_time_
1470{
1471 my($self,$this,$flag) = @_;
1472
1473 return $self->_process_($this,$flag,2);
1474}
1475
1476sub _equal_date_
1477{
1478 my($self,$this,$flag) = @_;
1479
1480 return $self->_process_($this,$flag,3);
1481}
1482
1483sub _not_equal_date_
1484{
1485 my($self,$this,$flag) = @_;
1486
1487 return $self->_process_($this,$flag,3) ^ 1;
1488}
1489
1490sub _equal_date_time_
1491{
1492 my($self,$this,$flag) = @_;
1493
1494 return $self->_process_($this,$flag,4);
1495}
1496
1497sub _not_equal_date_time_
1498{
1499 my($self,$this,$flag) = @_;
1500
1501 return $self->_process_($this,$flag,4) ^ 1;
1502}
1503
1504sub _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
1512sub _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
1549sub _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
1562sub _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
1665sub _plus_equal_
1666{
1667 my($self,$this) = @_;
1668
1669 return $self->_plus_($this,undef);
1670}
1671
1672sub _minus_equal_
1673{
1674 my($self,$this) = @_;
1675
1676 return $self->_minus_($this,undef);
1677}
1678
1679sub _increment_
1680{
1681 my($self) = @_;
1682
1683 return $self->_plus_(1,undef);
1684}
1685
1686sub _decrement_
1687{
1688 my($self) = @_;
1689
1690 return $self->_minus_(1,undef);
1691}
1692
16931;
1694
1695__END__
1696
Full OpenSPARC design & verification tarball including full HDL.