File Coverage

blib/lib/Date/EzDate2.pm
Criterion Covered Total %
statement 396 495 80.0
branch 204 292 69.8
condition 66 92 71.7
subroutine 40 48 83.3
pod 0 9 0.0
total 706 936 75.4


line stmt bran cond sub pod time code
1             package Date::EzDate2;
2 1     1   1753 use strict;
  1         1  
  1         23  
3 1     1   3 use Carp 'croak';
  1         1  
  1         63  
4              
5             # debugging tools
6             # use Debug::ShowStuff ':all';
7             # use Debug::ShowStuff::ShowVar;
8              
9             # version
10             our $VERSION = '0.01';
11              
12              
13             #------------------------------------------------------------------------------
14             # pod
15             #
16              
17             =head1 NAME
18              
19             Date::EzDate2 - Date and time manipulation made easy
20              
21             =head1 EzDate2 vs EzDate
22              
23             EzDate2 is the next generation of the module Date::EzDate. EzDate2 provides
24             the same easy interface for dealing with date and time, but uses DateTime
25             to provide a wider and more accurate set of services.
26              
27             EzDate2 is *NOT* a drop-in replacement for EzDate. That's why it's not just
28             an updated version of EzDate.
29              
30             This early release is just to test EzDate2's distribution on CPAN. It's not yet
31             ready for prime time.
32              
33             =head1 SYNOPSIS
34              
35             An EzDate2 object represents a single point in time and exposes all properties
36             of that point. It also makes it easy to change those properties to produce
37             a different point in time. EzDate2 has many features, here are a few:
38              
39             use Date::EzDate2;
40             my $mydate = Date::EzDate2->new();
41              
42             # output some date information
43             print $mydate, "\n"; # e.g. output: Fri Jul 22, 2016 16:53:33
44              
45             =cut
46              
47             #
48             # pod
49             #------------------------------------------------------------------------------
50              
51              
52              
53             # warn levels
54 1     1   3 use constant WARN_NONE => 0;
  1         3  
  1         65  
55 1     1   3 use constant WARN_STDERR => 1;
  1         8  
  1         36  
56 1     1   2 use constant WARN_CROAK => 2;
  1         2  
  1         91  
57             our $default_warning = WARN_STDERR;
58              
59              
60             #------------------------------------------------------------------------------
61             # object overloading
62             #
63             use overload
64 6     6   60 '""' => sub{$_[0]->{'default'}}, # stringification
65 1         9 '<=>' => \&compare, # comparison
66             '+' => \&addition, # addition
67             '-' => \&subtraction, # subtraction
68 1     1   966 fallback => 1; # operations not defined here
  1         925  
69             #
70             # object overloading
71             #------------------------------------------------------------------------------
72              
73              
74             #------------------------------------------------------------------------------
75             # new
76             #
77             sub new {
78 40     40 0 9022 my ($class, $time, %opts) = @_;
79 40         51 my ($rv, %tiehash);
80            
81             # TESTING
82             # println subname(); ##i
83            
84             # create tied hash
85 40 50       226 tie(%tiehash, $class . '::Tie', $time, %opts) or return undef;
86            
87             # create blessed reference to tied hash
88 40         109 $rv = bless(\%tiehash, $class);
89            
90             # return
91 40         92 return $rv;
92             }
93             #
94             # new
95             #------------------------------------------------------------------------------
96              
97              
98             #------------------------------------------------------------------------------
99             # clone
100             #
101             sub clone {
102 16     16 0 111 my ($ezdate) = @_;
103            
104             # TESTING
105             # println subname(), ' - ', __PACKAGE__; ##i
106            
107             # call tied object's new()
108 16         42 return ref($ezdate)->new($ezdate);
109             }
110             #
111             # clone
112             #------------------------------------------------------------------------------
113              
114              
115             #------------------------------------------------------------------------------
116             # next_month
117             #
118             sub next_month {
119 3     3 0 24 my ($ezdate, $count) = @_;
120            
121             # TESTING
122             # println subname(); ##i
123            
124             # call tied object's next_month()
125 3         7 return tied(%$ezdate)->next_month($count);
126             }
127             #
128             # next_month
129             #------------------------------------------------------------------------------
130              
131              
132              
133             #------------------------------------------------------------------------------
134             # settings and utility subs
135             #
136 0     0 0 0 sub zero_hour_ampm {return $_[0]->tie_ob->{'zero_hour_ampm'} = $_[1]}
137              
138 1     1 0 8 sub set_format {return $_[0]->tie_ob->set_format(@_[1..$#_])}
139              
140             sub get_format {
141 0     0 0 0 my ($self, $key) = @_;
142 0         0 my $ob = $self->tie_ob;
143 0         0 $key =~ s|\s||gs;
144 0         0 $key = lc($key);
145 0         0 return join('', @{$ob->{'formats'}->{$key}});
  0         0  
146             }
147              
148 0     0 0 0 sub del_format {return delete $_[0]->{$_[1]}}
149 18     18 0 22 sub tie_ob{return tied(%{$_[0]})}
  18         61  
150              
151             # warnings level
152             sub set_warnings {
153 1     1 0 6 my ($ezdate, $level) = @_;
154            
155             # TESTING
156             # println subname(); ##i
157            
158             # level must be defined
159 1 50       4 if (! defined $level)
160 0         0 { croak 'level-not-defined: warning level is not defined' }
161            
162             # normalize
163 1         2 $level = lc($level);
164 1         2 $level =~ s|\s||gs;
165            
166             # plain english
167 1 50       5 if ($level eq 'none')
    50          
    50          
    0          
168 0         0 { $level = WARN_NONE }
169             elsif ($level eq 'stderr')
170 0         0 { $level = WARN_STDERR }
171             elsif ($level eq 'croak')
172 1         3 { $level = WARN_CROAK }
173             elsif ($level eq 'default')
174 0         0 { $level = $default_warning }
175            
176             # set tied object
177 1         3 return $ezdate->tie_ob->{'warnings'} = $level;
178             }
179              
180             #
181             # settings and utility subs
182             #------------------------------------------------------------------------------
183              
184              
185             ###############################################################################
186             # Date::EzDate2::Tie
187             #
188             package Date::EzDate2::Tie;
189 1     1   435 use strict;
  1         1  
  1         22  
190 1     1   857 use DateTime;
  1         82766  
  1         34  
191 1     1   9 use DateTime::TimeZone;
  1         0  
  1         17  
192 1     1   5 use Carp qw{carp croak};
  1         2  
  1         86  
193 1     1   453 use Clone;
  1         2212  
  1         45  
194 1     1   4 use base 'Tie::StdHash';
  1         2  
  1         529  
195              
196             # debugging tools
197             # use Debug::ShowStuff ':all';
198              
199              
200             #------------------------------------------------------------------------------
201             # globals
202             #
203             our (
204             @ltimefields, @OrdWords, $OrdWordsRx, %PCodes, %WeekDayNums,
205             %OrdWordsNums, @OrdNums, %MonthNums, $pcode,
206             );
207              
208             # localtime() fields
209             # @ltimefields = qw[sec min hour dayofmonth monthnum year weekdaynum yearday dst];
210             @ltimefields = qw[sec min hour dayofmonth monthnum year];
211              
212             # words for the days of the month
213             @OrdWords = qw[
214             Zeroth First Second Third Fourth Fifth Sixth Seventh Eighth Ninth Tenth
215             Eleventh Twelfth Thirteenth Fourteenth Fifteenth Sixteenth Seventeenth
216             Eighteenth Ninteenth Twentieth Twentyfirst Twentysecond Twentythird
217             Twentyfourth Twentyfifth Twentysixth Twentyseventh Twentyeighth Twentyninth
218             Thirtieth Thirtyfirst
219             ];
220              
221             # regular expression versions of OrdWords
222             $OrdWordsRx = '\b(' . join('|', @OrdWords[1..$#OrdWords]) . ')\b';
223              
224             # build hash or ord words
225             foreach my $i (1..$#OrdWords)
226             { $OrdWordsNums{lc($OrdWords[$i])} = $i }
227              
228             # number ordinals
229             @OrdNums = qw[
230             0th 1st 2nd 3rd 4th 5th 6th 7th 8th 9th 10th 11th 12th 13th 14th 15th 16th
231             17th 18th 19th 20th 21st 22nd 23rd 24th 25th 26th 27th 28th 29th 30th 31st
232             ];
233              
234             # month numbers
235             @MonthNums{qw[jan feb mar apr may jun jul aug sep oct nov dec]} = (1..12);
236              
237             # weekday numbers
238             $WeekDayNums{'mon'} = 1;
239             $WeekDayNums{'tue'} = 2;
240             $WeekDayNums{'wed'} = 3;
241             $WeekDayNums{'thu'} = 4;
242             $WeekDayNums{'fri'} = 5;
243             $WeekDayNums{'sat'} = 6;
244             $WeekDayNums{'sun'} = 7;
245              
246             # @WeekDayShort = qw[Sun Mon Tue Wed Thu Fri Sat];
247             # @WeekDayLong = qw[Sunday Monday Tuesday Wednesday Thursday Friday Saturday];
248             # @MonthShort = qw[Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec];
249             # @MonthLong = qw[January February March April May June July August September October November December];
250             # @MonthDays = qw[31 x 31 30 31 30 31 31 30 31 30 31];
251              
252             # percent code regex
253             $pcode = '^\%[\w\%]$';
254              
255             # warn levels
256 1     1   5 use constant WARN_NONE => Date::EzDate2::WARN_NONE;
  1         1  
  1         72  
257 1     1   9 use constant WARN_STDERR => Date::EzDate2::WARN_STDERR;
  1         2  
  1         38  
258 1     1   4 use constant WARN_CROAK => Date::EzDate2::WARN_CROAK;
  1         1  
  1         4984  
259              
260             %PCodes = qw[
261             yearlong year
262             yearshort yeartwodigit
263             dayofyear yearday
264             dayofyear3d yearday3d
265             dayofweeknum weekdaynum
266             dayofweeknum2d weekdaynum2d
267             %Y year
268             %y yeartwodigit
269             %a weekdayshort
270             %A weekdaylong
271             %d dayofmonth
272             %D {monthnum2d}/{dayofmonth2d}/{year2d}
273             %H hour2d
274             %h monthshort
275             %b ampmhournozero
276             %B hournozero
277             %e monthnum
278             %m monthnum2d
279             %j dayofyear3d
280             %f dayofmonthnozero
281             %k ampmhour
282             %M min2d
283             %P ampmuc
284             %p ampmlc
285             %s epochsec
286             %S sec2d
287             %w weekdaynum
288             %y yeartwodigit
289             %T %H:%M:%S
290             %n newline
291             %t tab
292             %% percent
293             ];
294              
295             $PCodes{'%c'} = '{weekdayshort} %h %d {hour2d}:{min2d}:{sec2d} %Y';
296             $PCodes{'%r'} = '%k:%M:%S %P';
297              
298             #
299             # globals
300             #------------------------------------------------------------------------------
301              
302              
303             #------------------------------------------------------------------------------
304             # TIEHASH
305             #
306             sub TIEHASH {
307 40     40   50 my ($class, $time, %opts) = @_;
308 40         65 my $eztied = bless ({}, $class);
309            
310             # TESTING
311             # println subname(); ##i
312            
313             # set some non-date properties
314             # $eztied->{'zero_hour_ampm'} = defined($opts{'zero_hour_ampm'}) ? $opts{'zero_hour_ampm'} : 1;
315 40         93 $eztied->{'formats'} = {};
316 40         84 $eztied->{'settings'} = {'dst_kludge' => 1};
317            
318             # default builtin formats
319 40         86 $eztied->set_format('fullday', '{month short} {day of month no zero}, {year}');
320 40         65 $eztied->set_format('fulldate', '{fullday}');
321 40         62 $eztied->set_format('dayandtime', '{month short} {day of month}, {year} {ampmhour no zero}:{minute}{ampm}');
322 40         67 $eztied->set_format('default', '{full}');
323            
324             # if clone
325 40 100       182 if (UNIVERSAL::isa $time, 'Date::EzDate2'){
326 16         33 $eztied->clone($time);
327             }
328            
329             # else
330             else {
331             # set DateTime object to current time
332 24         101 $eztied->{'dt'} = DateTime->now(
333             time_zone => DateTime::TimeZone->new( name => 'local' )->name(),
334             );
335            
336             # if time is a scalar and has content, call timefromstring()
337 24 50 66     19140 if ( defined($time) && (! ref $time) && ($time =~ m|\S|s) ) {
      66        
338 23         70 $eztied->timefromstring($time);
339             }
340             }
341            
342             # return
343 40         140 return $eztied;
344             }
345             #
346             # TIEHASH
347             #------------------------------------------------------------------------------
348              
349              
350             #------------------------------------------------------------------------------
351             # clone
352             #
353             sub clone {
354 16     16   22 my ($new, $old) = @_;
355            
356             # TESTING
357             # println subname(), ' - ', __PACKAGE__; ##i
358            
359             # ensure we're using the tied hash
360 16 50       48 if ( UNIVERSAL::isa $old, 'Date::EzDate2' )
361 16         44 { $old = $old->tie_ob() }
362            
363             # formats and settings
364 16         453 $new->{'formats'} = Clone::clone($old->{'formats'});
365 16         116 $new->{'settings'} = Clone::clone($old->{'settings'});
366            
367             # datetime object
368 16         63 $new->{'dt'} = $old->{'dt'}->clone();
369            
370             # return
371 16         153 return $new;
372             }
373             #
374             # clone
375             #------------------------------------------------------------------------------
376              
377              
378              
379             #------------------------------------------------------------------------------
380             # STORE
381             #
382             our $left_brace_rx = quotemeta('{');
383              
384             sub STORE {
385 98     98   658 my ($eztied, $key, $val) = @_;
386 98         93 my (%set, $orgkey, $orgval, $dt);
387            
388             # TESTING
389             # println subname(); ##i
390            
391             # hold on to original values
392 98         104 $orgkey = $key;
393 98         84 $orgval = $val;
394            
395             # error checking
396 98 50       200 if (! defined $val) {
397 0         0 return $eztied->warn(
398             'value-not-defined-in-store: ' .
399             'Must send a defined value when setting a ' .
400             'property of an EzDate object'
401             );
402             }
403            
404             # if value contains {, assume they're assigning a format
405 98 50       322 $val =~ m|$left_brace_rx| and return $eztied->set_format($key, $val);
406            
407             # normalize key
408 98         149 normalize_key($key);
409 98         164 $key = $eztied->get_alias($key, 'strip_no_zero'=>1);
410            
411             # TESTING
412             # showvar $key;
413            
414             # normalize value
415 98         107 $val = lc($val);
416 98         173 $val =~ s|^\s+||gs;
417 98         113 $val =~ s|\s+$||gs;
418 98         98 $val =~ s|\s+| |gs;
419            
420             # TESTING
421             # println $key, ': ', $val;
422            
423             # get DateTime object
424 98         103 $dt = $eztied->{'dt'};
425            
426             # day of month
427 98 100 100     1131 if ($key eq 'dayofmonth') {
    100 100        
    100 100        
    100 66        
    100 100        
    100 100        
    100 100        
    100 100        
    100 100        
    100 100        
    100 100        
    50 100        
428 17         29 $set{'day'} = $val;
429             }
430            
431             # year
432             elsif ($key eq 'year') {
433 17         30 $set{'year'} = $val;
434             }
435            
436             # month
437             elsif ( ($key eq 'month') || ($key eq 'monthnum') || ($key eq 'monthlong') || ($key eq 'monthshort') ) {
438             # letters
439 21 100       58 unless ( $val =~ m|^\d+$|si ) {
440             # get just first three letters
441 18         23 $val =~ s|\s||gs;
442 18         31 $val = substr($val, 0, 3);
443            
444             # if a month number exists, use it, else throw error
445             # KLUDGE: assuming English names for now, will work with
446             # DateTime's locale functions later.
447 18 50       46 if (my $num = $MonthNums{$val}) {
448 18         22 $val = $num;
449             }
450             else {
451 0         0 return $eztied->warn(
452             "invalid-month-name: do not know this month name: $orgval"
453             )
454             }
455             }
456            
457             # set month
458 21         46 $set{'month'} = $val;
459             }
460            
461             # weekday
462             elsif ( ($key eq 'weekday') || ($key eq 'weekdaynum') || ($key eq 'weekdayshort') || ($key eq 'weekdaylong') ) {
463             # if not integer, get integer value
464 6 100       17 unless ($val =~ m|^\d+$|s) {
465             # get just first three letters
466 5         10 $val = lc($val);
467 5         8 $val =~ s|\s||gs;
468 5         11 $val = substr($val, 0, 3);
469            
470             # attempt to get value
471 5 50       17 unless ($val = $WeekDayNums{$val}) {
472 0         0 return $eztied->warn(
473             "invalid-weekday-name: do not know this weekday name: $orgval"
474             )
475             }
476             }
477            
478             # set day
479 6 100       17 unless ( $val == $dt->day_of_week ) {
480 5         26 $set{'day'} = $dt->day + $val - $dt->day_of_week;
481             }
482             }
483            
484             # yearday
485             elsif ( ($key eq 'yearday') || ($key eq 'yearday3d') ) {
486 3         3 my ($current);
487            
488             # check for integer and range
489 3 50       11 $eztied->integer_check($key, $val)
490             or return 0;
491            
492             # get current value
493 3         9 $current = $dt->day_of_year();
494            
495             # if they're not equal, set to new day of year
496 3 50       16 unless ($current == $val) {
497             # add days
498 3         11 $dt->add(
499             days => $val - $current,
500             );
501            
502             # return
503 3         1217 return 1;
504             }
505             }
506            
507             # hour
508             elsif ( ($key eq 'hour') || ($key eq 'hour2d') ) {
509             # check for integer and range
510 3 50       7 $eztied->integer_check($key, $val)
511             or return 0;
512            
513             # assign value
514 3         10 $set{'hour'} = $val;
515             }
516            
517             # minute
518             elsif ( ($key eq 'min') || ($key eq 'min2d') ) {
519             # check for integer
520 3 50       5 $eztied->integer_check($key, $val)
521             or return 0;
522            
523             # assign value
524 3         6 $set{'minute'} = $val;
525             }
526            
527             # second
528             elsif ( ($key eq 'sec') || ($key eq 'sec2d') ) {
529             # check for integer and range
530 3 50       6 $eztied->integer_check($key, $val)
531             or return 0;
532            
533             # assign value
534 3         6 $set{'second'} = $val;
535             }
536            
537             # ampm
538             elsif ( ($key eq 'ampm') || ($key eq 'ampmlc') || ($key eq 'ampmuc') ) {
539 20         18 my ($current);
540            
541             # add 'm' to just or or p
542 20 100       48 if (length($val) == 1)
543 1         3 {$val .= 'm'}
544            
545             # normalize
546 20         28 $val =~ s|\s||gs;
547            
548             # error checking
549 20 50 66     67 unless ( ($val eq 'am') || ($val eq 'pm') )
550 0         0 { return $eztied->warn('invalid-ampm: ampm may only be set to am or pm') }
551            
552             # get dt object
553 20         51 $current = $dt->hour;
554            
555             # if no change, we're done
556 20 100       90 if ($current < 12) {
557 16 100       37 if ($val eq 'am')
558 1         2 { return 1}
559             }
560             else {
561 4 50       12 if ($val eq 'pm')
562 0         0 { return 1}
563             }
564            
565             # set change
566 19 100       29 if ($val eq 'am')
567 4         10 { $set{'hour'} = $current - 12 }
568             else
569 15         31 { $set{'hour'} = $current + 12 }
570             }
571            
572             # ampmhour
573             elsif ($key eq 'ampmhour') {
574             # check for integer
575 2 50       6 $eztied->integer_check($key, $val)
576             or return 0;
577            
578             # add twelve if necessary
579 2 50       5 if ($dt->hour >= 12)
580 2         21 { $val += 12 }
581            
582             # set
583 2         4 $set{'hour'} = $val;
584             }
585            
586             # miltime
587             elsif ($key eq 'miltime') {
588             # must ve exactly four digits
589 2 50       8 unless ($val =~ m|^\d{4}$|s)
590 0         0 { return $eztied->warn('invalid-miltime: miltime must consist of exactly four digits') }
591            
592             # set
593 2         6 $set{'hour'} = substr($val, 0, 2);
594 2         4 $set{'minute'} = substr($val, 2, 2);
595             }
596            
597             # dmy
598             elsif ($key eq 'dmy') {
599 1         2 my (@tokens, $day, $month, $year);
600            
601             # split
602 1         1 $val = lc($val);
603 1         7 @tokens = split(m/(\d+)|([a-z]+)/si, $val);
604 1         3 @tokens = grep {defined $_} @tokens;
  8         11  
605 1         2 @tokens = grep {m|\S|s} @tokens;
  6         8  
606            
607             # get values
608 1         3 ($day, $month, $year) = @tokens;
609            
610             # check day
611 1 50       4 $eztied->integer_check("$key - day", $day)
612             or return 0;
613            
614             # normalize month
615 1         3 $month = substr($month, 0, 3);
616            
617             # if a month number exists, use it, else throw error
618             # KLUDGE: assuming English names for now, will work with
619             # DateTime's locale functions later.
620 1 50       4 if (my $num = $MonthNums{$month}) {
621 1         2 $month = $num;
622             }
623             else {
624 0         0 return $eztied->warn(
625             "invalid-month-name: do not know this month name: $orgval"
626             )
627             }
628            
629             # check year
630 1 50       3 $eztied->integer_check("$key - year", $year)
631             or return 0;
632            
633             # set
634 1         2 $set{'day'} = $day;
635 1         2 $set{'month'} = $month;
636 1         2 $set{'year'} = $year;
637             }
638            
639             # elsif ($key eq 'minofday') {
640             # $eztied->setfromtime (
641             # DST_ADJUST_NO,
642             # $eztied->{'epochsec'} - ($eztied->{'hour'} * t_60_60) - ($eztied->{'min'} * 60) + ($val * 60)
643             # )
644             # }
645             #
646             # elsif ($key eq 'hour') {
647             # $val = timelocal(
648             # $eztied->{'sec'},
649             # $eztied->{'min'},
650             # $val,
651             # $eztied->{'dayofmonth'},
652             # $eztied->{'monthnum'},
653             # $eztied->{'year'},
654             # );
655             #
656             # $eztied->setfromtime(DST_ADJUST_NO, $val);
657             # }
658             #
659             # # hour and minute
660             # elsif ( ($key eq 'clocktime') || ($key =~ m|^mil(itary)?time$|) ) {
661             # my ($changed, $hour, $min, $sec) = $eztied->gettime($val);
662             #
663             # unless (defined $hour)
664             # {$hour = $eztied->{'hour'}}
665             # unless (defined $min)
666             # {$min = $eztied->{'min'}}
667             # unless (defined $sec)
668             # {$sec = $eztied->{'sec'}}
669             #
670             # $eztied->setfromtime
671             # (
672             # 0,
673             # $eztied->{'epochsec'}
674             #
675             # - ($eztied->{'sec'})
676             # - ($eztied->{'min'} * 60)
677             # - ($eztied->{'hour'} * t_60_60)
678             #
679             # + ($sec)
680             # + ($min * 60)
681             # + ($hour * t_60_60)
682             # );
683             # }
684             #
685             # elsif ($key eq 'dst')
686             # {return $eztied->warn('dst property is read-only')}
687             #
688             # elsif ($key eq 'epochsec')
689             # {$eztied->setfromtime(DST_ADJUST_NO, $val)}
690             #
691             # elsif ($key eq 'epochmin')
692             # {$eztied->setfromtime(DST_ADJUST_NO, $eztied->{'epochsec'} - ($eztied->getepochmin * 60) + ($val * 60) )}
693             #
694             # elsif ($key eq 'epochhour')
695             # {$eztied->setfromtime(DST_ADJUST_NO, $eztied->{'epochsec'} - ($eztied->getepochhour * t_60_60) + ($val * t_60_60) )}
696             #
697             # elsif ($key eq 'epochday') {
698             # my ($oldhour, $oldepochsec, $oldmin);
699             #
700             # $eztied->setfromtime(
701             # DST_ADJUST_YES,
702             # $eztied->{'epochsec'} - ($eztied->getepochday * t_60_60_24) + (int($val) * t_60_60_24)
703             # );
704             # }
705             #
706             # # ordinals
707             # elsif ($key =~ m/dayofmonthord(word|num)?/) {
708             # # if numeric
709             # if ($val =~ s|^(\d+)\s*\w*$|$1|s)
710             # {$eztied->STORE('dayofmonth', $val)}
711             #
712             # # else word
713             # else {
714             # my $nval = $val;
715             # $nval =~ tr/A-Z/a-z/;
716             # $nval =~ s|\W||gs;
717             #
718             # # if no such ordinal exists
719             # unless ($nval = $OrdWordsNums{$nval})
720             # { return $eztied->warn("Invalid ordinal: $val") }
721             #
722             # $eztied->STORE('dayofmonth', $nval);
723             # }
724             # }
725             #
726             # elsif ($key eq 'year') {
727             # my ($maxday, $targetday);
728             #
729             # # if same year, nothing to do
730             # if ($eztied->{'year'} == $val)
731             # {return}
732             #
733             # # make sure day of month isn't greater than maximum day of target month
734             # $maxday = daysinmonth($eztied->{'monthnum'}, $val);
735             #
736             # if ($eztied->{'dayofmonth'} > $maxday) {
737             # $eztied->warn(
738             # "Changing the year sets day of month ($eztied->{'dayofmonth'}) to higher than days in month ($maxday); ",
739             # "setting the day down to $maxday"
740             # );
741             # $targetday = $maxday;
742             # }
743             # else
744             # {$targetday = $eztied->{'dayofmonth'}}
745             #
746             # $val = timelocal($eztied->{'sec'}, $eztied->{'min'}, $eztied->{'hour'}, $targetday, $eztied->{'monthnum'}, $val);
747             # $eztied->setfromtime(DST_ADJUST_YES, $val);
748             # }
749             #
750             # elsif ($key =~ m/^year(two|2)digit/) {
751             # $val =~ s|^.*(..)$|$1|;
752             # $eztied->STORE('year', substr($eztied->{'year'}, 0, 2) . zeropad_2($val));
753             # }
754             #
755             # elsif ($key =~ m/^monthnumbase(one|1)/)
756             # {$eztied->STORE('monthnum', $val - 1)}
757             #
758             #
759             # #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
760             # # monthnum
761             # #
762             # elsif ($key eq 'monthnum') {
763             # my ($target, $epoch_second);
764             # my $month = $eztied->{'monthnum'};
765             # my $year = $eztied->{'year'};
766             # my $orgday = $eztied->{'dayofmonth'};
767             # my $dayofmonth = $eztied->{'dayofmonth'};
768             # my $jumps = $val - $month;
769             #
770             # # if nothing to do
771             # $jumps or return;
772             #
773             # $target = $jumps;
774             # $target = abs($target);
775             #
776             # # jumping forward
777             # if ($jumps > 0) {
778             # foreach (1..$target) {
779             # # if end of year
780             # if ($month == 11) {
781             # $month = 0;
782             # $year++;
783             # }
784             # else
785             # {$month++}
786             # }
787             # }
788             #
789             # # jumping backward
790             # else {
791             # foreach (1..$target) {
792             # # if beginning of year
793             # if ($month == 0) {
794             # $month = 11;
795             # $year--;
796             # }
797             # else
798             # {$month--}
799             # }
800             # }
801             #
802             #
803             # # adjust day for shorter month (if necessary)
804             # if ($dayofmonth > 28) {
805             # my $dim = daysinmonth($month, $year);
806             #
807             # if ($dim < $dayofmonth)
808             # { $dayofmonth = $dim }
809             # }
810             #
811             # # get epoch second from timelocal
812             # $epoch_second = timelocal($eztied->{'sec'}, $eztied->{'min'}, $eztied->{'hour'}, $dayofmonth, $month, $year);
813             # $eztied->setfromtime(DST_ADJUST_NO, $epoch_second);
814             # }
815             # #
816             # # monthnum
817             # #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
818             #
819             #
820             # elsif ( ($key eq 'monthshort') || ($key eq 'monthlong') )
821             # {$eztied->STORE('monthnum', $MonthNums{lc(substr($val, 0, 3))})}
822             #
823             # elsif (
824             # ($key eq 'weekdayshort') ||
825             # ($key eq 'weekdaylong') ||
826             # ($key eq 'dayofweekshort') ||
827             # ($key eq 'dayofweeklong')
828             # ) {
829             # $eztied->STORE(
830             # 'weekdaynum',
831             # $WeekDayNums{lc(substr($val, 0, 3))})
832             # }
833             #
834             # else
835             # { return $eztied->warn("Do not understand key: $orgkey") }
836            
837             # else don't know key
838             else {
839             # TESTING
840             # die "unknown-name-for-store: do not know this property name: $orgkey";
841            
842             # return with warning
843 0         0 return $eztied->warn(
844             "unknown-name-for-store: do not know this property name: $orgkey"
845             )
846             }
847            
848             # set new date and time
849 94         186 $eztied->new_date_time(\%set);
850            
851             # return value
852 94         399 return $val;
853             }
854             #
855             # STORE
856             #------------------------------------------------------------------------------
857              
858              
859             #------------------------------------------------------------------------------
860             # integer_check
861             #
862             sub integer_check {
863 16     16   22 my ($eztied, $key, $val) = @_;
864            
865             # TESTING
866             # println subname(); ##i
867            
868             # must be all digit and greater than zero
869 16 50 33     122 unless ( defined($val) && ($val =~ m|^\d+$|s) && ($val > 0) ) {
      33        
870             # warn
871 0 0       0 $eztied->warn(
872             "not-integer-for-$key: " .
873             "the value for $key must be a positive integer but is " .
874             (defined($val) ? "\"$val\"" : 'undef') . ' ' .
875             "instead"
876             );
877            
878             # return false
879 0         0 return 0;
880             }
881            
882             # return true
883 16         48 return 1;
884             }
885             #
886             # integer_check
887             #------------------------------------------------------------------------------
888              
889              
890              
891             #------------------------------------------------------------------------------
892             # timefromstring
893             #
894              
895             # today, now, yesterday, tomorrow
896             our %relative = (
897             today => 1,
898             now => 1,
899             yesterday => 1,
900             tomorrow => 1,
901             );
902              
903             # map time units to duractions
904             #my %duration_map = (
905             # year => 'years',
906             # month => 'months',
907             # day => 'days',
908             # hour => 'hours',
909             # minute => 'minutes',
910             # second => 'seconds',
911             #);
912              
913             sub timefromstring {
914 23     23   42 my ($eztied, $val, %opts) = @_;
915            
916             # TESTING
917             # println subname(); ##i
918            
919             # error checking
920 23 50       49 if (! defined $val)
921 0         0 { return $eztied->warn('time-string-not-defined: did not get a defined time string') }
922            
923             # alias hour am/pm to hour:00 am/pm
924             # $eztied->{'zero_hour_ampm'} and $val =~ s/(^|[^:\d])(\d+)\s*([ap]m)/$1$2:00:00 $3/gis;
925             # $eztied->{'zero_hour_ampm'} and $val =~ s/(^|[^:\d])(\d+)\s*([ap]m?\b)/$1$2:00:00 $3/gis;
926            
927             # normalize
928             # $val = lc($val);
929 23         55 $val =~ s|^\s+||s;
930 23         70 $val =~ s|\s+$||s;
931 23         57 $val =~ s|\s+| |s;
932            
933             # if just an integer
934 23 50       126 if ($val =~ m/^\d+$/i) {
    50          
935 0         0 my ($year, $month, $day, $hour, $min, $sec, $doy, $dow, $dst) = Gmtime($val);
936            
937             # set from gmtime
938 0         0 $eztied->{'year'} = $year;
939 0         0 $eztied->{'monthnum'} = $month;
940 0         0 $eztied->{'dayofmonth'} = $day;
941 0         0 $eztied->{'hour'} = $hour;
942 0         0 $eztied->{'min'} = $min;
943 0         0 $eztied->{'sec'} = $sec;
944             }
945            
946             # elsif today, now, yesterday, tomorrow
947             elsif ($relative{lc $val}) {
948             # lowercase
949 0         0 $val = lc($val);
950            
951             # today
952 0 0 0     0 if ( ($val eq 'today') || ($val eq 'now') ) {
953 0         0 $eztied->setfromtime();
954             }
955            
956             # tomorrow
957 0 0       0 if ($val eq 'tomorrow') {
958 0         0 $eztied->setfromtime();
959            
960             @$eztied{qw{year monthnum dayofmonth}} =
961 0         0 Add_Delta_Days(@$eztied{qw{year monthnum dayofmonth}}, 1);
962             }
963            
964             # yesterday
965 0 0       0 if ($val eq 'yesterday') {
966 0         0 $eztied->setfromtime();
967            
968             @$eztied{qw{year monthnum dayofmonth}} =
969 0         0 Add_Delta_Days(@$eztied{qw{year monthnum dayofmonth}}, -1);
970             }
971             }
972            
973             # else a date string
974             else {
975 23         25 my (%set);
976            
977             # TESTING
978             # println 'date string'; ##i
979             # showvar $val;
980            
981             # special case: ##:##.#####
982             # In some time formats, the hour, min, second is
983             # followed by fractional seconds. We don't handle those
984             # fractions, so we'll just remove them.
985 23         84 $val =~ s/(\d+\:\d+)\.[\d\-]+/$1/g;
986            
987             # Another special case: A.M. to AM and P.M. to PM
988 23         53 $val =~ s/a\.m\b/am/gis;
989 23         26 $val =~ s/p\.m\b/pm/gis;
990            
991             # remove time zone if it exists
992 23 50       60 if ( $val =~ s|[a-z_]+\s*/\s*[a-z_]+$||si ) {
993 0         0 $set{'time_zone'} = $&;
994 0         0 $val =~ s|\s+$||s;
995             }
996            
997             # normalize
998 23         29 $val = lc($val);
999 23         107 $val =~ s/[^\w:]/ /g;
1000 23         110 $val =~ s/\s*:\s*/:/g;
1001            
1002             # change ordinals to numbers
1003 23         234 $val =~ s|$OrdWordsRx|$OrdWordsNums{$1}|gis;
1004 23         82 $val =~ s/(\d)(th|rd|st|nd)\b/$1/gis;
1005            
1006             # noon to 12:00:00
1007             # midnight to 00:00:00
1008 23         55 $val =~ s/\bnoon\b/ 12:00:00 /gis;
1009 23         44 $val =~ s/\bmidnight\b/ 00:00:00 /gis;
1010            
1011             # normalize some more
1012 23         58 $val =~ s/(\d)([a-z])/$1 $2/g;
1013 23         50 $val =~ s/([a-z])(\d)/$1 $2/g;
1014 23         81 $val =~ s/\s+/ /g;
1015 23         44 $val =~ s/^\s*//;
1016 23         103 $val =~ s/\s*$//;
1017 23         66 $val =~ s/([a-z]{3})[a-z]+/$1/gs;
1018            
1019             # remove weekday
1020             # TOD0: use localized names of weekdays
1021 23         162 $val =~ s/((sun)|(mon)|(tue)|(wed)|(thu)|(fri)|(sat))\s*//;
1022 23         92 $val =~ s/\s*$//;
1023            
1024             # attempt to get time
1025 23 50       77 unless ($opts{'dateonly'}) {
1026 23         64 ($val, @set{qw{hour minute second}}) = $eztied->gettime($val, 'skipjustdigits'=>1);
1027             }
1028            
1029             # attempt to get date
1030 23 50       53 unless ($opts{'timeonly'}) {
1031 23 50       37 if (length $val) {
1032 23         52 ($val, @set{qw{day month year}}) = getdate($val);
1033             }
1034             }
1035            
1036             # attempt to get time again
1037 23 50       50 unless ($opts{'dateonly'}) {
1038 23 100 66     102 if (length($val) && (! defined($set{'hour'})) ) {
1039 22         23 my ($hour_new, $min_new, $sec_new);
1040            
1041             # parse again
1042 22         50 ($val, $hour_new, $min_new, $sec_new) = $eztied->gettime($val, 'skipjustdigits'=>1, 'croakonfail'=>1);
1043            
1044             # set from new valued if they are defined
1045 22 50       63 defined($hour_new) and $set{'hour'} = $hour_new;
1046 22 50       45 defined($min_new) and $set{'minute'} = $min_new;
1047 22 50       52 defined($sec_new) and $set{'second'} = $sec_new;
1048             }
1049             }
1050            
1051             # is somehow we don't still have a defined string, return
1052 23 50       50 if (! defined $val)
1053 0         0 { return 0 }
1054            
1055             # trim
1056 23         47 $val =~ s/^\s*//;
1057            
1058             # create new datetime object
1059 23 50       45 if (%set) {
1060 23         52 $eztied->new_date_time(\%set);
1061             }
1062             }
1063            
1064             # return
1065 23         55 return 1;
1066             }
1067             #
1068             # timefromstring
1069             #------------------------------------------------------------------------------
1070              
1071              
1072             #------------------------------------------------------------------------------
1073             # new_date_time
1074             #
1075             sub new_date_time {
1076 117     117   106 my ($eztied, $set) = @_;
1077 117         81 my ($old, $new, %offset);
1078            
1079             # TESTING
1080             # println subname(); ##i
1081            
1082             # old datetime object
1083 117         101 $old = $eztied->{'dt'};
1084            
1085             # create new datetime object with just year
1086             $new = DateTime->new(
1087             year => coal($set->{'year'}, $old->year),
1088 117   33     341 time_zone => $set->{'time_zone'} || $old->time_zone,
1089             );
1090            
1091             # delete year
1092 117         12571 delete $set->{'year'};
1093            
1094             # build duration
1095 117         266 foreach my $key (keys %$set) {
1096 194 100       275 if (defined $set->{$key}) {
1097 191         361 $offset{$key . 's'} = $set->{$key};
1098             }
1099             }
1100            
1101             # decrement months and days
1102 117         132 foreach my $key (qw{months days}) {
1103 234 100       374 if (defined $offset{$key})
1104 91         132 { $offset{$key}-- }
1105             }
1106            
1107             # add offset to new datetime object
1108             $new->add(
1109             months => coal($offset{'months'}, $old->month - 1 ),
1110             days => coal($offset{'days'}, $old->day - 1 ),
1111             hours => coal($offset{'hours'}, $old->hour ),
1112             minutes => coal($offset{'minutes'}, $old->minute ),
1113 117         297 seconds => coal($offset{'seconds'}, $old->second ),
1114             );
1115            
1116             # set new dattime object
1117 117         42823 $eztied->{'dt'} = $new;
1118             }
1119             #
1120             # new_date_time
1121             #------------------------------------------------------------------------------
1122              
1123              
1124             #------------------------------------------------------------------------------
1125             # coal
1126             # short for coalesce
1127             #
1128             sub coal {
1129 702     702   2175 my ($new, $old) = @_;
1130 702 100       1976 return defined($new) ? $new : $old;
1131             }
1132             #
1133             # coal
1134             #------------------------------------------------------------------------------
1135              
1136              
1137             #------------------------------------------------------------------------------
1138             # getdate
1139             # attempt to get date
1140             # supported date formats
1141             # 14 Jan 2001
1142             # 14 JAN 01
1143             # 14JAN2001
1144             # Jan 14, 2001
1145             # Jan 14, 01
1146             # 01-14-01
1147             # 1-14-01
1148             # 1-7-01
1149             # 01-14-2001
1150             #
1151             sub getdate {
1152 23     23   27 my ($val) = @_;
1153 23         28 my ($day, $month, $year);
1154            
1155             # TESTING
1156             # println subname(); ##i
1157            
1158             # Tue Jun 12 13:03:28 2012
1159 23 50       199 if ($val =~ s/^([a-z]+) (\d+) (\S+) (\d+)$/$3/) {
    100          
    50          
    0          
    0          
    0          
1160 0         0 $year = $4;
1161 0         0 $month = $MonthNums{$1};
1162 0         0 $day = $2;
1163             }
1164            
1165             # 14 Jan 2001
1166             # 14 JAN 01
1167             # 14JAN2001 # will be normalized to have spaces
1168             elsif ($val =~ m/^\d+ [a-z]+ \d{4}$/) {
1169 1         5 my @tokens = split(' ', $val);
1170 1         2 $day = $tokens[0];
1171 1         2 $month = $MonthNums{$tokens[1]};
1172 1         2 $year = $tokens[2];
1173 1         2 $val = '';
1174             }
1175            
1176             # Jan 14, 2001
1177             # Jan 14, 01
1178             elsif ($val =~ s/^([a-z]+) (\d+) (\d+)//) {
1179 22         48 $month = $MonthNums{$1};
1180 22         37 $day = $2;
1181 22         31 $year = $3;
1182             }
1183            
1184             # Jan 2001
1185             # Jan 01
1186             elsif ($val =~ s/^([a-z]+) (\d+)//) {
1187 0         0 $month = $MonthNums{$1};
1188 0         0 $year = $2;
1189             }
1190            
1191             # 2001-01-14
1192             elsif ($val =~ s/^(\d{4}) (\d+) (\d+)//) {
1193 0         0 $year = $1;
1194 0         0 $month = $2 - 1;
1195 0         0 $day = $3;
1196             }
1197            
1198             # 01-14-01
1199             # 1-14-01
1200             # 1-7-01
1201             # 01-14-2001
1202             elsif ($val =~ s/^(\d+) (\d+) (\d+)//) {
1203 0         0 $month = $1 - 1;
1204 0         0 $day = $2;
1205 0         0 $year = $3;
1206             }
1207            
1208             # return
1209 23         102 return ($val, $day, $month, $year);
1210             }
1211             #
1212             # getdate
1213             #------------------------------------------------------------------------------
1214              
1215              
1216             #------------------------------------------------------------------------------
1217             # gettime
1218             # supported time formats:
1219             # 5pm
1220             # 5:34 pm
1221             # 17:34
1222             # 17:34:13
1223             # 5:34:13
1224             # 5:34:13 pm
1225             # 2330 (military time)
1226             #
1227             sub gettime {
1228 45     45   111 my ($eztied, $str, %opts)= @_;
1229 45         37 my ($hour, $min, $sec);
1230            
1231             # TESTING
1232             # println subname(); ##i
1233            
1234             # string must be defined
1235 45 50       74 unless (defined $str) {
1236 0         0 croak 'strin-not-defined: $str is not defined';
1237             }
1238            
1239             # clean up a little
1240 45         88 $str =~ s/^\s+//;
1241 45         80 $str =~ s/\s+$//;
1242 45         39 $str =~ s/^://;
1243 45         36 $str =~ s/:$//;
1244 45         97 $str =~ s/(\d)(am|pm)/$1 $2/;
1245            
1246             # 5:34:13 pm
1247             # 5:34:13 p
1248 45 100 33     338 if ($str =~ s/^(\d+):(\d+):(\d+) (a|p)(m|\b)\s*//) {
    100          
    50          
    50          
    50          
    50          
    50          
1249 19         38 $hour = ampmhour($1, $4);
1250 19         24 $min = $2;
1251 19         18 $sec = $3;
1252             }
1253            
1254             # 17:34:13
1255             elsif ($str =~ s/^(\d+):(\d+):(\d+)\s*//) {
1256 3         7 $hour = $1;
1257 3         7 $min = $2;
1258 3         4 $sec = $3;
1259             }
1260            
1261             # 5:34 pm
1262             elsif ($str =~ s/^(\d+):(\d+) (a|p)m?\s*//) {
1263 0         0 $hour = ampmhour($1, $3);
1264 0         0 $min = $2;
1265             }
1266            
1267             # 17:34
1268             elsif ($str =~ s/^(\d+):(\d+)\s*//) {
1269 0         0 $hour = $1;
1270 0         0 $min = $2;
1271             }
1272            
1273             # 5 pm
1274             elsif ($str =~ s/^(\d+) (a|p)m?\b\s*//) {
1275 0         0 $hour = ampmhour($1, $2);
1276 0         0 $min = 0;
1277 0         0 $sec = 0;
1278             }
1279            
1280             # elsif just digits
1281             elsif ( (! $opts{'skipjustdigits'}) && ($str =~ m/^\d+$/) ) {
1282 0         0 $str = zeropad_open($str, 4);
1283 0         0 $hour = substr($str, 0, 2);
1284 0         0 $min = substr($str, 2, 2);
1285             }
1286            
1287             # else don't recognize format
1288             elsif ($opts{'croakonfail'}) {
1289 0         0 return $eztied->warn("unrecognized-format: don't recognize time format: $str");
1290             }
1291            
1292             # return
1293 45         181 return ($str, $hour, $min, $sec);
1294             }
1295             #
1296             # gettime
1297             #------------------------------------------------------------------------------
1298              
1299              
1300             #------------------------------------------------------------------------------
1301             # ampmhour
1302             #
1303             sub ampmhour {
1304 19     19   38 my ($hour, $ampm) = @_;
1305            
1306             # if 12
1307 19 100       75 if ($hour == 12) {
    100          
1308             # if am, set to 0
1309 3 50       9 if ($ampm =~ m/^a/)
1310 0         0 {$hour = 0}
1311             }
1312            
1313             # else if pm, add 12
1314             elsif ($ampm =~ m/^p/) {
1315 5         7 $hour += 12;
1316             }
1317            
1318             # return
1319 19         33 return $hour;
1320             }
1321             #
1322             # ampmhour
1323             #------------------------------------------------------------------------------
1324              
1325              
1326             #------------------------------------------------------------------------------
1327             # set_format
1328             #
1329             sub set_format {
1330 161     161   157 my ($eztied, $name, $format) = @_;
1331            
1332             # normalize name
1333 161         194 $name =~ s|\s||g;
1334 161         1441 $name =~ lc($name);
1335            
1336 161         234 $eztied->{'formats'}->{$name} = format_split($format);
1337             }
1338              
1339             sub format_split {
1340             # split
1341 223     223   1708 my @rv = split(m/(\{[^\{\}]*\}|\%.)/, $_[0]);
1342            
1343             # normalize
1344 223         300 foreach my $el (@rv) {
1345 1417 100       2319 if ($el =~ m|^\{.*\}$|s)
1346 558         572 { normalize_key($el) }
1347             }
1348            
1349             # remove empties
1350 223         228 @rv = grep {length $_} @rv;
  1417         1517  
1351            
1352             # return
1353 223         527 return \@rv;
1354             }
1355             #
1356             # set_format
1357             #------------------------------------------------------------------------------
1358              
1359              
1360             #------------------------------------------------------------------------------
1361             # setfromtime
1362             #
1363             sub setfromtime {
1364 0     0   0 my ($eztied, $time) = @_;
1365            
1366             # TESTING
1367             # println subname(); ##i
1368            
1369             # set time fields
1370 0         0 @$eztied{@ltimefields} = localtime();
1371            
1372             # add 1900 to year
1373 0         0 $eztied->{'year'} += 1900;
1374            
1375             # increment monthnum, which was base zero, to base one
1376 0         0 $eztied->{'monthnum'}++;
1377             }
1378             #
1379             # setfromtime
1380             #------------------------------------------------------------------------------
1381              
1382              
1383             #------------------------------------------------------------------------------
1384             # normalize_key
1385             #
1386             sub normalize_key {
1387 1581     1581   1972 $_[0] =~ s|\s||gs;
1388 1581 100       2825 $_[0] =~ tr/A-Z/a-z/ unless $_[0] =~ m|^\%\w$|;
1389 1581         1337 $_[0] =~ s|ordinal|ord|sg;
1390            
1391 1581         1188 $_[0] =~ s|hours|hour|sg;
1392            
1393 1581         1161 $_[0] =~ s|minute|min|sg;
1394 1581         1088 $_[0] =~ s|mins|min|sg;
1395            
1396 1581         1046 $_[0] =~ s|second|sec|sg;
1397 1581         1106 $_[0] =~ s|secs|sec|sg;
1398            
1399 1581         1155 $_[0] =~ s/two/2/gs;
1400 1581         1225 $_[0] =~ s/three/3/gs;
1401 1581         1232 $_[0] =~ s/digits?/d/gs;
1402            
1403 1581         996 $_[0] =~ s/timezone/tz/gs;
1404            
1405 1581         1525 $_[0] =~ s|number|num|sg;
1406             }
1407             #
1408             # normalize_key
1409             #------------------------------------------------------------------------------
1410              
1411              
1412              
1413              
1414             #------------------------------------------------------------------------------
1415             # zeropad_open, zeropad_2
1416             #
1417             sub zeropad_open {
1418 30     30   87 my ($rv, $length) = @_;
1419 30   50     42 $length ||= 2;
1420             # return ('0' x ($length - length($rv))) . $rv;
1421 30         134 return sprintf "%0${length}d", $rv;
1422             }
1423              
1424             sub zeropad_2 {
1425 456     456   1447 my ($val) = @_;
1426            
1427             # $val must be defined
1428 456 50       614 if (! defined $val) {
1429 0         0 croak 'zeropad_2~val-not-defined: the value sent to zeropad_2 is not defined';
1430             }
1431            
1432             # return
1433 456         1760 return sprintf "%02d", $_[0];
1434             }
1435             #
1436             # zeropad_open, zeropad_2
1437             #------------------------------------------------------------------------------
1438              
1439              
1440             #------------------------------------------------------------------------------
1441             # month_short
1442             #
1443             #sub month_short {
1444             # my ($eztied) = @_;
1445             # my ($rv);
1446             #
1447             # # get name of month, return just the first three letters
1448             # $rv = Month_to_Text($eztied->{'monthnum'});
1449             # $rv = substr($rv, 0, 3);
1450             #
1451             # # return
1452             # return $rv;
1453             #}
1454             #
1455             # month_short
1456             #------------------------------------------------------------------------------
1457              
1458              
1459             #------------------------------------------------------------------------------
1460             # FETCH
1461             #
1462             sub FETCH {
1463 1268     1268   14011 my ($eztied, $key, %opts) = @_;
1464 1268         845 my ($orgkey, $dt);
1465            
1466             # TESTING
1467             # println subname(); ##i
1468            
1469             # hold on to original key
1470 1268         919 $orgkey = $key;
1471            
1472             # get key from aliases if necessary
1473 1268         1394 $key = $eztied->get_alias($key);
1474            
1475            
1476             #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1477             # nested properties
1478             #
1479 1268 100 100     4630 if ( (! ref $key) && ($key =~ m|[\{\%]|) && ($key !~ m|$pcode|o) )
      66        
1480 62         97 { $key = format_split($key) }
1481            
1482 1268 100       1493 if (ref $key) {
1483 69         144 my @rv = @$key;
1484            
1485 69         76 foreach my $el (@rv) {
1486             # if this is one of the format elements
1487             # then fetch the value of the given key
1488 480 100 100     2267 if (
1489             ($el =~ s|\{([^\}]+)\}|$1|) || # if it is enclosed in {}
1490             ($el =~ m|$pcode|o) # if it is a %x code
1491             ) {
1492 274         320 $el =~ s|['"\s]||g;
1493 274         383 $el = $eztied->FETCH($el, normalized=>1);
1494             }
1495             }
1496            
1497             # ensure defined values in @rv
1498 69         235 foreach my $val (@rv) {
1499 480 50       588 if (! defined $val)
1500 0         0 { $val = '' }
1501             }
1502            
1503             # return
1504 69         349 return join('', @rv);
1505             }
1506             #
1507             # nested properties
1508             #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1509            
1510            
1511             # clean up key
1512 1199 100       1967 $opts{'normalized'} or normalize_key($key);
1513            
1514             # datetime object
1515 1199         1038 $dt = $eztied->{'dt'};
1516            
1517             # datetime object
1518 1199 50 33     3171 if ( ($key eq 'dt') || $key eq 'datetime' ) {
1519 0         0 return $dt;
1520             }
1521            
1522             # already or mostly calculated
1523             #if (exists $eztied->{$key}) {
1524             # # ensure two digits for several properties
1525             # if ( $key =~ m/^(dayofmonth|monthnum|hour|min|sec)$/ )
1526             # { return zeropad_2($eztied->{$key}) }
1527             #
1528             # # all other properties, return key as-is
1529             # return $eztied->{$key};
1530             #}
1531            
1532             # character codes
1533 1199 100       1381 $key eq 'newline' and return "\n";
1534 1184 100       1270 $key eq 'tab' and return "\t";
1535 1169 50       1188 $key eq 'leftbrace' and return '{';
1536 1169 50       1273 $key eq 'lb' and return '{';
1537 1169 50       1298 $key eq 'rightbrace' and return '}';
1538 1169 50       1282 $key eq 'rb' and return '}';
1539 1169 100       1383 $key eq 'percent' and return '%';
1540            
1541             # nozero's
1542 1154 100       1754 if ($key =~ s/no(zero|0)//)
1543 75         104 { return $eztied->FETCH($key) + 0 }
1544            
1545             # day of month
1546 1079 100       1303 if ($key eq 'dayofmonth')
1547 66         140 { return $dt->day }
1548            
1549             # day of month, two digits
1550 1013 100       1116 if ($key eq 'dayofmonth2d')
1551 30         87 { return zeropad_2($dt->day) }
1552            
1553             # day of month ord
1554 983 50       1193 if ($key =~ m|^dayofmonthord(word)?$|)
1555 0         0 { return $OrdWords[$eztied->{'dayofmonth'}] }
1556 983 50       1076 if ($key eq 'dayofmonthordnum')
1557 0         0 { return $OrdNums[$eztied->{'dayofmonth'}] }
1558            
1559             # weekdaynum
1560 983 100       1056 if ($key eq 'weekdaynum')
1561 30         82 { return $dt->day_of_week() }
1562            
1563             # weekdaynum2d
1564 953 50       1067 if ($key eq 'weekdaynum2d')
1565 0         0 { return zeropad_2($dt->day_of_week()) }
1566            
1567             # weekday
1568 953 100       1289 if ($key =~ m/^(weekdayshort|dayofweekshort|dayofweek)$/)
1569 45         115 { return $dt->day_abbr() }
1570 908 100       1016 if ($key =~ m/^(weekdaylong|dayofweeklong)$/)
1571 31         81 { return $dt->day_name() }
1572            
1573             # month
1574 877 100       943 if ($key eq 'monthshort')
1575 47         99 { return $dt->month_abbr() }
1576 830 100 66     2045 if ( ($key eq 'month') || ($key eq 'monthlong') )
1577 16         63 { return $dt->month_name() }
1578            
1579             # month number
1580 814 100       916 if ($key eq 'monthnum')
1581 31         81 { return $dt->month }
1582 783 100       867 if ($key eq 'monthnum2d')
1583 45         87 { return zeropad_2($dt->month) }
1584            
1585             # day of year
1586 738 100       880 if ($key eq 'yearday')
1587 16         52 { return $dt->day_of_year() }
1588 722 100       828 if ($key eq 'yearday3d')
1589 30         57 { return zeropad_open($dt->day_of_year(), 3) }
1590            
1591             # year
1592 692 100       756 if ($key eq 'year')
1593 48         103 { return $dt->year }
1594 644 100       704 if ($key eq 'year2d')
1595 45         90 { return substr($dt->year, -2) }
1596            
1597             # epoch
1598 599 50 33     1437 if ( ($key eq 'epoch') || ($key eq 'epochsec') )
1599 0         0 { return Date_to_Time(@$eztied{qw{year monthnum dayofmonth hour min sec}}) }
1600            
1601             # leapyear
1602 599 100       769 if ($key =~ m/^(is)?leapyear/)
1603 30         81 { return $dt->is_leap_year() }
1604            
1605             # days in month
1606 569 100       648 if ($key eq 'daysinmonth') {
1607 30         56 return DateTime->last_day_of_month(
1608             year => $dt->year,
1609             month => $dt->month,
1610             time_zone => $dt->time_zone_long_name()
1611             )->day;
1612             }
1613            
1614             # DMY: eg 15JAN2001
1615 539 100       638 if ($key eq 'dmy') {
1616             return
1617 1         2 zeropad_2($dt->day) .
1618             uc($dt->month_abbr()) .
1619             $dt->year;
1620             }
1621            
1622             # full
1623 538 100       589 if ($key eq 'full') {
1624 11         6 my ($weekday);
1625            
1626             # return
1627             return
1628 11         29 $dt->day_abbr() . ' ' .
1629             $dt->month_abbr() . ' ' .
1630             $dt->day() . ', ' .
1631             $dt->year() . ' ' .
1632             zeropad_2($dt->hour) . ':' .
1633             zeropad_2($dt->minute) . ':' .
1634             zeropad_2($dt->second);
1635             }
1636            
1637             # military time, aka "miltime"
1638 527 100       724 if ($key =~ m|^mil(itary)?time$|)
1639 30         66 { return zeropad_2($dt->hour) . zeropad_2($dt->minute) }
1640            
1641             # iso8601
1642 497 50       615 if ($key eq 'iso8601') {
1643             return
1644             $eztied->{'year'} . '-' .
1645             zeropad_2($eztied->{'monthnum'}) . '-' .
1646             zeropad_2($eztied->{'dayofmonth'}) . ' ' .
1647            
1648             zeropad_2($eztied->{'hour'}) . ':' .
1649             zeropad_2($eztied->{'min'}) . ':' .
1650 0         0 zeropad_2($eztied->{'sec'});
1651             }
1652            
1653             # hour
1654 497 100       555 if ($key eq 'hour')
1655 15         37 { return $dt->hour }
1656            
1657             # hour two digits
1658 482 100       567 if ($key eq 'hour2d')
1659 60         134 { return zeropad_2($dt->hour) }
1660            
1661             # minute
1662 422 100       492 if ($key eq 'min')
1663 45         88 { return $dt->minute }
1664            
1665             # minute two digits
1666 377 100       444 if ($key eq 'min2d')
1667 75         144 { return zeropad_2($dt->minute) }
1668            
1669             # second
1670 302 100       371 if ($key eq 'sec')
1671 60         114 { return $dt->second }
1672            
1673             # second two digits
1674 242 100       308 if ($key eq 'sec2d')
1675 75         164 { return zeropad_2($dt->second) }
1676            
1677             # variable
1678 167         109 my ($ampm);
1679            
1680             # calculate ampm, which is needed in most results from here down
1681 167 100       339 $ampm = ($dt->hour >= 12) ? 'pm' : 'am';
1682            
1683             # am/pm
1684 167 100 100     962 if ( ($key eq 'ampm') || ($key eq 'ampmlc') )
1685 45         106 { return $ampm }
1686            
1687             # AM/PM uppercase
1688 122 100       174 if ($key eq 'ampmuc')
1689 45         124 { return uc($ampm) }
1690            
1691             # variable
1692 77         46 my ($ampmhour);
1693            
1694             # calculate ampmhour, which is needed from here down
1695 77 100 66     122 if ( ($dt->hour == 0) || ($dt->hour == 12) )
    50          
1696 2         18 { $ampmhour = 12 }
1697             elsif ($dt->hour > 12)
1698 0         0 { $ampmhour = $dt->hour - 12 }
1699             else
1700 75         715 { $ampmhour = $dt->hour }
1701            
1702             # am/pm hour
1703 77 100       240 if ($key eq 'ampmhour')
1704 60         72 { return zeropad_2($ampmhour) }
1705            
1706             # hour and minute with ampm
1707 17 50 33     50 if (
1708             ($key eq 'clocktime') ||
1709             ($key eq 'clocktimestrict')
1710             ) {
1711            
1712             return
1713 17         56 $ampmhour . ':' .
1714             zeropad_2($dt->minute) . ' ' .
1715             $ampm;
1716             }
1717            
1718             # tz
1719 0 0       0 if ( $key eq 'tz' ) {
1720 0         0 return $dt->time_zone_short_name;
1721             }
1722            
1723             # olson
1724 0 0       0 if ( $key eq 'olson' ) {
1725 0         0 return $dt->time_zone_long_name;
1726             }
1727            
1728             # else we don't know what property is needed
1729 0         0 return $eztied->warn("unknown-format: do not know this format: $orgkey");
1730             }
1731             #
1732             # FETCH
1733             #------------------------------------------------------------------------------
1734              
1735              
1736             #------------------------------------------------------------------------------
1737             # warn
1738             #
1739             sub warn {
1740 0     0   0 my $eztied = shift;
1741 0 0       0 my $level = defined($eztied->{'warnings'}) ? $eztied->{'warnings'} : $Date::EzDate2::default_warning;
1742            
1743             # TESTING
1744             # println subname(); ##i
1745            
1746             # if no level, return undef
1747 0 0       0 $level or return undef;
1748            
1749 0 0       0 if ($level == WARN_STDERR) {
1750             # showstack();
1751 0         0 carp 'WARNING: ', @_;
1752 0         0 return undef;
1753             }
1754            
1755             # croak
1756 0         0 croak @_;
1757             }
1758             #
1759             # warn
1760             #------------------------------------------------------------------------------
1761              
1762              
1763             #------------------------------------------------------------------------------
1764             # get_alias
1765             #
1766             sub get_alias {
1767 1970     1970   1861 my ($eztied, $key, %opts) = @_;
1768            
1769             # normalize
1770 1970 100       3806 unless ($key =~ m|[\{\%]|) {
1771 1352         1690 $key =~ s|\s||g;
1772 1352         1300 $key = lc($key);
1773            
1774             # strip "nozero" if that option was sent
1775 1352 100       1969 $opts{'strip_no_zero'} and $key =~ s|nozero||g;
1776             }
1777            
1778             # if this key has an alias
1779 1970 100       2839 if (exists $PCodes{$key})
1780 604         1010 {return $eztied->get_alias($PCodes{$key}, %opts)}
1781            
1782             # if this is a named format
1783 1366 100       1817 if (exists $eztied->{'formats'}->{$key})
1784 7         14 {return $eztied->{'formats'}->{$key}}
1785            
1786 1359         2044 return $key;
1787             }
1788             #
1789             # get_alias
1790             #------------------------------------------------------------------------------
1791              
1792              
1793             #------------------------------------------------------------------------------
1794             # ym, ymd
1795             #
1796             sub ym {
1797 0     0   0 my ($eztied) = @_;
1798 0         0 return @$eztied{qw{year monthnum}};
1799             }
1800              
1801             sub ymd {
1802 0     0   0 my ($eztied) = @_;
1803 0         0 return @$eztied{qw{year monthnum dayofmonth}};
1804             }
1805             #
1806             # ym, ymd
1807             #------------------------------------------------------------------------------
1808              
1809              
1810             #------------------------------------------------------------------------------
1811             # next_month
1812             #
1813             sub next_month {
1814 3     3   4 my ($eztied, $count) = @_;
1815            
1816             # TESTING
1817             # println subname(); ##i
1818            
1819             # add months and return
1820 3         7 return $eztied->{'dt'}->add(months => $count, end_of_month=>'limit');
1821             }
1822             #
1823             # next_month
1824             #------------------------------------------------------------------------------
1825              
1826              
1827             #------------------------------------------------------------------------------
1828             # DELETE
1829             #
1830             sub DELETE {
1831 0     0     my ($eztied, $key) = @_;
1832            
1833             # normalize key
1834 0           $key =~ s|\s||gs;
1835 0           $key = lc($key);
1836            
1837             # delete from formats, but not properties
1838 0           return delete $eztied->{'formats'}->{$key};
1839             }
1840             #
1841             # DELETE
1842             #------------------------------------------------------------------------------
1843              
1844             #
1845             # Date::EzDate2::Tie
1846             ###############################################################################
1847              
1848              
1849             # return true
1850             1;
1851              
1852             __END__