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__