File Coverage

blib/lib/DateTime/Event/Cron.pm
Criterion Covered Total %
statement 374 418 89.4
branch 135 172 78.4
condition 41 74 55.4
subroutine 68 79 86.0
pod 14 21 66.6
total 632 764 82.7


line stmt bran cond sub pod time code
1             package DateTime::Event::Cron;
2              
3 7     7   2141080 use 5.006;
  7         18  
4 7     7   26 use strict;
  7         9  
  7         129  
5 7     7   21 use warnings;
  7         11  
  7         187  
6 7     7   21 use Carp;
  7         8  
  7         422  
7              
8 7     7   30 use vars qw($VERSION);
  7         7  
  7         337  
9              
10             $VERSION = '0.09';
11              
12 7     7   24 use constant DEBUG => 0;
  7         9  
  7         473  
13              
14 7     7   754 use DateTime;
  7         308203  
  7         139  
15 7     7   3361 use DateTime::Set;
  7         229703  
  7         178  
16 7     7   51 use DateTime::Duration;
  7         11  
  7         123  
17 7     7   2592 use Set::Crontab;
  7         4572  
  7         15709  
18              
19             my %Object_Attributes;
20              
21             ###
22              
23             sub from_cron {
24             # Return cron as DateTime::Set
25 29     29 1 12712 my $class = shift;
26 29 50       121 my %sparms = @_ == 1 ? (cron => shift) : @_;
27 29         32 my %parms;
28 29         50 $parms{cron} = delete $sparms{cron};
29 29         77 $parms{user_mode} = delete $sparms{user_mode};
30 29 100       307 $parms{cron} or croak "Cron string parameter required.\n";
31 27         83 my $dtc = $class->new(%parms);
32 22         67 $dtc->as_set(%sparms);
33             }
34              
35             sub from_crontab {
36             # Return list of DateTime::Sets based on entries from
37             # a crontab file.
38 1     1 1 102 my $class = shift;
39 1 50       7 my %sparms = @_ == 1 ? (file => shift) : @_;
40 1         3 my $file = delete $sparms{file};
41 1         1 delete $sparms{cron};
42 1         20 my $fh = $class->_prepare_fh($file);
43 1         1 my @cronsets;
44 1         5 while (<$fh>) {
45 11         14 chomp;
46 11         8 my $set;
47 11         8 eval { $set = $class->from_cron(%sparms, cron => $_) };
  11         21  
48 11 100 66     481 push(@cronsets, $set) if ref $set && !$@;
49             }
50 1         4 @cronsets;
51             }
52              
53             sub as_set {
54             # Return self as DateTime::Set
55 22     22 1 22 my $self = shift;
56 22         29 my %sparms = @_;
57             Carp::cluck "Recurrence callbacks overriden by ". ref $self . "\n"
58 22 50 33     117 if $sparms{next} || $sparms{recurrence} || $sparms{previous};
      33        
59 22         24 delete $sparms{next};
60 22         36 delete $sparms{previous};
61 22         43 delete $sparms{recurrence};
62 22     83   88 $sparms{next} = sub { $self->next(@_) };
  83         32941  
63 22     65   59 $sparms{previous} = sub { $self->previous(@_) };
  65         36199  
64 22         109 DateTime::Set->from_recurrence(%sparms);
65             }
66              
67             ###
68              
69             sub new {
70 54     54 0 7945 my $class = shift;
71 54         77 my $self = {};
72 54         79 bless $self, $class;
73 54 100       176 my %parms = @_ == 1 ? (cron => shift) : @_;
74 54         172 my $crontab = $self->_make_cronset(%parms);
75 33         59 $self->_cronset($crontab);
76 33         60 $self;
77             }
78              
79 7     7 1 4563 sub new_from_cron { new(@_) }
80              
81             sub new_from_crontab {
82 0     0 1 0 my $class = shift;
83 0 0       0 my %parms = @_ == 1 ? (file => shift()) : @_;
84 0         0 my $fh = $class->_prepare_fh($parms{file});
85 0         0 delete $parms{file};
86 0         0 my @dtcrons;
87 0         0 while (<$fh>) {
88 0         0 my $dtc;
89 0         0 eval { $dtc = $class->new(%parms, cron => $_) };
  0         0  
90 0 0 0     0 if (ref $dtc && !$@) {
91 0         0 push(@dtcrons, $dtc);
92 0 0       0 $parms{user_mode} = 1 if defined $dtc->user;
93             }
94             }
95 0         0 @dtcrons;
96             }
97              
98             ###
99              
100             sub _prepare_fh {
101 1     1   1 my $class = shift;
102 1         2 my $fh = shift;
103 1 50       3 if (! ref $fh) {
104 0         0 my $file = $fh;
105 0         0 local(*FH);
106 0         0 $fh = do { local *FH; *FH }; # doubled *FH avoids warning
  0         0  
  0         0  
107 0 0       0 open($fh, "<$file")
108             or croak "Error opening $file for reading\n";
109             }
110 1         2 $fh;
111             }
112              
113             ###
114              
115             sub valid {
116             # Is the given date valid according the current cron settings?
117 444     444 1 20946 my($self, $date) = @_;
118 444 100 66     889 return if !$date || $date->second;
119 432 100 100     8439 $self->minute->contains($date->minute) &&
      100        
120             $self->hour->contains($date->hour) &&
121             $self->days_contain($date->day, $date->dow) &&
122             $self->month->contains($date->month);
123             }
124              
125             sub match {
126             # Does the given date match the cron spec?
127 0     0 1 0 my($self, $date) = @_;
128 0 0       0 $date = DateTime->now unless $date;
129 0 0 0     0 $self->minute->contains($date->minute) &&
      0        
130             $self->hour->contains($date->hour) &&
131             $self->days_contain($date->day, $date->dow) &&
132             $self->month->contains($date->month);
133             }
134              
135             ### Return adjacent dates without altering original date
136              
137             sub next {
138 99     99 1 22870 my($self, $date) = @_;
139 99   66     231 $self->increment($date || DateTime->now);
140             }
141              
142             sub previous {
143 81     81 1 14579 my($self, $date) = @_;
144 81   66     227 $self->decrement($date || DateTime->now);
145             }
146              
147             ### Change given date to adjacent dates
148              
149             sub increment {
150 99     99 1 2257 my($self, $date) = @_;
151 99 50       164 $date = $date ? $date->clone : DateTime->now;
152 99 100       2207 return $date if $date->is_infinite;
153 77         201 do {
154 78         121 $self->_attempt_increment($date);
155             } until $self->valid($date);
156 77         838 $date;
157             }
158              
159             sub decrement {
160 81     81 1 1911 my($self, $date) = @_;
161 81 50       149 $date = $date ? $date->clone : DateTime->now;
162 81 100       1914 return $date if $date->is_infinite;
163 59         163 do {
164 59         118 $self->_attempt_decrement($date);
165             } until $self->valid($date);
166 59         678 $date;
167             }
168              
169             ###
170              
171             sub _attempt_increment {
172 78     78   128 my($self, $date) = @_;
173 78 50       145 ref $date or croak "Reference to datetime object reqired\n";
174 78 100       115 $self->valid($date) ?
175             $self->_valid_incr($date) :
176             $self->_invalid_incr($date);
177             }
178              
179             sub _attempt_decrement {
180 59     59   69 my($self, $date) = @_;
181 59 50       146 ref $date or croak "Reference to datetime object reqired\n";
182 59 100       93 $self->valid($date) ?
183             $self->_valid_decr($date) :
184             $self->_invalid_decr($date);
185             }
186              
187 50     50   466 sub _valid_incr { shift->_incr(@_) }
188              
189 36     36   354 sub _valid_decr { shift->_decr(@_) }
190              
191             sub _invalid_incr {
192             # If provided date is valid, return it. Otherwise return
193             # nearest valid date after provided date.
194 28     28   332 my($self, $date) = @_;
195 28 50       61 ref $date or croak "Reference to datetime object reqired\n";
196              
197 28         27 print STDERR "\nI GOT: ", $date->datetime, "\n" if DEBUG;
198              
199 28 100       54 $date->truncate(to => 'minute')->add(minutes => 1)
200             if $date->second;
201              
202 28         6153 print STDERR "RND: ", $date->datetime, "\n" if DEBUG;
203              
204             # Find our greatest invalid unit and clip
205 28 100       56 if (!$self->month->contains($date->month)) {
    100          
    100          
206 3         27 $date->truncate(to => 'month');
207             }
208             elsif (!$self->days_contain($date->day, $date->dow)) {
209 12         44 $date->truncate(to => 'day');
210             }
211             elsif (!$self->hour->contains($date->hour)) {
212 5         43 $date->truncate(to => 'hour');
213             }
214             else {
215 8         80 $date->truncate(to => 'minute');
216             }
217              
218 28         4317 print STDERR "BBT: ", $date->datetime, "\n" if DEBUG;
219              
220 28 100       79 return $date if $self->valid($date);
221              
222 25         194 print STDERR "ZZT: ", $date->datetime, "\n" if DEBUG;
223              
224             # Extraneous durations clipped. Start searching.
225 25         42 while (!$self->valid($date)) {
226 40         334 $date->add(months => 1) until $self->month->contains($date->month);
227 40         270 print STDERR "MON: ", $date->datetime, "\n" if DEBUG;
228              
229 40         82 my $day_orig = $date->day;
230 40         144 $date->add(days => 1) until $self->days_contain($date->day, $date->dow);
231 40 100 50     88 $date->truncate(to => 'month') && next if $date->day < $day_orig;
232 35         126 print STDERR "DAY: ", $date->datetime, "\n" if DEBUG;
233              
234 35         80 my $hour_orig = $date->hour;
235 35         134 $date->add(hours => 1) until $self->hour->contains($date->hour);
236 35 100 50     291 $date->truncate(to => 'day') && next if $date->hour < $hour_orig;
237 30         103 print STDERR "HOR: ", $date->datetime, "\n" if DEBUG;
238              
239 30         60 my $min_orig = $date->minute;
240 30         112 $date->add(minutes => 1) until $self->minute->contains($date->minute);
241 30 100 50     261 $date->truncate(to => 'hour') && next if $date->minute < $min_orig;
242 25         121 print STDERR "MIN: ", $date->datetime, "\n" if DEBUG;
243             }
244 25         215 print STDERR "SET: ", $date->datetime, "\n" if DEBUG;
245 25         83 $date;
246             }
247              
248             sub _invalid_decr {
249             # If provided date is valid, return it. Otherwise
250             # return the nearest previous valid date.
251 23     23   234 my($self, $date) = @_;
252 23 50       57 ref $date or croak "Reference to datetime object reqired\n";
253              
254 23         18 print STDERR "\nD GOT: ", $date->datetime, "\n" if DEBUG;
255              
256 23 100       45 if (!$self->month->contains($date->month)) {
    100          
    100          
257 3         27 $date->truncate(to => 'month');
258             }
259             elsif (!$self->days_contain($date->day, $date->dow)) {
260 10         33 $date->truncate(to => 'day');
261             }
262             elsif (!$self->hour->contains($date->hour)) {
263 3         26 $date->truncate(to => 'hour');
264             }
265             else {
266 7         68 $date->truncate(to => 'minute');
267             }
268              
269 23         3606 print STDERR "BBT: ", $date->datetime, "\n" if DEBUG;
270              
271 23 100       49 return $date if $self->valid($date);
272              
273 20         161 print STDERR "ZZT: ", $date->datetime, "\n" if DEBUG;
274              
275             # Extraneous durations clipped. Start searching.
276 20         30 while (!$self->valid($date)) {
277 34 100       308 if (!$self->month->contains($date->month)) {
278 9         65 $date->subtract(months => 1) until $self->month->contains($date->month);
279 9         103 $self->_unit_peak($date, 'month');
280 9         11088 print STDERR "MON: ", $date->datetime, "\n" if DEBUG;
281             }
282 34 100       225 if (!$self->days_contain($date->day, $date->dow)) {
283 22         47 my $day_orig = $date->day;
284 22         86 $date->subtract(days => 1)
285             until $self->days_contain($date->day, $date->dow);
286 22 100 50     51 $self->_unit_peak($date, 'month') && next if ($date->day > $day_orig);
287 13         71 $self->_unit_peak($date, 'day');
288 13         15996 print STDERR "DAY: ", $date->datetime, "\n" if DEBUG;
289             }
290 25 100       63 if (!$self->hour->contains($date->hour)) {
291 21         182 my $hour_orig = $date->hour;
292 21         72 $date->subtract(hours => 1) until $self->hour->contains($date->hour);
293 21 100 50     189 $self->_unit_peak($date, 'day') && next if ($date->hour > $hour_orig);
294 18         80 $self->_unit_peak($date, 'hour');
295 18         21898 print STDERR "HOR: ", $date->datetime, "\n" if DEBUG;
296             }
297 22 50       95 if (!$self->minute->contains($date->minute)) {
298 22         194 my $min_orig = $date->minute;
299 22         92 $date->subtract(minutes => 1)
300             until $self->minute->contains($date->minute);
301 22 100 50     200 $self->_unit_peak($date, 'hour') && next if ($date->minute > $min_orig);
302 20         119 print STDERR "MIN: ", $date->datetime, "\n" if DEBUG;
303             }
304             }
305 20         195 print STDERR "SET: ", $date->datetime, "\n" if DEBUG;
306 20         75 $date;
307             }
308              
309             ###
310              
311             sub _unit_peak {
312 54     54   134 my($self, $date, $unit) = @_;
313 54 50 33     140 $date && $unit or croak "DateTime ref and unit required.\n";
314 54         1743 $date->truncate(to => $unit)
315             ->add($unit . 's' => 1)
316             ->subtract(minutes => 1);
317             }
318              
319             sub _next_day {
320 40     40   47 my($self, $year, $mon, $day) = @_;
321 40         106 my $dt = DateTime->new(year => $year, month => $mon, day => $day);
322 32         5819 my $dur = DateTime::Duration->new(days => 1);
323 32         1881 $dt->add_duration($dur);
324 32         15490 while (! $self->days_contain($dt->day, $dt->day_of_week)) {
325 395         829 $dt->add_duration($dur);
326             }
327 32         73 $dt->day;
328             }
329              
330             sub _prev_day {
331 31     31   39 my($self, $year, $mon, $day) = @_;
332 31         91 my $dt = DateTime->new(year => $year, month => $mon, day => $day);
333 24         4423 my $dur = DateTime::Duration->new(days => 1);
334 24         1306 $dt->subtract_duration($dur);
335 24         13048 while (! $self->days_contain($dt->day, $dt->day_of_week)) {
336 394         830 $dt->subtract_duration($dur);
337             }
338 24         64 $dt->day;
339             }
340              
341             ### Unit cascades
342              
343             sub _incr {
344 50     50   54 my($self, $date) = @_;
345 50         83 my $last_min = $date->minute;
346 50         152 my $last_hour = $date->hour;
347 50         178 my $last_day = $date->day;
348 50         142 my $last_month = $date->month;
349 50         145 my $year = $date->year;
350 50         146 my($next_min, $next_hour, $next_day, $next_month) =
351             ($last_min, $last_hour, $last_day, $last_month);
352 50         42 while (1) {
353 72         93 $next_min = $self->minute->next($last_min);
354 72 100       130 if ($next_min <= $last_min) {
355 48         72 $next_hour = $self->hour->next($last_hour);
356 48 100       85 if ($next_hour <= $last_hour) {
357 40         40 eval { $next_day = $self->_next_day($year, $last_month, $last_day) };
  40         68  
358 40 100 66     1499 if ($next_day <= $last_day || $@) {
359 19         45 $next_month = $self->month->next($last_month);
360 19 100       39 if ($next_month <= $last_month) {
361 9         8 $year += 1;
362             }
363 19         26 $last_month = $next_month;
364             }
365 40         37 $last_day = $next_day;
366             }
367 48         49 $last_hour = $next_hour;
368             }
369 72         62 $last_min = $next_min;
370 72         67 eval {
371 72         167 $date->set(
372             minute => $next_min,
373             hour => $next_hour,
374             day => $next_day,
375             month => $next_month,
376             year => $year,
377             );
378             };
379 72 100       22814 last unless $@;
380             }
381 50         186 $date;
382             }
383              
384             sub _decr {
385 36     36   49 my($self, $date) = @_;
386 36         69 my $last_min = $date->minute;
387 36         125 my $last_hour = $date->hour;
388 36         118 my $last_day = $date->day;
389 36         106 my $last_month = $date->month;
390 36         111 my $year = $date->year;
391 36         106 my($prev_min, $prev_hour, $prev_day, $prev_month) =
392             ($last_min, $last_hour, $last_day, $last_month);
393 36         39 while (1) {
394 68         101 $prev_min = $self->minute->previous($last_min);
395 68 100       125 if ($prev_min >= $last_min) {
396 43         62 $prev_hour = $self->hour->previous($last_hour);
397 43 100       81 if ($prev_hour >= $last_hour) {
398 31         33 eval { $prev_day = $self->_prev_day($year, $last_month, $last_day) };
  31         63  
399 31 100 66     1240 if ($prev_day >= $last_day || $@) {
400 21         49 $prev_month = $self->month->previous($last_month);
401 21 100       53 if ($prev_month >= $last_month) {
402 12         13 $year -= 1;
403             }
404 21         24 $last_month = $prev_month;
405             }
406 31         29 $last_day = $prev_day;
407             }
408 43         59 $last_hour = $prev_hour;
409             }
410 68         57 $last_min = $prev_min;
411 68         63 eval {
412 68         190 $date->set(
413             minute => $prev_min,
414             hour => $prev_hour,
415             day => $prev_day,
416             month => $prev_month,
417             year => $year,
418             );
419             };
420 68 100       21591 last unless $@;
421             }
422 36         137 $date;
423             }
424              
425             ### Factories
426              
427 54     54   45 sub _make_cronset { shift; DateTime::Event::Cron::IntegratedSet->new(@_) }
  54         144  
428              
429             ### Shortcuts
430              
431 1832     1832 0 703098 sub days_contain { shift->_cronset->days_contain(@_) }
432              
433 2123     2123 0 811722 sub minute { shift->_cronset->minute }
434 1074     1074 0 305657 sub hour { shift->_cronset->hour }
435 0     0 0 0 sub dom { shift->_cronset->dom }
436 544     544 0 53321 sub month { shift->_cronset->month }
437 0     0 0 0 sub dow { shift->_cronset->dow }
438 0     0 1 0 sub user { shift->_cronset->user }
439 0     0 1 0 sub command { shift->_cronset->command }
440 0     0 1 0 sub original { shift->_cronset->original }
441              
442             ### Static acessors/mutators
443              
444 5606     5606   7234 sub _cronset { shift->_attr('cronset', @_) }
445              
446             sub _attr {
447 5606     5606   4369 my $self = shift;
448 5606         4201 my $name = shift;
449 5606 100       8482 if (@_) {
450 33         94 $Object_Attributes{$self}{$name} = shift;
451             }
452 5606         13163 $Object_Attributes{$self}{$name};
453             }
454              
455             ### debugging
456              
457             sub _dump_sets {
458 0     0   0 my($self, $date) = @_;
459 0         0 foreach (qw(minute hour dom month dow)) {
460 0         0 print STDERR "$_: ", join(',',$self->$_->list), "\n";
461             }
462 0 0       0 if (ref $date) {
463 0         0 $date = $date->clone;
464 0         0 my @mod;
465 0         0 my $mon = $date->month;
466 0         0 $date->truncate(to => 'month');
467 0         0 while ($date->month == $mon) {
468 0 0       0 push(@mod, $date->day) if $self->days_contain($date->day, $date->dow);
469 0         0 $date->add(days => 1);
470             }
471 0         0 print STDERR "mod for month($mon): ", join(',', @mod), "\n";
472             }
473 0         0 print STDERR "day_squelch: ", $self->_cronset->day_squelch, " ",
474             "dow_squelch: ", $self->_cronset->dow_squelch, "\n";
475 0         0 $self;
476             }
477              
478             ###
479              
480 54     54   6923 sub DESTROY { delete $Object_Attributes{shift()} }
481              
482             ##########
483              
484             {
485              
486             package DateTime::Event::Cron::IntegratedSet;
487              
488             # IntegratedSet manages the collection of field sets for
489             # each cron entry, including sanity checks. Individual
490             # field sets are accessed through their respective names,
491             # i.e., minute hour dom month dow.
492             #
493             # Also implements some merged field logic for dom/dow
494             # interactions.
495              
496 7     7   44 use strict;
  7         12  
  7         132  
497 7     7   24 use Carp;
  7         7  
  7         6934  
498              
499             my %Range = (
500             minute => [0..59],
501             hour => [0..23],
502             dom => [1..31],
503             month => [1..12],
504             dow => [1..7],
505             );
506              
507             my @Month_Max = qw( 31 29 31 30 31 30 31 31 30 31 30 31 );
508              
509             my %Object_Attributes;
510              
511             sub new {
512 54     54   61 my $self = [];
513 54         68 bless $self, shift;
514 54         116 $self->_range(\%Range);
515 54         108 $self->set_cron(@_);
516 33         39 $self;
517             }
518              
519             sub set_cron {
520             # Initialize
521 54     54   54 my $self = shift;
522 54         85 my %parms = @_;
523 54         72 my $cron = $parms{cron};
524 54         55 my $user_mode = $parms{user_mode};
525 54 100       178 defined $cron or croak "Cron entry fields required\n";
526 53         78 $self->_attr('original', $cron);
527 53         47 my @line;
528 53 100       85 if (ref $cron) {
529 1         7 @line = grep(!/^\s*$/, @$cron);
530             }
531             else {
532 52         132 $cron =~ s/^\s+//;
533 52         141 $cron =~ s/\s+$//;
534 52         235 @line = split(/\s+/, $cron);
535             }
536 53 100       876 @line >= 5 or croak "At least five cron entry fields required.\n";
537 44         159 my @entry = splice(@line, 0, 5);
538 44         56 my($user, $command);
539 44 50       83 unless (defined $user_mode) {
540             # auto-detect
541 44 100 66     128 if (@line > 1 && $line[0] =~ /^\w+$/) {
542 4         4 $user_mode = 1;
543             }
544             }
545 44 100       81 $user = shift @line if $user_mode;
546 44         83 $command = join(' ', @line);
547 44         62 $self->_attr('command', $command);
548 44         60 $self->_attr('user', $user);
549 44         50 my $i = 0;
550 44         65 foreach my $name (qw( minute hour dom month dow )) {
551 199         287 $self->_attr($name, $self->make_valid_set($name, $entry[$i]));
552 190         187 ++$i;
553             }
554 35         69 my @dom_list = $self->dom->list;
555 35         223 my @dow_list = $self->dow->list;
556 35         143 my $dom_range = $self->range('dom');
557 35         53 my $dow_range = $self->range('dow');
558 35 100 100     184 $self->dom_squelch(scalar @dom_list == scalar @$dom_range &&
559             scalar @dow_list != scalar @$dow_range ? 1 : 0);
560 35 100 100     165 $self->dow_squelch(scalar @dow_list == scalar @$dow_range &&
561             scalar @dom_list != scalar @$dom_range ? 1 : 0);
562 35 100       50 unless ($self->dom_squelch) {
563 29         44 my @doms = $self->dom->list;
564 29         143 my $pass = 0;
565 29         63 MONTH: foreach my $month ($self->month->list) {
566 33         115 foreach (@doms) {
567 33 100 50     138 ++$pass && last MONTH if $_ <= $Month_Max[$month - 1];
568             }
569             }
570 29 100       234 croak "Impossible last day for provided months.\n" unless $pass;
571             }
572 33         90 $self;
573             }
574              
575             # Field range queries
576             sub range {
577 269     269   201 my($self, $name) = @_;
578 269 50       304 my $val = $self->_range->{$name} or croak "Unknown field '$name'\n";
579 269         254 $val;
580             }
581              
582             # Perform sanity checks when setting up each field set.
583             sub make_valid_set {
584 199     199   209 my($self, $name, $str) = @_;
585 199         239 my $range = $self->range($name);
586 199         265 my $set = $self->make_set($str, $range);
587 199         305 my @list = $set->list;
588 199 100       1146 croak "Malformed cron field '$str'\n" unless @list;
589 197 100       782 croak "Field value ($list[-1]) out of range ($range->[0]-$range->[-1])\n"
590             if $list[-1] > $range->[-1];
591 192 100 100     413 if ($name eq 'dow' && $set->contains(0)) {
592 3         18 shift(@list);
593 3 50       12 push(@list, 7) unless $set->contains(7);
594 3         23 $set = $self->make_set(join(',',@list), $range);
595             }
596 192 100       616 croak "Field value ($list[0]) out of range ($range->[0]-$range->[-1])\n"
597             if $list[0] < $range->[0];
598 190         341 $set;
599             }
600              
601             # No sanity checks
602 202     202   140 sub make_set { shift; DateTime::Event::Cron::OrderedSet->new(@_) }
  202         303  
603              
604             # Flags for when dom/dow are applied.
605 1902     1902   2188 sub dom_squelch { shift->_attr('dom_squelch', @_ ) }
606 1694     1694   1815 sub dow_squelch { shift->_attr('dow_squelch', @_ ) }
607              
608             # Merged logic for dom/dow
609             sub days_contain {
610 1832     1832   1839 my($self, $dom, $dow) = @_;
611 1832 50 33     6110 defined $dom && defined $dow
612             or croak "Day of month and day of week required.\n";
613 1832         2210 my $dom_c = $self->dom->contains($dom);
614 1832         8083 my $dow_c = $self->dow->contains($dow);
615 1832 100       6906 return $dow_c if $self->dom_squelch;
616 1659 100       1811 return $dom_c if $self->dow_squelch;
617 269 100       1118 $dom_c || $dow_c;
618             }
619              
620             # Set Accessors
621 2123     2123   2760 sub minute { shift->_attr('minute' ) }
622 1074     1074   1374 sub hour { shift->_attr('hour' ) }
623 1896     1896   2207 sub dom { shift->_attr('dom' ) }
624 573     573   761 sub month { shift->_attr('month' ) }
625 1867     1867   2007 sub dow { shift->_attr('dow' ) }
626 0     0   0 sub user { shift->_attr('user' ) }
627 0     0   0 sub command { shift->_attr('command') }
628 0     0   0 sub original { shift->_attr('original') }
629              
630             # Accessors/mutators
631 323     323   395 sub _range { shift->_attr('range', @_) }
632              
633             sub _attr {
634 11783     11783   7635 my $self = shift;
635 11783         7735 my $name = shift;
636 11783 100       14189 if (@_) {
637 455         832 $Object_Attributes{$self}{$name} = shift;
638             }
639 11783         29079 $Object_Attributes{$self}{$name};
640             }
641              
642 54     54   181 sub DESTROY { delete $Object_Attributes{shift()} }
643              
644             }
645              
646             ##########
647              
648             {
649              
650             package DateTime::Event::Cron::OrderedSet;
651              
652             # Extends Set::Crontab with some progression logic (next/prev)
653              
654 7     7   36 use strict;
  7         8  
  7         129  
655 7     7   27 use Carp;
  7         7  
  7         311  
656 7     7   25 use base 'Set::Crontab';
  7         8  
  7         2611  
657              
658             my %Object_Attributes;
659              
660             sub new {
661 202     202   152 my $class = shift;
662 202         171 my($string, $range) = @_;
663 202 50 33     666 defined $string && ref $range
664             or croak "Cron field and range ref required.\n";
665 202         431 my $self = Set::Crontab->new($string, $range);
666 202         8437 bless $self, $class;
667 202         377 my @list = $self->list;
668 202         852 my(%next, %prev);
669 202         321 foreach (0 .. $#list) {
670 2498         2577 $next{$list[$_]} = $list[($_+1)%@list];
671 2498         2782 $prev{$list[$_]} = $list[($_-1)%@list];
672             }
673 202         302 $self->_attr('next', \%next);
674 202         265 $self->_attr('previous', \%prev);
675 202         413 $self;
676             }
677              
678             sub next {
679 139     139   129 my($self, $entry) = @_;
680 139         180 my $hash = $self->_attr('next');
681 139 50       243 croak "Missing entry($entry) in set\n" unless exists $hash->{$entry};
682 139         130 my $next = $hash->{$entry};
683 139 50       260 wantarray ? ($next, $next <= $entry) : $next;
684             }
685              
686             sub previous {
687 132     132   132 my($self, $entry) = @_;
688 132         187 my $hash = $self->_attr('previous');
689 132 50       239 croak "Missing entry($entry) in set\n" unless exists $hash->{$entry};
690 132         133 my $prev = $hash->{$entry};
691 132 50       241 wantarray ? ($prev, $prev >= $entry) : $prev;
692             }
693              
694             sub _attr {
695 675     675   486 my $self = shift;
696 675         517 my $name = shift;
697 675 100       902 if (@_) {
698 404         730 $Object_Attributes{$self}{$name} = shift;
699             }
700 675         907 $Object_Attributes{$self}{$name};
701             }
702              
703 202     202   1626 sub DESTROY { delete $Object_Attributes{shift()} }
704              
705             }
706              
707             ###
708              
709             1;
710              
711             __END__
712              
713             =head1 NAME
714              
715             DateTime::Event::Cron - DateTime extension for generating recurrence
716             sets from crontab lines and files.
717              
718             =head1 SYNOPSIS
719              
720             use DateTime::Event::Cron;
721              
722             # check if a date matches (defaults to current time)
723             my $c = DateTime::Event::Cron->new('* 2 * * *');
724             if ($c->match) {
725             # do stuff
726             }
727             if ($c->match($date)) {
728             # do something else for datetime $date
729             }
730              
731             # DateTime::Set construction from crontab line
732             $crontab = '*/3 15 1-10 3,4,5 */2';
733             $set = DateTime::Event::Cron->from_cron($crontab);
734             $iter = $set->iterator(after => DateTime->now);
735             while (1) {
736             my $next = $iter->next;
737             my $now = DateTime->now;
738             sleep(($next->subtract_datetime_absolute($now))->seconds);
739             # do stuff...
740             }
741              
742             # List of DateTime::Set objects from crontab file
743             @sets = DateTime::Event::Cron->from_crontab(file => '/etc/crontab');
744             $now = DateTime->now;
745             print "Now: ", $now->datetime, "\n";
746             foreach (@sets) {
747             my $next = $_->next($now);
748             print $next->datetime, "\n";
749             }
750              
751             # DateTime::Set parameters
752             $crontab = '* * * * *';
753              
754             $now = DateTime->now;
755             %set_parms = ( after => $now );
756             $set = DateTime::Event::Cron->from_cron(cron => $crontab, %set_parms);
757             $dt = $set->next;
758             print "Now: ", $now->datetime, " and next: ", $dt->datetime, "\n";
759              
760             # Spans for DateTime::Set
761             $crontab = '* * * * *';
762             $now = DateTime->now;
763             $now2 = $now->clone;
764             $span = DateTime::Span->from_datetimes(
765             start => $now->add(minutes => 1),
766             end => $now2->add(hours => 1),
767             );
768             %parms = (cron => $crontab, span => $span);
769             $set = DateTime::Event::Cron->from_cron(%parms);
770             # ...do things with the DateTime::Set
771              
772             # Every RTFCT relative to 12am Jan 1st this year
773             $crontab = '7-10 6,12-15 10-28/2 */3 3,4,5';
774             $date = DateTime->now->truncate(to => 'year');
775             $set = DateTime::Event::Cron->from_cron(cron => $crontab, after => $date);
776              
777             # Rather than generating DateTime::Set objects, next/prev
778             # calculations can be made directly:
779              
780             # Every day at 10am, 2pm, and 6pm. Reference date
781             # defaults to DateTime->now.
782             $crontab = '10,14,18 * * * *';
783             $dtc = DateTime::Event::Cron->new_from_cron(cron => $crontab);
784             $next_datetime = $dtc->next;
785             $last_datetime = $dtc->previous;
786             ...
787              
788             # List of DateTime::Event::Cron objects from
789             # crontab file
790             @dtc = DateTime::Event::Cron->new_from_crontab(file => '/etc/crontab');
791              
792             # Full cron lines with user, such as from /etc/crontab
793             # or files in /etc/cron.d, are supported and auto-detected:
794             $crontab = '* * * * * gump /bin/date';
795             $dtc = DateTime::Event::Cron->new(cron => $crontab);
796              
797             # Auto-detection of users is disabled if you explicitly
798             # enable/disable via the user_mode parameter:
799             $dtc = DateTime::Event::Cron->new(cron => $crontab, user_mode => 1);
800             my $user = $dtc->user;
801             my $command = $dtc->command;
802              
803             # Unparsed original cron entry
804             my $original = $dtc->original;
805              
806             =head1 DESCRIPTION
807              
808             DateTime::Event::Cron generated DateTime events or DateTime::Set objects
809             based on crontab-style entries.
810              
811             =head1 METHODS
812              
813             The cron fields are typical crontab-style entries. For more information,
814             see L<crontab(5)> and extensions described in L<Set::Crontab>. The
815             fields can be passed as a single string or as a reference to an array
816             containing each field. Only the first five fields are retained.
817              
818             =head2 DateTime::Set Factories
819              
820             See L<DateTime::Set> for methods provided by Set objects, such as
821             C<next()> and C<previous()>.
822              
823             =over 4
824              
825             =item from_cron($cronline)
826              
827             =item from_cron(cron => $cronline, %parms, %set_parms)
828              
829             Generates a DateTime::Set recurrence for the cron line provided. See
830             new() for details on %parms. Optionally takes parameters for
831             DateTime::Set.
832              
833             =item from_crontab(file => $crontab_fh, %parms, %set_parms)
834              
835             Returns a list of DateTime::Set recurrences based on lines from a
836             crontab file. C<$crontab_fh> can be either a filename or filehandle
837             reference. See new() for details on %parm. Optionally takes parameters
838             for DateTime::Set which will be passed along to each set for each line.
839              
840             =item as_set(%set_parms)
841              
842             Generates a DateTime::Set recurrence from an existing
843             DateTime::Event::Cron object.
844              
845             =back
846              
847             =head2 Constructors
848              
849             =over 4
850              
851             =item new_from_cron(cron => $cronstring, %parms)
852              
853             Returns a DateTime::Event::Cron object based on the cron specification.
854             Optional parameters include the boolean 'user_mode' which indicates that
855             the crontab entry includes a username column before the command.
856              
857             =item new_from_crontab(file => $fh, %parms)
858              
859             Returns a list of DateTime::Event::Cron objects based on the lines of a
860             crontab file. C<$fh> can be either a filename or a filehandle reference.
861             Optional parameters include the boolean 'user_mode' as mentioned above.
862              
863             =back
864              
865             =head2 Other methods
866              
867             =over 4
868              
869             =item next()
870              
871             =item next($date)
872              
873             Returns the next valid datetime according to the cron specification.
874             C<$date> defaults to DateTime->now unless provided.
875              
876             =item previous()
877              
878             =item previous($date)
879              
880             Returns the previous valid datetime according to the cron specification.
881             C<$date> defaults to DateTime->now unless provided.
882              
883             =item increment($date)
884              
885             =item decrement($date)
886              
887             Same as C<next()> and C<previous()> except that the provided datetime is
888             modified to the new datetime.
889              
890             =item match($date)
891              
892             Returns whether or not the given datetime (defaults to current time)
893             matches the current cron specification. Dates are truncated to minute
894             resolution.
895              
896             =item valid($date)
897              
898             A more strict version of match(). Returns whether the given datetime is
899             valid under the current cron specification. Cron dates are only accurate
900             to the minute -- datetimes with seconds greater than 0 are invalid by
901             default. (note: never fear, all methods accepting dates will accept
902             invalid dates -- they will simply be rounded to the next nearest valid
903             date in all cases except this particular method)
904              
905             =item command()
906              
907             Returns the command string, if any, from the original crontab entry.
908             Currently no expansion is performed such as resolving environment
909             variables, etc.
910              
911             =item user()
912              
913             Returns the username under which this cron command was to be executed,
914             assuming such a field was present in the original cron entry.
915              
916             =item original()
917              
918             Returns the original, unparsed cron string including any user or
919             command fields.
920              
921             =back
922              
923             =head1 AUTHOR
924              
925             Matthew P. Sisk E<lt>sisk@mojotoad.comE<gt>
926              
927             =head1 COPYRIGHT
928              
929             Copyright (c) 2003 Matthew P. Sisk. All rights reserved. All wrongs
930             revenged. This program is free software; you can distribute it and/or
931             modify it under the same terms as Perl itself.
932              
933             =head1 SEE ALSO
934              
935             DateTime(3), DateTime::Set(3), DateTime::Event::Recurrence(3),
936             DateTime::Event::ICal(3), DateTime::Span(3), Set::Crontab(3), crontab(5)
937              
938             =cut