#!/afs/sipb/project/perldev/p -w

use strict;
use IO::File;
use IO::Pipe;
use POSIX;
use Fcntl ':flock';
use Config;

### kludge: punt old, more-buggy version.

$0 =~ s@.*/@@g;
print "ARGV: $0 @ARGV\n";

exit 90 if (@ARGV > 1);
exit 91 if @ARGV && !($ARGV[0] =~ /^-([yn])$/);
my $REALLY = !@ARGV || ($1 eq 'y');

### find hostname

my $HOST = `hostname`;
$HOST =~ s/\s+//g;

### variables

use vars qw( $BINDIR $DESTDIR );

$BINDIR = '/afs/athena.mit.edu/user/b/e/bert/Thesis/exact';
$DESTDIR = '/afs/zone.mit.edu/user/bert/THESIS_DATA/current';

use vars qw( $return @xterm );

$return = $BINDIR . '/return';
@xterm = qw( xterm -geometry 80x48+0+0 );

use vars qw( $lockfile $queuefile $logfile $stopfile );

$lockfile =  $DESTDIR . '/.lock';
$queuefile = $DESTDIR . '/queue';
$logfile =   $DESTDIR . '/log';

use vars qw( %sig_num );

@sig_num{split(/\s+/, $Config{sig_name})} = split(/\s+/, $Config{sig_num});

use vars qw( $tag $param $global $CHILD );
$CHILD = -1;

chdir($DESTDIR);

### status message etc

sub status (@) {
  my ($state, $tag, @rest) = @_;
  return unless $REALLY;
  my $date = POSIX::strftime('%m/%d %T', localtime);
  my $msg = "$state $tag $HOST --- @rest --- $date\n";
  print $msg;
  my $log = IO::File->new($logfile, 'a')
    or die "Can't open the log file: $!\n$msg\n";
  flock($log, LOCK_EX)
    or die "Can't lock the log file: $!\n$msg\n";  
  print {$log} $msg;
  $log->close;
}

sub mail {
  return unless $REALLY;
  my $sm = IO::Pipe->new->writer('/usr/lib/sendmail bert@mit.edu');
  $sm->print("Subject: " . shift(@_) . "\n\n");
  $sm->print(@_);
  $sm->close;
}

### event and signal handlers

$SIG{'__DIE__'} = sub {
  mail("$HOST -- kaboom!", "ERROR: $0 @ARGV failed!\n@_\n");
  status 'X', $tag, $param;
  exit 80;
};

$SIG{'HUP'} = sub {
  return unless $CHILD;  # if we're in the forked child, *don't* spew
  mail("$HOST -- logout", "I just got logged out!");
  status 'L', $tag, $param;
  kill( ($sig_num{'HUP'} || 1), $CHILD ) if $CHILD > 0;
  exit 10;
};

$SIG{'CHLD'} = sub {
  my $pid;
  #print "reaped child: $pid\n" while ($pid = waitpid(-1,WNOHANG)) > 0;
  1 while (waitpid(-1,WNOHANG) > 0);
};

### get, remove and parse the first line, ensuring atomicity in the process
{
  # get a lock, open the queue
  my $lock = IO::File->new($lockfile, 'w')
    or die "Can't open the lock file: $!\n";
  flock($lock, LOCK_EX)
    or die "Can't lock the lock file: $!\n";

  my $queue = IO::File->new($queuefile, 'r')
    or die "Can't open the old queue file: $!\n";
  # if this were UFS, we could link and keep reading.  but AFS sucks. =(
  my ($common, $line, @rest) = <$queue>;
  defined($common) or die "Queue is broken (no lines)!\n";
  defined($line)   or die "Queue is empty!\n";
  $queue->close;

  if ($REALLY) {
    $queue = IO::File->new($queuefile, 'w')
      or die "Can't create the new queue file: $!\n";
    print {$queue} $common, @rest;
    $queue->close;
  }

  # unlock the files
  flock($lock, LOCK_UN)
    or die "Can't unlock the lock file: $!\n";
  $lock->close;

  # parse data
  chomp $common;
  ($tag, $global) = split(/>\s*/, $common, 2);
  defined($global) or die "Invalid common line: '$common'";
  chomp $line;
  ($tag, $param) = split(/>\s*/, $line, 2);
  defined($param) or die "Invalid line: '$line'";
}

### OK, now run things.

status '+', $tag, $param;

$CHILD = fork;
if ($CHILD < 0) {
  # error
  die "Augh!  Fork failed!  ($!)";

} elsif ($CHILD == 0) {
  # child

  if ($REALLY) {
    exec( @xterm, '-T', $tag,
	  '-e', $return, split(/\s+/, $global), split(/\s+/, $param));
    die "Augh!  Exec failed!  ($!)";

  } else {
    print "(child: sleeping)\n";
    sleep(3);
    print "(child: done)\n";
    exit 0;
  }
}

# parent

{
  local($SIG{'CHLD'});  $SIG{'CHLD'} = '';
  waitpid $CHILD, 0;
}

if ($? == -1) {
  print "bogon status, continuing\n";
} elsif ($?) {
  print "oops, status is ".sprintf("%x",$?)."\n";
  status 'E', $tag, $param;
  exit 0;
}

status '-', $tag, $param;

if ((time - $^T) < 300  &&  $REALLY) {
  exit 1;
} else {
  exit 0;
}