File Coverage

blib/lib/Schedule/Match.pm
Criterion Covered Total %
statement 121 127 95.2
branch 45 64 70.3
condition 16 33 48.4
subroutine 11 12 91.6
pod 7 8 87.5
total 200 244 81.9


line stmt bran cond sub pod time code
1             # -*- mode: perl -*-
2             #
3             # $Id: Match.pm,v 1.7 2000/03/28 13:20:01 tai Exp $
4             #
5              
6             package Schedule::Match;
7              
8             =head1 NAME
9              
10             Schedule::Match - Handles and detects clash between pattern-based schedules
11              
12             =head1 SYNOPSIS
13              
14             use Schedule::Match qw(scheck rcheck isleap uthash expand localtime);
15              
16             # hash structure of handled schedule
17             $this = {
18             life => 3600, # how long each execution of schedule lasts (in second)
19             t_mh => '*', # minute of the hour - in crontab(5) format
20             t_hd => '*', # hour of the day - in crontab(5) format
21             t_dw => '*', # day of the week - in crontab(5) format
22             t_dm => '*', # date of the month - in crontab(5) format
23             t_wm => '*', # week of the month - in crontab(5) format
24             t_my => '*', # month of the year - in crontab(5) format
25             t_yt => '*', # year (of the time) - in crontab(5) format
26             t_om => '*', # occurrence in the month - in crontab(5) format
27             };
28              
29             # create hash structure from given time
30             $that = uthash($time, $life);
31              
32             @when = scheck($this, $that, ...); # list clash (duration not considered)
33             @when = rcheck($this, $that, ...); # list clash (duration considered)
34              
35             $bool = isleap($year); # check for leap year
36             @list = expand($expr, \@fill); # expand each crontab(5) expression
37              
38             @time = localtime($time); # feature enhanced localtime(3)
39              
40             =head1 DESCRIPTION
41              
42             This library allows you to manage schedule which has structure
43             similar to crontab(5) format. It offers methods to detect clash
44             between schedules (with or without duration considered), and
45             can also tell when, and how often they clash.
46              
47             From the viewpoint of data structure, one major difference
48             compared to crontab(5) is a concept of duration. Each schedule
49             has its own duration, and clash detection can be done upon that.
50             For more information on data structure, please consult
51             SCHEDULE STRUCTURE section below.
52              
53             All schedules are assumed to be in the same timezone. You will
54             have to align them beforehand if not.
55              
56             Currently available methods are as follows:
57              
58             =over 4
59              
60             =cut
61              
62             require Exporter;
63              
64 9     9   144496 use strict;
  9         31  
  9         343  
65              
66 9     9   105 use Carp;
  9         19  
  9         611  
67 9     9   108059 use Time::Local;
  9         10192  
  9         885  
68              
69 9     9   56 use vars qw(@ISA @EXPORT_OK $VERSION $DEBUG $WILD);
  9         19  
  9         21743  
70              
71             @ISA = qw(Exporter);
72             @EXPORT_OK = qw(scheck rcheck isleap uthash expand localtime $WILD);
73              
74             $VERSION = '0.07';
75              
76             ## Wildcard schedule which matches with any schedule
77             $WILD = {
78             t_mh => '*', t_hd => '*', t_dm => '*', t_my => '*',
79             t_yt => '*', t_dw => '*', t_wm => '*', t_om => '*',
80             };
81              
82             ## Used for debugging
83             $DEBUG = 0;
84              
85             ## Template used to expand schedule pattern
86             my $FILL = {
87             t_mh => [0..59],
88             t_hd => [0..23],
89             t_dm => [1..31],
90             t_my => [0..11],
91             t_yt => [1970..2037],
92             t_dw => [0..6],
93             t_wm => [1..6],
94             t_om => [1..5],
95             };
96              
97             ## Major timespan in seconds
98             my $DSEC = 3600 * 24;
99             my $WSEC = $DSEC * 7;
100             my $MSEC = $DSEC * 31;
101             my $YSEC = $DSEC * 366;
102              
103             =item @when = lcheck($this, $deep, $keep, $init, $last);
104              
105             Returns list of UNIX times which is a time given schedule
106             gets invoked.
107              
108             =cut
109 0     0 1 0 sub lcheck {
110             ;
111             }
112              
113             =item @when = scheck($this, $that, $deep, $keep, $init, $last);
114              
115             Detects clash between given schedules _without_ considering
116             duration. Returns the list of clash time (empty if not).
117             It is safe to assume the list is sorted.
118              
119             Options are:
120              
121             =over 4
122              
123             =item - $deep
124              
125             Sets the "depth" of clash detection. If set to false, it will
126             report only one clash (first one) per day.
127              
128             =item - $keep
129              
130             Sets the maximum number of clashes to detect. Defaults to 1.
131              
132             =item - $init
133              
134             Set the starting time of timespan to do the detection.
135             Defaults to the moment this method is called.
136              
137             =item - $done
138              
139             Set the closing time of timespan to do the detection.
140             Defaults to 3 years after $init.
141              
142             =back
143              
144             =cut
145             sub scheck {
146 10     10 1 52 my $exp0 = shift;
147 10         14 my $exp1 = shift;
148 10         13 my $deep = shift;
149 10   50     31 my $keep = shift || 1;
150 10   66     34 my $init = shift || time;
151 10   66     31 my $last = shift || $init + $YSEC * 5;
152 10         14 my $pack;
153             my $want;
154 0         0 my @keep;
155              
156 10 50       28 print STDERR "[scheck] entered.\n" if $DEBUG;
157              
158             ## Expand and then logically mix schedules.
159             ##
160             ## Note if two schedule logically never overwrap, some
161             ## part of the resulting schedule won't contain anything
162             ## (undef in this case), allowing the code to bailout early.
163 10         15 while (my($key, $val) = each %{$FILL}) {
  90         313  
164 80   50     164 $pack->{$key} = &shrink(&expand($exp0->{$key}, $val),
165             &expand($exp1->{$key}, $val)) || return;
166             }
167              
168             ## Put a mark on wanted t_wm, t_dw, and t_om.
169 10         15 foreach (@{$pack->{t_dw}}) { $want->{t_dw}->{$_} = 1; }
  10         26  
  70         128  
170 10         19 foreach (@{$pack->{t_wm}}) { $want->{t_wm}->{$_} = 1; }
  10         20  
  60         105  
171 10         20 foreach (@{$pack->{t_om}}) { $want->{t_om}->{$_} = 1; }
  10         21  
  50         85  
172              
173             ## Convert hour and minute into second beforehand
174 10         19 foreach (@{$pack->{t_hd}}) { $_ *= 3600; }
  10         35  
  10         31  
175 10         18 foreach (@{$pack->{t_mh}}) { $_ *= 60; }
  10         21  
  10         28  
176              
177             ## Initialize maximum date for each month
178 10         63 my @NMAX = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
179              
180             ##
181             ## Check if there's any valid date in overwrapping part
182             ## of the schedule. It there is one, it means it'll clash
183             ## on that date.
184             ##
185              
186 10         24 my($t_yt, $t_my, $t_dm, $t_hd, $t_mh, $base, $time, @time);
187              
188 10         23 T_YT:
189 10         16 foreach $t_yt (@{$pack->{t_yt}}) {
190              
191             ## Check for leap year to change maximum date of Feburary.
192 10 50       43 $NMAX[1] = &isleap($t_yt) ? 29 : 28;
193              
194 10         23 T_MY:
195 10         15 foreach $t_my (@{$pack->{t_my}}) {
196              
197 16         30 T_DM:
198 16         26 foreach $t_dm (@{$pack->{t_dm}}) {
199             ## Skip if the date is invalid (such as Feb 31).
200 16 50       42 next if $t_dm > $NMAX[$t_my];
201              
202 16         74 $base = timelocal(0, 0, 0, $t_dm, $t_my, $t_yt - 1900);
203              
204 16 50       1151 last T_YT if $last < $base;
205 16 50       40 next T_YT if $base < $init - $YSEC;
206 16 50       38 next T_MY if $base < $init - $MSEC;
207 16 50       33 next T_DM if $base < $init - $DSEC;
208              
209 16         75 @time = &localtime($base);
210              
211             ## If all reverse-calculated entries were marked as
212             ## "WANTED", it means the day is valid (and so really
213             ## clashes).
214 16 50 33     246 next unless ($want->{t_dw}->{$time[6]} &&
      33        
215             $want->{t_wm}->{$time[9]} &&
216             $want->{t_om}->{$time[10]});
217              
218             ## Record time of clash in the day.
219 16         23 foreach $t_hd (@{$pack->{t_hd}}) {
  16         44  
220 16         28 foreach $t_mh (@{$pack->{t_mh}}) {
  16         40  
221             ## Time of the clash
222 16         27 $time = $base + $t_mh + $t_hd;
223              
224 16 50       37 last T_YT if $last < $time;
225 16 50       40 next if $time < $init;
226              
227 16 100       96 last T_YT if push(@keep, $time) >= $keep;
228 6 50       34 next T_DM unless ($deep);
229             }
230             }
231             }
232             }
233             }
234              
235 10 100       169 wantarray ? @keep : $keep[0];
236             }
237              
238             =item $list = rcheck($exp0, $exp1, $deep, $keep, $init, $done);
239              
240             Detects clash between given schedules _with_ duration considered.
241              
242             This is almost compatible with B except that $deep and $keep
243             option does not work as expected (for current implementation). For
244             $deep, it is always set to 1, and for $keep, you would need to
245             specify much larger value (I cannot give the exact number since
246             it depends on how often two schedules clash).
247              
248             =cut
249             sub rcheck {
250 4     4 1 68 my $exp0 = shift;
251 4         7 my $exp1 = shift;
252 4         7 my $deep = shift;
253 4   50     18 my $keep = shift || 1;
254 4   33     34 my $init = shift || time;
255 4   33     50 my $last = shift || $init + $YSEC * 3;
256 4         8 my @keep;
257             my @run0;
258 0         0 my @run1;
259              
260 4 50       11 print STDERR "[rcheck] entered.\n" if $DEBUG;
261              
262             ## Obtain list of starting time for each schedule pattern.
263             ##
264             ## NOTE:
265             ## Since there's no way of knowing how much of the retrieved
266             ## schedule elements overwrap, it is impossible to guarantee
267             ## the minimum number of clashes reported (i.e. $keep).
268 4         16 @run0 = &scheck($WILD, $exp0, 1, $keep, $init - $exp0->{life}, $last);
269 4         18 @run1 = &scheck($WILD, $exp1, 1, $keep, $init - $exp1->{life}, $last);
270              
271             ## Compare each invocation of schedule pattern, to see if there's
272             ## any clash or not.
273             LOOP:
274 4         13 foreach (@run0) {
275 6         11 my $t0 = $_;
276 6         13 my $t1 = $_ + $exp0->{life};
277 6         11 foreach (@run1) {
278 11         15 my $u0 = $_;
279 11         19 my $u1 = $_ + $exp1->{life};
280              
281             ## If there's no overwrapping part, bailout.
282 11 100       28 last if $t1 < $u0;
283 9 100       18 next if $t0 > $u1;
284              
285             ## Record the time of clash and quit if enough was found.
286 6 100 66     43 if ($t0 <= $u0 && $u0 <= $t1) {
    50 33        
287 2 50       10 last LOOP if push(@keep, $u0) >= $keep;
288             }
289             elsif ($u0 <= $t0 && $t0 <= $u1) {
290 4 100       17 last LOOP if push(@keep, $t0) >= $keep;
291             }
292             }
293             }
294              
295 4 100       28 wantarray ? @keep : $keep[0];
296             }
297              
298             =item $bool = isleap($year);
299              
300             Returns wheather given year is leap year or not. Returns true
301             if it is, false otherwise.
302              
303             =cut
304             sub isleap {
305 19 100 66 19 1 138 ($_[0] % 4) == 0 && (($_[0] % 100) != 0 || ($_[0] % 400) == 0);
306             }
307              
308             =item $hash = uthash($time[, $life]);
309              
310             Create schedule structure from given UNIX time. Optionally, you
311             can also set the duration of created schedule (which defaults to 0).
312              
313             =cut
314             sub uthash {
315 1     1 1 6 my $time = shift;
316 1         2 my $life = shift;
317 1         3 my @time = &localtime($time);
318              
319             return {
320 1         11 life => $life, # life (in second)
321             t_mh => $time[1], # minute of the hour
322             t_hd => $time[2], # hour of the day
323             t_dm => $time[3], # day of the month
324             t_my => $time[4], # month of the year
325             t_yt => $time[5] + 1900, # year (of the time)
326             t_dw => $time[6], # date of the week
327             t_wm => $time[9], # week of the month
328             t_om => $time[10], # occurrence in the month
329             };
330             }
331              
332             =item @time = localtime($time);
333              
334             Converts a time as returned by the time function to a 11-element
335             array with the time analyzed for the local time zone.
336              
337             Except for appended 10th and 11th element, this is compatible with
338             built-in B.
339              
340             Appended 2 elements (10th and 11th) are "week of the month" and
341             "occurence in the month", both in 1-indexed style.
342              
343             =cut
344             sub localtime {
345 24     24 1 126 my $time = shift;
346 24         32 my @time;
347              
348 24 100       91 $time = defined($time) ? $time : time;
349              
350 24 100       94 wantarray || return CORE::localtime($time);
351              
352 23         627 @time = CORE::localtime($time);
353 23         172 @time,
354             int(($time[3] + 7 - $time[6] + 6) / 7),
355             int(($time[3] + 6) / 7);
356             }
357              
358             =item @list = expand($expr, \@fill);
359              
360             Function to expand given crontab(5)-like expression to the list
361             of matching values. \@fill is used to expand wildcard.
362              
363             =cut
364             sub expand {
365 167     167 1 258 my $expr = shift;
366 167         178 my $fill = shift;
367 167         410 my @expr = split(m|/|, $expr);
368 167         328 my @list = split(m|,|, $expr[0]);
369 167         188 my @temp;
370             my @last;
371 0         0 my %seen;
372              
373 167 50       346 print STDERR "[expand] \$expr: $expr\n" if $DEBUG;
374              
375             ## Expand pattern, and then sort+uniq the resulting list
376 167         253 foreach (@list) {
377 186 100       749 push(@temp, @$fill) if m|^\*$|;
378 186 100       746 push(@temp, $1) if m|^(\d+)$|;
379 186 100       570 push(@temp, $1..$2) if m|^(\d+)-(\d+)$|;
380             }
381 167         278 @temp = sort { $a <=> $b } grep { ! $seen{$_}++ } @temp;
  2371         3357  
  2076         6338  
382              
383             ## Pick out elements by "skip" value (to handle '*/n' notation)
384 167         284 $expr[1]++;
385 167         419 for (my $i = 0 ; $i <= $#temp ; $i += $expr[1]) {
386 2055         5556 push(@last, $temp[$i]);
387             }
388              
389 167 50       381 if ($DEBUG) {
390 0         0 print STDERR "[expand] \@last: @last\n";
391             }
392 167 50       1763 wantarray ? @last : $last[0];
393             }
394              
395             ##
396             # Function to logically combine two expanded schedule element
397             #
398             sub shrink {
399 80     80 0 148 my %seen;
400 80         118 my @list = grep { $seen{$_}++ } @_;
  2000         3218  
401              
402 80 50       163 if ($DEBUG) {
403 0         0 print STDERR "[shrink] \@list: @list\n";
404             }
405 80 50       823 @list ? \@list : undef;
406             }
407              
408             =back
409              
410             =head1 SCHEDULE STRUCTURE
411              
412             Below is a structure of schedule used in this library:
413              
414             life => duration of the schedule (in second)
415             t_mh => minute of the hour
416             t_hd => hour of the day
417             t_dm => day of the month
418             t_my => month of the year
419             t_yt => year (of the time)
420             t_dw => day of the week
421             t_wm => week of the month
422             t_om => occurrence in the month
423              
424             As you can see, this is a simple hashtable. And for all t_*
425             entries, crontab(5)-like notation is supported. For this
426             notation, please consult crontab(5) manpage.
427              
428             Next goes some examples. To make description short, I stripped
429             the text "Schedule lasting for an hour, starting from midnight"
430             off from each description. Please assume that when reading.
431              
432             =item 1. on every Jan. 1.
433              
434             $schedule = {
435             life => 3600,
436             t_mh => '0',
437             t_hd => '0',
438             t_dm => '1',
439             t_my => '0',
440             t_yt => '*',
441             t_dw => '*',
442             t_wm => '*',
443             t_om => '*',
444             }
445              
446             =item 2. on every 3rd Sunday.
447              
448             $schedule = {
449             life => 3600,
450             t_mh => '0',
451             t_hd => '0',
452             t_dm => '*',
453             t_my => '*',
454             t_yt => '*',
455             t_dw => '0',
456             t_wm => '*',
457             t_om => '3',
458             }
459              
460             =item 3. on Monday of every 3rd week.
461              
462             $schedule = {
463             life => 3600,
464             t_mh => '0',
465             t_hd => '0',
466             t_dm => '*',
467             t_my => '*',
468             t_yt => '*',
469             t_dw => '1',
470             t_wm => '3',
471             t_om => '*',
472             }
473              
474             =item 4. on every other day.
475              
476             $schedule = {
477             life => 3600,
478             t_mh => '0',
479             t_hd => '0',
480             t_dm => '*/1',
481             t_my => '*',
482             t_yt => '*',
483             t_dw => '*',
484             t_wm => '*',
485             t_om => '*',
486             }
487              
488             =item 5. on every other 2 days, from January to May.
489              
490             $schedule = {
491             life => 3600,
492             t_mh => '0',
493             t_hd => '0',
494             t_dm => '*/2',
495             t_my => '0-4',
496             t_yt => '*',
497             t_dw => '*',
498             t_wm => '*',
499             t_om => '*',
500             }
501              
502             =item 6. on the day which is Sunday _and_ the 1st day of the month.
503              
504             $schedule = {
505             life => 3600,
506             t_mh => '0',
507             t_hd => '0',
508             t_dm => '1',
509             t_my => '*',
510             t_yt => '*',
511             t_dw => '0',
512             t_wm => '*',
513             t_om => '*',
514             }
515              
516             =item 7. on Jan. 1, 1999
517              
518             $schedule = {
519             life => 3600,
520             t_mh => '0',
521             t_hd => '0',
522             t_dm => '1',
523             t_my => '0',
524             t_yt => '1999',
525             t_dw => '*',
526             t_wm => '*',
527             t_om => '*',
528             }
529              
530             Got the idea? You need to be careful on how you specify pattern,
531             since it is possible to create pattern which never happens (Say,
532             every Monday of 1st week which is 3rd Monday of the month).
533              
534             Other key-value pair can be in the hash, but there is no gurantee
535             for those entries. It might clash with future enhancements to the
536             strcuture, or it might even be dropped when the internal copy
537             of the structure is made.
538              
539             =head1 BUGS
540              
541             Two potential bugs are currently known:
542              
543             =over 4
544              
545             =item UNIX-Y2K++ bug
546              
547             Due to a feature of localtime(3), this cannot cannot handle year
548             beyond 2038. Since clash-detection code checks for the date in
549             the future, this library is likely to break before that (around
550             2030?).
551              
552             =item Clash detection bug
553              
554             When schedule(s) in question repeat in very short time (like every
555             minute), method rcheck might not be able to check through timespan
556             that is long enough.
557              
558             This can be avoided if you specify HUGE value for $keep, but
559             then things will be so slow, I believe it is not practical.
560              
561             =back
562              
563             =head1 COPYRIGHT
564              
565             Copyright 1999, Taisuke Yamada .
566             All rights reserved.
567              
568             This library is free software; you can redistribute it
569             and/or modify it under the same terms as Perl itself.
570              
571             =cut
572              
573             1;