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 FileHandle;
  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 FileHandle;
  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         my $prog = "$main::root/local/client.pl";
 238         $prog = "$main::root/perl/client.pl" if ! -e $prog;
 239
 240         my $pid = fork();
 241         if (defined $pid) {
 242                 if (!$pid) {
 243                         # in child, unset warnings, disable debugging and general clean up from us
 244                         $^W = 0;
 245                         eval "{ package DB; sub DB {} }";
 246                         $SIG{HUP} = 'IGNORE';
 247                         alarm(0);
 248                         DXChannel::closeall();
 249                         $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = $SIG{__WARN__} = 'DEFAULT';
 250                         exec $prog, $call, 'connect' or dbg('cron', "exec '$prog' failed $!");
 251                 }
 252                 dbg('cron', "connect to $call started");
 253         } else {
 254                 dbg('cron', "can't fork for $prog $!");
 255         }
 256
 257         # coordinate
 258         sleep(1);
 259 }
 260
 261 # spawn any old job off
 262 sub spawn
 263 {
 264         my $line = shift;
 265
 266         my $pid = fork();
 267         if (defined $pid) {
 268                 if (!$pid) {
 269                         # in child, unset warnings, disable debugging and general clean up from us
 270                         $^W = 0;
 271                         eval "{ package DB; sub DB {} }";
 272                         $SIG{HUP} = 'IGNORE';
 273                         alarm(0);
 274                         DXChannel::closeall();
 275                         $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = $SIG{__WARN__} = 'DEFAULT';
 276                         exec "$line" or dbg('cron', "exec '$line' failed $!");
 277                 }
 278                 dbg('cron', "spawn of $line started");
 279         } else {
 280                 dbg('cron', "can't fork for $line $!");
 281         }
 282
 283         # coordinate
 284         sleep(1);
 285 }
 286
 287 # do an rcmd to another cluster from the crontab
 288 sub rcmd
 289 {
 290         my $call = uc shift;
 291         my $line = shift;
 292
 293         # can we see it? Is it a node?
 294         my $noderef = DXCluster->get_exact($call);
 295         return  if !$noderef || !$noderef->pcversion;
 296
 297         # send it
 298         DXProt::addrcmd($main::mycall, $call, $line);
 299 }
 300 1;
 301 __END__