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