Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options
 
PerlMonks  

comment on
( [id://3333]=superdoc: print w/replies, xml ) Need Help?? 
#!/usr/bin/perl -w
use strict;
BEGIN{
  $0 = "crond";
  
  require 5;
  use Fcntl;
  use File::Basename;
  use File::Spec;
  use Getopt::Std;
  use POSIX ();
  use Symbol; #Support pre 5.6; they don't auto-vivify on open
  
  $Mail::Sendmail::VERSION = $Mail::Send::VERSION = 0;
  eval 'use Mail::Send';
  eval 'use Mail::Sendmail'  if $@ || ! $Mail::Send::VERSION;
}
my($pid, %EXPLODECACHE, %OPT, $VERSION);
$VERSION = 0.82;

#Get config/options
{
  my @defbug;
  %ENV = (
          CRONDAEMON=>1,                #!-X
          CRONDEBUG =>0,                #!-x
          CRONEMBED =>0,                #!-O
          CRONLOG   =>'/var/log/cron/', # -L
          CRONMAIL  =>1,                #!-M; extend this to MAILTO?!
          CRONONCE  =>0,                #!-1
          CRONSERIAL=>0,                #!-s
          CRONSOGGY =>0,                #!-S
          CRONUNSAFE=>0,                #!-U
          HOME      =>'/',
          LOGNAME   =>'',
          MAILTO    =>'',
          PATH      =>$ENV{PATH},
          SHELL     =>'/bin/sh'
         );
  if( -r '/etc/default/cron' && open(DEFAULT, '/etc/default/cron') ){
    my(%default, %verboseOPT);
    %verboseOPT = (
                   CRONDAEMON=>'X',
                   CRONDEBUG =>'x',
                   CRONEMBED =>'O',
                   CRONLOG   =>'L',
                   CRONMAIL  =>'M',
                   CRONONCE  =>'1',
                   CRONSERIAL=>'s',
#UPDATE: Oops forgot this.
                   CRONSOGGY =>'S',
                   CRONUNSAFE=>'U'
                  );
    while(<DEFAULT>){
      chomp();
      next if /^\s*(?:\#|$)/;
      if( /^\s*([^\s]*?)\s*=\s*(.*)/ ){
        push(@defbug, "DEBUG2 (Setting envar $1 => $2) ");
        $default{uc($1)} = $2; next;
      }
    }
    %ENV = (%ENV, %default);
    foreach my $var ( grep {/^CRON/ } keys %ENV ){
      $ENV{$var} = 1 if lc($ENV{$var}) eq 'yes';
      $ENV{$var} = 0 if lc($ENV{$var}) eq 'no';
      $OPT{$verboseOPT{$var}} = delete($ENV{$var});
    }
  }
  getopts('1f:hsx:F:L:MOSUX', \%OPT);
  if( $OPT{h} || scalar @ARGV ){
    die("Usage: $0 [-1MOSUXhs] [-F file] [-L dir] [-f file] [-x debugf
+lag]\n");
  }
  $OPT{s}   = $OPT{X} ? 1 : ($OPT{s} || 0);
  #XXX -s could imply -U but for perhaps allowing group changing?!
  #       multiple levels of U? 1 is all 2 is except groups?
  debug(@defbug) if $OPT{x} & 2 && @defbug;
  if( $OPT{S} ){
    eval "use File::Temp ':POSIX'";
    if( $@ && $OPT{O} ){
      *tmpnam = *POSIX::tmpnam;
    }
    else{
      #XXX set security based on $]
      #File::Temp->safe_level( File::Temp::HIGH() );
    }
  }
  if( $OPT{x} & 1 ){
    eval 'use Data::Dumper';
    debug("DEBUG (%OPT = %{\n", Dumper(\%OPT), "})");
  }
}


#Be a good little daemon
{
  $OPT{f} = File::Spec->rel2abs($OPT{f}) if $OPT{f};
  $OPT{F} = File::Spec->rel2abs($OPT{F}) if $OPT{F};
  chdir(File::Spec->rootdir) || die("Couldn't chdir to ROOT directory:
+ $!\n");
  if( $OPT{X} ){
    debug("STARTED (no fork)");
  }
  else{
    unless( defined($pid = fork()) ){
      die("Couldn't fork: $!\n");
    }
    exit 0 if $pid;
    POSIX::setsid();
    debug("STARTED (fork ok)");
    open(STDIN,  '<'. File::Spec->devnull) ||
      die("Can't read from NULL device: $!\n");
    open(STDOUT, '>'. File::Spec->devnull) unless $OPT{L} eq '-' ||
      die("Can't write from NULL device: $!\n");
  }
}



#Set us up the bomb (read configuration)
my(@PJOBS, @TABOPT, %TABMTIME);
LOAD: {
  my($crontabindex, @crontabs, @crontabpaths, @groups);
  $crontabindex =0;
  #This is to prevent memory leaks
  %EXPLODECACHE = @PJOBS = @TABOPT = ();

  unless( $OPT{U} ){
    while( my @F = getgrent() ){ push @groups, [@F] }; endgrent();
  }
  
  if( $OPT{f} || $OPT{F} ){
    push(@crontabpaths, [0, $OPT{f}]) if $OPT{f};    #-f
    push(@crontabpaths, [1, $OPT{F}]) if $OPT{F};    #-F
  }
  else{
    #                [user(0=none, 1=6th field, 2=filename), file]
    @crontabpaths = (
                     [1, '/etc/crontab'],            #System crontab
                     [1, '/etc/cron.d'],             #System crontabs
                     [2, '/var/spool/cron'],         #User   crontabs
                     [2, '/var/spool/cron/crontabs'] # "        "     
+on Sun
                    );
  }
  foreach my $crontabpath ( @crontabpaths ){
    stat $crontabpath->[1];
    if( -d _ && opendir(CRONTABPATH, $crontabpath->[1]) ){
      push(@crontabs,
           map([$crontabpath->[0], File::Spec->catfile($crontabpath->[
+1], $_)],
               grep {!/^\./} readdir(CRONTABPATH) ) );
      closedir(CRONTABPATH);
    }
    elsif( -e _ ){
      push(@crontabs, $crontabpath);
    }
    else{
      next;
    }
    $TABMTIME{$crontabpath->[1]} = -M _;
  }
  
  foreach my $tab ( @crontabs ){
    local %ENV = %ENV;
    open(TAB, $tab->[1]) || carp("WARN (Couldn't open $tab->[1]: $!)")
+ && next;
    debug("DEBUG2 (Reading '$tab->[1]')") if $OPT{x} & 2;
    while( <TAB> ){
      local $ENV{USER};
      chomp();
      next if /^\s*(?:\#|$)/;
      if( /^\s*([^\s]*?)\s*=\s*(.*)/ ){
        debug("DEBUG2 (Setting envar $1 => $2)") if $OPT{x} & 2;
        $ENV{uc($1)} = $2; next;
      }
      my @fields = split(/\s+/);
      debug("DEBUG2 (", join(',', @fields), ")") if $OPT{x} & 2;
      if( $tab->[0] == 1){
        $ENV{USER} = splice(@fields,5,1);
      }
      elsif( $tab->[0] == 2 ){
        my $user = basename($tab->[1]);
        next unless getpwnam($user);
        $ENV{USER} = $user;
      }
      $ENV{USER}  ||= $OPT{U} ? 'undef' : scalar getpwuid($<);
      $ENV{UID}   ||= $OPT{U} ? $<      : scalar getpwnam($ENV{USER}) 
+|| $<;
      if( exists($ENV{MAILTO}) && ! defined($ENV{MAILTO}) ){
        delete($ENV{MAILTO});
      }
      else{
        $ENV{MAILTO} ||= $ENV{USER};
      }
        unless( $OPT{U} ){
        $ENV{GID} = join(':', map($_->[2],
                                grep($_->[3] =~ /\b$ENV{USER}\b/,@grou
+ps) ) )||
                  [grep(lc($_->[0]) eq lc($ENV{USER}), @groups)]->[0]-
+>[2];
        }
      else{
        $ENV{GID} = $(;
      }
      $ENV{LOGNAME} = $ENV{USER};
      $ENV{HOME} ||= $OPT{U} ? File::Spec->rootdir : (getpwnam($ENV{US
+ER}))[7];
      push(@PJOBS, [splice(@fields,0,5),
                    [$crontabindex, {
                                     GID     => delete($ENV{GID}),
                                     UID     => delete($ENV{UID}),
                                     HOME    => delete($ENV{HOME}),
                                     USER    => delete($ENV{USER}),
                                     MAILTO  => delete($ENV{MAILTO}),
                                     LOGNAME => delete($ENV{LOGNAME}) 
+},
                     join(' ', @fields)]]);
      debug("DEBUG2 (Saving job CMD(@fields))") if $OPT{x} & 2;
    }
    close(TAB);
    #XXX debug statement instantiates the key, gets us an error later.
+..
    delete $ENV{USER};
    $TABOPT[$crontabindex++] = \%ENV;
  }
}


#Create EXPLODECACHE
{
  my %verbosetime = (SUN=>0, MON=>1, TUE=>2, WED=>3, THU=>4, FRI=>5, S
+AT=>6,
                     JAN=>1, FEB=>2, MAR=>3, APR=>4, MAY=>5, JUN=>6, J
+UL=>7,
                     AUG=>8, SEP=>9, OCT=>10,NOV=>11,DEC=>12);
  sub explode{
    my @exploded;
    return $EXPLODECACHE{$_[0]} if exists $EXPLODECACHE{$_[0]};
    
    foreach ( split(/,/, $_[0]) ){
      if( m%\*/(\d+)% ){
        for(my $i=0; $i<60; $i+=$1){ push(@exploded, $i); }
      }
      elsif( /-/ ){
        my($i, $j, $k) = ($_ =~ m%(\d+)-(\d+)(?:/(\d+))?% );
        $i = $verbosetime{uc($i)} || $i;
        $j = $verbosetime{uc($j)} || $j;
        $k ||= 1;
        for(; $i<=$j; $i+=$k){ push(@exploded, $i); }
      }
      else{
        push(@exploded, $verbosetime{uc()} || $_);
      }
    }
    $EXPLODECACHE{$_[0]} = [@exploded];
  }
  foreach my $job (@PJOBS){
    do { explode($job->[$_]); } for (0..4);
  }
}
  
    
#AD INFINITUM
while(1){
  debug("DEBUG1 (I'm alive and checking)") if $OPT{x} & 1;
  
  my @time = localtime(time());
  foreach my $job (@PJOBS){
    my $pid;
    debug("DEBUG4 (",
          "($job->[0] eq '*' || $job->[0] == $time[1]) &&",
          "($job->[1] eq '*' || $job->[1] == $time[2]) &&",
          "($job->[2] eq '*' || $job->[2] == $time[3]) && (",
          "($job->[4] eq '*' || $job->[4] == $time[6]) ||",
          "($job->[3] eq '*' || $job->[3] == $time[4]) ) )") if $OPT{x
+} & 4;
    next unless  $job->[0] eq '*' || grep($_ == $time[1],
                                          @{$EXPLODECACHE{$job->[0]}} 
+);
    next unless  $job->[1] eq '*' || grep($_ == $time[2],
                                          @{$EXPLODECACHE{$job->[1]}} 
+);
    next unless  $job->[2] eq '*' || grep($_ == $time[3],
                                          @{$EXPLODECACHE{$job->[2]}} 
+);
    next unless ($job->[4] eq '*' || grep($_ == $time[6],
                                          @{$EXPLODECACHE{$job->[4]}} 
+) ) ||
                ($job->[3] eq '*' || grep($_ == $time[4],
                                          @{$EXPLODECACHE{$job->[3]}} 
+) );

    next if $job->[5]->[2] =~ /^#/ && ! $OPT{O}; #Save the forks!
    
    debug("DEBUG4 (Got a job)") if $OPT{x} & 4;
    if( $OPT{s} ){
      job($job->[5]);
    }
    else{
      unless( defined($pid = fork()) ){
        #Really a croak but can't be fatal; since we're the grandparen
+t
        carp("DIE (Couldn't fork: $!)");
        next;
      }
      job($job->[5]) unless $pid;
    }
  }
  $OPT{1} && exit 0;
    
  #XXXsleep 60;
  #XXXdo{ $kid= waitpid(-1, POSIX::WNOHANG()); } until -1 == $kid;
  for(my $i=0; $i<12; $i++){
    sleep 5;
    while( waitpid(-1, POSIX::WNOHANG()) != -1 ){}
  }
  foreach (keys %TABMTIME){
    goto LOAD if $TABMTIME{$_} != (-M $_ || 0);
  }
}

sub carp{
  warn(@_) if $OPT{X} && $OPT{L} ne '-';
  l0g('warnings', 'CARP (', @_, ')');
}

sub croak{
  warn(@_) if $OPT{X} && $OPT{L} ne '-';
  l0g('errors', 'CROAK (', @_, ')');
  exit 0 unless $OPT{s};
}

sub debug{
  l0g('info', @_);
}

sub job{
  my($FRMCHLD, $chldinput, $chldoutput, $return, $CHLDSTDIN, $TOCHLD);
  $return = "undef";

  #Don't kill hashes in perl jobs
  if( $_[0]->[2] !~ /^#/ && $_[0]->[2] =~ /([^%]+)%(.*)/ ){
    return croak("Embedded newlines (%) not allowed with -S") if $OPT{
+S};
    $_[0]->[2] = $1;
    $chldinput = $2;
    $chldinput =~ s/(.)%/ $1 eq "\\" ? '%' : "$1\n" /eg;
    pipe($CHLDSTDIN=gensym(), $TOCHLD=gensym()) ||
      croak("Couldn't create pipe: $!");
  }

  %ENV = (%{$TABOPT[$_[0]->[0]]}, %{$_[0]->[1]});
  if( $OPT{S} ){
    open(STDERR, ">&STDOUT");
    if( $OPT{O} && $_[0]->[2] =~ /#!perl\s+-e\s+(.*)/ ){
        local $/ = undef;
        my $TMP = gensym();
        my $tmpfile = tmpnam();
        open($TMP, "+>$tmpfile");
        my $oldout = select($TMP);
        $0 = "perl -e $1";
        {
          local *STDOUT = $TMP;
          local *STDERR = $TMP;
          local $SIG{__WARN__} = sub{print STDERR @_};
          eval($1);
        }
        select($oldout);
        if($@){
          return croak("Failed (with $@) evaluting\n$1");
        }
        seek($TMP,0,0);
        $chldoutput = join('', <$TMP>);
        close($TMP);
        unlink($tmpfile);
    }
    else{
      $chldoutput = qx($_[0]->[2]);
    }
  }
  else{
    my $pid = 0 || open($FRMCHLD=gensym(), "-|");
    #XXX Michael Schwern of p5p reports former doesn;t work on VMS in 
+5.7.2
    #|| open($FRMCHLD=gensym(), "-|", 'perl bug') ;#?!
    unless( defined($pid) ){
      croak("Couldn't fork: $!");
      return -1;
    }
    if( $pid ){
      $0 = uc($0) . "($pid) ";
      $ENV{USER} = $_[0]->[1]->{USER};
      if( defined($chldinput) ){
        #close($CHLDSTDIN); #XXX gives SIGPIPE
        print $TOCHLD $chldinput;
        close($TOCHLD);
      }
      $chldoutput = join('', <$FRMCHLD>);
      $return = close($FRMCHLD);
    }
    else{
      my $gid;
      if( defined($chldinput) ){
        close($TOCHLD);
        my $fileno = fileno($CHLDSTDIN);
        open(STDIN, "<&$fileno");
      }
      open(STDERR, ">&STDOUT");

      unless( $< || $OPT{U} ){
        $gid = $ENV{GID};
        $gid =~ tr/:/ /;
        $gid = $gid =~ / / ? $gid : "$gid $gid";
        $( = $) = $gid;
        $< = $> = $ENV{UID};
        sub list{
          my $prev = 'NaN';
          return join(',', grep($_ ne $prev && (($prev) = $_),
                                sort split($_[0], $_[1] )));
        };
        croak("DIE (Couldn't setregid($(, $gid): $!)") unless
          ($( eq $)) && list(' ', $() eq list(':', $ENV{GID});
        croak("DIE (Couldn't setreuid($<, $ENV{UID}): $!") unless
          ($< == $>) && ($> == $ENV{UID});
      }
      $ENV{PATH} = delete($ENV{SUPATH}) unless $< && ! exists($ENV{SUP
+ATH});

      if( $OPT{O} && $_[0]->[2] =~ /#!perl\s+-e\s+(.*)/ ){
        $0 = "perl -e $1";
        eval $1;
      }
      else{
        exec($_[0]->[2]);
      }
      exit();
    }
  }
  debug("CMD ($_[0]->[2])[$return]");
  debug("DEBUG8 (\n", $chldoutput, ")") if $OPT{x} & 8;
  mail($ENV{MAILTO}, $chldoutput) if $ENV{MAILTO} && $chldoutput;
  if( $OPT{s} ){
    $0 = "crond";
    return 0;
  }
  else{
    exit 0;
  }
}

sub l0g{
  return unless $OPT{L};

  my $log = shift();
  open(LOG, $OPT{L} eq '-' ? '>-' : ">>$OPT{L}/$log" ) || return;
  #Can't rely on LOCK_EX being 2 for cross-platform
  flock(LOG, Fcntl::LOCK_EX()) unless $OPT{L} eq '-';
  print LOG scalar localtime(time()), " $0\[$$\]: (", $ENV{USER}||$<,"
+) @_\n";
  close(LOG) unless $OPT{L} eq '-';
}

sub mail{
  return if $OPT{M};
  my @x_cron_env;
  foreach my $key ( keys %ENV ){
    push @x_cron_env, "<$key=$ENV{$key}>";
  }
  if( $Mail::Send::VERSION ){
    my($msg, $fh);
    $msg = new Mail::Send;
    $msg->to($_[0]);
    $msg->subject($0);
    $msg->set('X-Cron-Env', @x_cron_env);
    $fh = $msg->open;
    print $fh $_[1];
    $fh->close;
  }
  elsif( $Mail::Sendmail::VERSION ){
    my(%mail, $host);
#XXXbe smarter later...
    $host = $mail{smtp} = 'localhost';
    %mail = (
             %mail,
             From => "$ENV{USER}\@$host",
             To => $_[0] =~ /@/ ? $_[0] : "$_[0]\@$host",
             Subject => $0,
             Message => $_[1],
             "X-Cron-Env" => join(',', @x_cron_env),
            );
    #Damn strict vars, maybe this gets optimized out
    $Mail::Sendmail::mailcfg = $Mail::Sendmail::mailcfg;
    $Mail::Sendmail::mailcfg{mime} = 0;
    Mail::Sendmail::sendmail(%mail);
  }
  else{
    open(MAIL, "|/bin/mail -s \"@{[quotemeta($0)]}\" $_[0]")
      || carp("WARN (Couldn't mail $_[0])(\n$_[1]\n)");
    print MAIL join("\n", map("X-Cron-Env: $_", @x_cron_env)), "\n";
    print MAIL $_[1];
    close(MAIL);
  }
}

[download]

In reply to a cron; in perl: Source by belg4mit
in thread a cron; in perl by belg4mit

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
    • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Domain Nodelet?

    www.com | www.net | www.org
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? • Last hour • Other CB clients
    Other Users?
    Others having a coffee break in the Monastery: (3)
    As of 2025-06-24 19:54 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      No recent polls found
      Notices?
      • erzuuli‥ Anonymous Monks are no longer allowed to use Super Search, due to an excessive use of this resource by robots.