]> scm.dxcluster.org Git - spider.git/blob - perl/DXCron.pm
d2e434bcbbd5bc1d1a4555ec7dd101e0d3d729a3
[spider.git] / perl / DXCron.pm
1 #
2 # module to timed tasks
3 #
4 # Copyright (c) 1998 - Dirk Koopman G1TLH
5 #
6 # $Id$
7 #
8
9 package DXCron;
10
11 use DXVars;
12 use DXUtil;
13 use DXM;
14 use DXDebug;
15 use IO::File;
16 use Carp;
17
18 use strict;
19
20 use vars qw{@crontab $mtime $lasttime $lastmin};
21
22 @crontab = ();
23 $mtime = 0;
24 $lasttime = 0;
25 $lastmin = 0;
26
27
28 my $fn = "$main::cmd/crontab";
29 my $localfn = "$main::localcmd/crontab";
30
31 # cron initialisation / reading in cronjobs
32 sub init
33 {
34         if ((-e $localfn && -M $localfn < $mtime) || (-e $fn && -M $fn < $mtime) || $mtime == 0) {
35                 my $t;
36                 
37                 @crontab = ();
38                 
39                 # first read in the standard one
40                 if (-e $fn) {
41                         $t = -M $fn;
42                         
43                         cread($fn);
44                         $mtime = $t if  !$mtime || $t <= $mtime;
45                 }
46
47                 # then read in any local ones
48                 if (-e $localfn) {
49                         $t = -M $localfn;
50                         
51                         cread($localfn);
52                         $mtime = $t if $t <= $mtime;
53                 }
54         }
55 }
56
57 # read in a cron file
58 sub cread
59 {
60         my $fn = shift;
61         my $fh = new IO::File;
62         my $line = 0;
63
64         dbg('cron', "cron: reading $fn\n");
65         open($fh, $fn) or confess("cron: can't open $fn $!");
66         while (<$fh>) {
67                 $line++;
68                 chomp;
69                 next if /^\s*#/o or /^\s*$/o;
70                 my ($min, $hour, $mday, $month, $wday, $cmd) = /^\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(.+)$/o;
71                 next if !$min;
72                 my $ref = bless {};
73                 my $err;
74                 
75                 $err |= parse($ref, 'min', $min, 0, 60);
76                 $err |= parse($ref, 'hour', $hour, 0, 23);
77                 $err |= parse($ref, 'mday', $mday, 1, 31);
78                 $err |= parse($ref, 'month', $month, 1, 12, "jan", "feb", "mar", "apr", "may", "jun", "jul", "aug", "sep", "oct", "nov", "dec");
79                 $err |= parse($ref, 'wday', $wday, 0, 6, "sun", "mon", "tue", "wed", "thu", "fri", "sat");
80                 if (!$err) {
81                         $ref->{cmd} = $cmd;
82                         push @crontab, $ref;
83                         dbg('cron', "cron: adding $_\n");
84                 } else {
85                         dbg('cron', "cron: error on line $line '$_'\n");
86                 }
87         }
88         close($fh);
89 }
90
91 sub parse
92 {
93         my $ref = shift;
94         my $sort = shift;
95         my $val = shift;
96         my $low = shift;
97         my $high = shift;
98         my @req;
99
100         # handle '*' values
101         if ($val eq '*') {
102                 $ref->{$sort} = 0;
103                 return 0;
104         }
105
106         # handle comma delimited values
107         my @comma = split /,/o, $val;
108         for (@comma) {
109                 my @minus = split /-/o;
110                 if (@minus == 2) {
111                         return 1 if $minus[0] < $low || $minus[0] > $high;
112                         return 1 if $minus[1] < $low || $minus[1] > $high;
113                         my $i;
114                         for ($i = $minus[0]; $i <= $minus[1]; ++$i) {
115                                 push @req, 0 + $i; 
116                         }
117                 } else {
118                         return 1 if $_ < $low || $_ > $high;
119                         push @req, 0 + $_;
120                 }
121         }
122         $ref->{$sort} = \@req;
123         
124         return 0;
125 }
126
127 # process the cronjobs
128 sub process
129 {
130         my $now = $main::systime;
131         return if $now-$lasttime < 1;
132         
133         my ($sec, $min, $hour, $mday, $mon, $wday) = (gmtime($now))[0,1,2,3,4,6];
134
135         # are we at a minute boundary?
136         if ($min != $lastmin) {
137                 
138                 # read in any changes if the modification time has changed
139                 init();
140
141                 $mon += 1;       # months otherwise go 0-11
142                 my $cron;
143                 foreach $cron (@crontab) {
144                         if ((!$cron->{min} || grep $_ eq $min, @{$cron->{min}}) &&
145                                 (!$cron->{hour} || grep $_ eq $hour, @{$cron->{hour}}) &&
146                                 (!$cron->{mday} || grep $_ eq $mday, @{$cron->{mday}}) &&
147                                 (!$cron->{mon} || grep $_ eq $mon, @{$cron->{mon}}) &&
148                                 (!$cron->{wday} || grep $_ eq $wday, @{$cron->{wday}})  ){
149                                 
150                                 if ($cron->{cmd}) {
151                                         dbg('cron', "cron: $min $hour $mday $mon $wday -> doing '$cron->{cmd}'");
152                                         eval "$cron->{cmd}";
153                                         dbg('cron', "cron: cmd error $@") if $@;
154                                 }
155                         }
156                 }
157         }
158
159         # remember when we are now
160         $lasttime = $now;
161         $lastmin = $min;
162 }
163
164
165 # these are simple stub functions to make connecting easy in DXCron contexts
166 #
167
168 # is it locally connected?
169 sub connected
170 {
171         my $call = uc shift;
172         return DXChannel->get($call);
173 }
174
175 # is it remotely connected anywhere (with exact callsign)?
176 sub present
177 {
178         my $call = uc shift;
179         return DXCluster->get_exact($call);
180 }
181
182 # is it remotely connected anywhere (ignoring SSIDS)?
183 sub presentish
184 {
185         my $call = uc shift;
186         return DXCluster->get($call);
187 }
188
189 # is it remotely connected anywhere (with exact callsign) and on node?
190 sub present_on
191 {
192         my $call = uc shift;
193         my $node = uc shift;
194         my $ref = DXCluster->get_exact($call);
195         return ($ref && $ref->mynode) ? $ref->mynode->call eq $node : undef;
196 }
197
198 # is it remotely connected anywhere (ignoring SSIDS) and on node?
199 sub presentish_on
200 {
201         my $call = uc shift;
202         my $node = uc shift;
203         my $ref = DXCluster->get($call);
204         return ($ref && $ref->mynode) ? $ref->mynode->call eq $node : undef;
205 }
206
207 # last time this thing was connected
208 sub last_connect
209 {
210         my $call = uc shift;
211         return $main::systime if DXChannel->get($call);
212         my $user = DXUser->get($call);
213         return $user ? $user->lastin : 0;
214 }
215
216 # disconnect a locally connected thing
217 sub disconnect
218 {
219         my $call = uc shift;
220         my $dxchan = DXChannel->get($call);
221         if ($dxchan) {
222                 if ($dxchan->is_ak1a) {
223                         $dxchan->send_now("D", DXProt::pc39($main::mycall, "$main::mycall DXCron"));
224                 } else {
225                         $dxchan->send_now('D', "");
226                 } 
227                 $dxchan->disconnect;
228         }
229 }
230
231 # start a connect process off
232 sub start_connect
233 {
234         my $call = uc shift;
235         my $lccall = lc $call;
236
237         if (grep {$_->{call} eq $call} @main::outstanding_connects) {
238                 dbg('cron', "Connect not started, outstanding connect to $call");
239                 return;
240         }
241         
242         my $prog = "$main::root/local/client.pl";
243         $prog = "$main::root/perl/client.pl" if ! -e $prog;
244         
245         my $pid = fork();
246         if (defined $pid) {
247                 if (!$pid) {
248                         # in child, unset warnings, disable debugging and general clean up from us
249                         $^W = 0;
250                         eval "{ package DB; sub DB {} }";
251                         $SIG{HUP} = 'IGNORE';
252                         alarm(0);
253                         DXChannel::closeall();
254                         $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = $SIG{__WARN__} = 'DEFAULT';
255                         exec $prog, $call, 'connect' or dbg('cron', "exec '$prog' failed $!");
256                 }
257                 dbg('cron', "connect to $call started");
258         } else {
259                 dbg('cron', "can't fork for $prog $!");
260         }
261
262         # coordinate
263         sleep(1);
264 }
265
266 # spawn any old job off
267 sub spawn
268 {
269         my $line = shift;
270         
271         my $pid = fork();
272         if (defined $pid) {
273                 if (!$pid) {
274                         # in child, unset warnings, disable debugging and general clean up from us
275                         $^W = 0;
276                         eval "{ package DB; sub DB {} }";
277                         $SIG{HUP} = 'IGNORE';
278                         alarm(0);
279                         DXChannel::closeall();
280                         $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = $SIG{__WARN__} = 'DEFAULT';
281                         exec "$line" or dbg('cron', "exec '$line' failed $!");
282                 }
283                 dbg('cron', "spawn of $line started");
284         } else {
285                 dbg('cron', "can't fork for $line $!");
286         }
287
288         # coordinate
289         sleep(1);
290 }
291
292 # do an rcmd to another cluster from the crontab
293 sub rcmd
294 {
295         my $call = uc shift;
296         my $line = shift;
297
298         # can we see it? Is it a node?
299         my $noderef = DXCluster->get_exact($call);
300         return  if !$noderef || !$noderef->pcversion;
301
302         # send it 
303         DXProt::addrcmd($main::mycall, $call, $line);
304 }
305 1;
306 __END__