#!/usr/bin/env perl
#
# Small daemon process to update the job state file from DAGMan logs.
# This program is to be run automatically by the pegasus-run command. 
#
# Usage: tailstatd [options] dagoutfile
#
# This file or a portion of this file is licensed under the terms of
# the Globus Toolkit Public License, found in file GTPL, or at
# http://www.globus.org/toolkit/download/license.html. This notice must
# appear in redistributions of this file, with or without modification.
#
# Redistributions of this Software, with or without modification, must
# reproduce the GTPL in: (1) the Software, or (2) the Documentation or
# some other similar material which is provided with the Software (if
# any).
#
# Copyright 1999-2004 University of Chicago and The University of
# Southern California. All rights reserved.
#
# Author: Jens-S. Vöckler voeckler@isi.edu
# Author: Gaurang Mehta gmehta@isi.edu
# Revision : $Revision: 3798 $
#
use 5.006;
use strict;
use subs qw(log);               # replace Perl's math log with logging
use POSIX qw(setsid setpgid);
use Fcntl qw(:DEFAULT :seek);
use File::Spec;
use File::Basename qw(basename dirname);
use Errno qw(:POSIX EINTR EAGAIN ENOENT);
use Getopt::Long qw(:config bundling no_ignore_case);
use Socket;
use Carp;
use DB_File;			# persistent hashes
use Time::HiRes;
use Time::Local;

# load our own local modules
use Pegasus::Common;
use Pegasus::Properties qw(PARSE_ALL);
use Pegasus::Workflow;
use Site::Intent;

# constants
$main::DEBUG = 0;		# for now
my $logbase = 'tailstatd.log'; 	# basename of daemon logfile
%main::brainkeys = ( required => [ qw(basedir vogroup label rundir) ],
		     optional => [ qw(dax dag jsd run pegasushome) ] );

# global variables
$main::start = time();		# start time for total duration
$main::workid = undef;		# workflow ID in workflow database
$main::line = 0;		# line number from DAGMan debug file
$main::stamp = 0;		# time stamp from log file
$main::pid = 0;			# DAGMan's pid -- set later
$main::replay_mode = 0;		# disable checking if DAGMan's pid is gone while running tailstatd
%main::subfn = ();		# all submitfiles of not-DONE jobs
%main::seen = ();		# how often a job was seen
%main::pending = ();		# remember when GLOBUS_SUBMIT was entered
				# jid => [ stamp, addon, wtime, site ]
%main::running = ();		# dito for EXECUTE for hidden starvation
				# jid => [ stamp, addon, wtime, site ]
%main::job_site = ();		# last site a job was planned for
%main::jobstate = ();		# jid => [ stamp, event, addon, wtime, site ]
%main::siteinfo = ();		# site => { [RPSF] => [ #, mtime ] }
%main::walltime = ();		# jid => walltime
%main::waiting = ();		# site => stamp/60 => [ #P->R, sum(ptime) ]

# revision handling
$_ = '$Revision: 3798 $';      # don't edit, automatically updated by CVS
$main::revision=$1 if /Revision:\s+([0-9.]+)/;

# forward declarations
sub usage;			# { }
sub make_boolean($);		# { }

# parse properties -Dkey=value
#warn( "# ", join( "\n# ", @ARGV ), "\n" );
my $props = Pegasus::Properties->new( PARSE_ALL );
my $workdb = undef;
my $doplot = make_boolean( $props->property('pegasus.tailstatd.show') );
my $database=1;
my $fuse = $props->property('pegasus.tailstatd.fuse') || 300;
$fuse = 60 if $fuse < 60;

# remove jobs after xxxx seconds in PENDING
my $idletime = $props->property('pegasus.max.idletime');

my $starvation=defined($idletime) ? $idletime  :0;

my $last_check = time();	# marker for starvation checks
my $jsd;			# location of jobstate.log file
my $nodaemon;			# foreground mode
my $logfile;			# location of tailstatd.log file
my $millisleep;			# emulated run mode delay
my $job_check_interval = 300;	# interval to check for starvation
my $liedetect = $props->property('pegasus.max.runtime.multiplier');
my $liedetector = defined($liedetect)  ? $liedetect : 5.0;		# remove after 5.0 * walltime in RUN

my %config = ();		# braindump database (textual file)
my $adjustment = 0;		# time zone adjustment (@#~! Condor)

GetOptions( "help|h" => \&usage,
	    "debug|d+" => \$main::DEBUG,
	    "adjust|a=i" => \$adjustment, 
	    "job|j=s" => \$jsd,
	    "log|l=s" => \$logfile,
	    "starve|s=i" => \$starvation,
	    "sim|S=i" => \$millisleep,
	    "check|c=i" => \$job_check_interval,
	    "config|C=s" => \%config, 
	    "show" => sub { $doplot=1 },
	    "database!"=>\$database,
	    "fuse=i" => \$fuse,
	    "no-daemon|n" => sub { $nodaemon=1 },
	    "foreground|N" => sub { $nodaemon=2 },
    	    "replay|r" => sub { $main::replay_mode=1 });

# sanity check
$fuse=60 if $fuse < 60;

# remaining argument is .dag.dagman.out file
my $out = shift || usage;
usage unless $out =~ /\.dagman\.out$/; # it'd better be!
$out = File::Spec->rel2abs($out); # turn into abs filename

# infer information from directory contents
my $run = dirname($out);	# infer run directory
if ( (keys %config) > 0 ) {
    # sanity check contents -- need at least for keys
    foreach my $key ( @{$main::brainkeys{required}} ) {
	die "Invalid use of --config option: Missing key $key\n"
	    unless exists $config{$key};
    }
} else {
    %config = slurp_braindb($run) or 
	warn "Warning: open brain db: $!\n";
}

# for slow start 
my $sitefn = $props->property('pegasus.slow.start'); 
my $sitedb = ( $sitefn ? 
	       Site::Intent->new( File::Spec->catfile($run,$sitefn) ) : 
	       undef );

# determine location of textual jobstate log
$jsd = File::Spec->catfile( $run, $Pegasus::Common::jobbase ) 
    unless ( defined $jsd );
my $flags = ( O_WRONLY ); # | O_APPEND );
if ( ! -e $jsd ) {
    warn "Info: Creating new file $jsd\n";
    $flags |= O_CREAT;
}
sysopen( JSDB, $jsd, $flags ) || die "Appending to $jsd: $!";
syswrite( JSDB, "@{[time]} INTERNAL *** TAILSTATD_STARTED ***\n" );
$logfile = File::Spec->catfile( $run, $logbase ) unless ( defined $logfile );
$logfile = File::Spec->rel2abs( $logfile );

# check for rescue DAG presence; determine submit file location
my $dag = basename( $out, '.dagman.out' );
$dag = File::Spec->rel2abs( $dag, $run );
if ( open( DAG, "<$dag" ) ) {
    my $fn;
    while ( <DAG> ) {
	next unless /^\s*job\s/i;
	if ( /JOB\s+(\S+)\s+(\S+)(\s+DONE)?/i ) {
	    # [ name, device#, inode#, size, mtime ]
	    $main::subfn{$1} = [ File::Spec->catfile($run,$2), -1, -1, -1, -1 ]
		if ( length($3)==0 );
	}
    }
    close DAG;			
    $main::subfn = 0 + keys(%main::subfn);
} else {
    warn "ERROR: Unable to read $dag: $!\n";
}
# POST-CONDITION: %main::subfn contains only submit-files of
# jobs that are not yet done. Normally, this is all submit files. 
# In rescue DAGs, that is an arbitrary subset of all jobs. 

# check for condor_rm
my $condor_rm = find_exec('condor_rm') || 
    die "ERROR: Unable to determine where condor_rm is installed\n";

# maintain database of removed Condor jobs (for restarts)
my $rmdb = File::Spec->catfile( $run, 'remove.db' );
if ( $main::replay_mode == 0 ) {
    tie( %main::remove, 'DB_File', $rmdb ) || 
        die "ERROR: Unable to create DB file $rmdb: $!\n";
} else {
    %main::remove = ();
}
END { untie %main::remove if $main::replay_mode == 0;}

#
# --- functions ---------------------------------------------------
#

sub usage {
    my $base = basename($0, '.pl');
    print << "EOF";

Usage: $base [options] workflow.dag.dagman.out

Mandatory arguments:
  outfile   is the log file produced by Condor DAGMan, usually ending in the
            suffix ".dag.dagman.out". 

Optional arguments:
 -h|--help       print this help and exit.
 -d|--debug      accumulative, add more messages as repeated, default level $main::DEBUG
                 dynamic adjustments via signals USR1 (incr) and USR2 (decr).
 -a|--adjust i   adjust for time zone differences by i seconds, default 0.
 -c|--check i    check for starvation every i seconds, default $job_check_interval s
 -s|--starve n   remove job from Condor after n second spent PENDING remotely,
                 use 0 to disable, defaults to $starvation s 
 -N|--foreground (Condor) don\'t daemonize $base; go through motions as if. 
 -n|--no-daemon  (debug) don\'t daemonize $base; keep it in the foreground.
    --show       create diagrams of workflow upon normal exit.
    --fuse sec   maximum wait for each plotting subscript, default $fuse s. 
 -j|--job fn     alternative job state file to write, default is $Pegasus::Common::jobbase
                 in the workflow\'s directory.
 -l|--log fn     alternative $base log file, default is $logbase 
                 in the workflow\'s directory.
 -C|--config k=v defines configurations instead of reading from braindump.txt.
                 Required keys include @{[join(", ",@{$main::brainkeys{required}})]}. 
                 Suggested keys include @{[join(", ",@{$main::brainkeys{optional}})]}. 
 -D| --database  Turn on Database entries for work DB.
 -r| --replay    disables checking for DAGMan\'s pid while running tailstatd.
Developer arguments: 
 -Dprop=val      Overrides for properties, must be initial (multi-option). 
 -S|--sim ms     simulate delays between reads by sleeping ms milliseconds.

Usage of configuration keys:
  The required keys are secondary keys into the wf_work table, used to uniquely
  identify any workflow, past or present. While not enforced, the required keys 
  customarily have the following relation to the optional "run" key: 

  run      /home/voeckler/work/ivdgl1/400x1x7200/run0004
           bbbbbbbbbbbbbbbbbbb gggggg llllllllll rrrrrrr
  basedir  full path to the base of work directories, portion 'b' of "run".
  vogroup  name of the VO group who runs this workflow, portion 'g' of "run".
           while an abitrary string, use your VO name plus a digit, e.g. 1.
  label    DAX label from gendax --label, portion 'l' of "run".
  rundir   instance of the workflow, portion 'r' of "run". 

EOF
    exit(1);
}

sub make_boolean($) {
    # purpose: convert an input string into something boolean
    # paramtr: $x (IN): a property value
    # returns: 0 (false) or 1 (true)
    my $x = shift;
    return 0 unless defined $x;	# undef is false
    $x = lc($x);
    ( $x eq 'true' || $x eq 'on' || $x eq 'yes' || $x > 0 ) ? 1 : 0;
}

sub systell(*) { 
    # purpose: make things symmetric, have a systell for sysseek
    # paramtr: FH (IO): filehandle
    # returns: current file position
    local(*FH) = shift;
    sysseek( FH, 0, SEEK_CUR );
}

sub log {
    # purpose: print whatever onto log stream with timestamp prefix
    # paramtr: any number of more parameters
    # globals: $main::line (IN): line number from DAGMan debug file
    # returns: -
    my @now = Time::HiRes::gettimeofday();
    my @tm = localtime( $now[0] );
    my $prefix = sprintf( "%4d%02d%02dT%02d%02d%02d.%03d [%d]: ",
                          $tm[5]+1900, $tm[4]+1, $tm[3],
                          $tm[2], $tm[1], $tm[0], 
                          $now[1] / 1000, $main::line );
    print $prefix, @_, "\n";
}

sub fatal {
    # purpose: log plus exit with failure
    # paramtr: any number of more parameters
    # returns: does not return 
    $_[0] .= ": $!" if ( $! != 0 );
    log( 'FATAL: ', @_ );
    exit(42);
}

sub assert_work_id($$$$) {
    # purpose: Extract the workflow id, create if it does not exist
    # paramtr: basedir, vogroup, label and rundir
    # returns: workflow id, or undef
    # globals: $workdb, $props
    return undef unless ( defined $workdb && @_ >= 4 );
    my $id = $workdb->work_id( @_ );
    unless ( defined $id ) {
	log( 'Warning: Missing workflow id, creating new entry' );
	$workdb->new_work( @_, scalar getpwuid($>), time, -1 );
	$id = $workdb->work_id( @_ );
    }
    $id;
}

sub infer_from_directory($) {
    # purpose: Extract the knowledge about the workflow from the rundir
    # paramtr: $run (IN): run directory, fully-qualified absolute path
    # returns: the workflow identifier, or undef if not found
    my $run = shift;
    my ($rundir,$workflow,$vogroup) = reverse split /\//, $run;
    substr($run, -(length($vogroup)+length($workflow)+length($rundir)+3) )='';
    #log("basedir=$run, vogroup=$vogroup, workflow=$workflow, rundir=$rundir");

    assert_work_id( $run, $vogroup, $workflow, $rundir );
}

sub infer_from_config(\%) {
    # purpose: Extract the knowledge about the workflow from the rundir
    # paramtr: $run (IN): run directory, fully-qualified absolute path
    # returns: the workflow identifier, or undef if not found
    my $href = shift;
    assert_work_id( $href->{basedir}, $href->{vogroup},
		    $href->{label}, $href->{rundir} );
}

sub out2log($) {
    # purpose: infer output symlink for Condor common user log
    # paramtr: $out (IN): the name of the $out file we use
    # globals: $run (IN): the run directory - hopefully absolute
    # returns: scalar: the name of the log file to use
    #          vector: the log file, and the basename thereof
    my $out = shift;

    # NEW: account for rescue DAGs
    my $base = basename( $out, '.dagman.out' );
    $base =~ s/(?:\.(?:rescue|dag))+$//g;
    $base .= '.log';
    my $log = File::Spec->catfile( $run, $base );

    # perl return
    wantarray ? ($log,$base) : $log;
}

# RSL normalize keys we look for in the submit file
my %good_rsl = ( maxcputime => 1, maxtime => 1, maxwalltime => 1 );
my $site_re = q{^\s*\+(pegasus|wf)_(site|resource)\s*=\s*(['"])?(\S+)\3}; # "'};

sub extract_knowledge($$) {
    # purpose: Extra any walltime and site info from a given submit file
    # paramtr: $stamp (IN): timestamp associated with the log line
    #          $info (IN): [ subfn, dev#, ino#, size, mtime ] reference
    # globals: %good_rsl (IN): which RSL keys constitute time requirements
    # returns: scalar: largest job time requirement in minutes, or undef
    #          vector: [0] like scalar
    #                  [1] destination site, or undef if not found
    my $stamp = shift;
    my $info = shift;
    my ($site,$result);			# defaults to undef

    # sanity check
    return ( wantarray ? (undef,undef) : undef ) unless defined $info;
    my $fn = $info->[0];
    return ( wantarray ? (undef,undef) : undef ) unless $fn;

    # update stat record for submit file
    @{$info}[1,2,3,4] = (stat($fn))[0,1,7,9];
    if ( $stamp < $info->[4] ) {
	log( "stamp=$stamp, mtime=", $info->[4], ", diff=", $info->[4]-$stamp )
	    if ( $main::DEBUG > 1 );
	log( 'skipping ', $fn, ' (reparsing events)' );
	return ( wantarray ? (undef,undef) : undef );
    }

    local(*SUB);
    if ( defined $fn && open( SUB, "<$fn" ) ) {
	my $re = '\(([^)]+)\)';
	while ( <SUB> ) {
	    if ( /^\s*globusrsl\W/i ) {
		# found RSL string, do parse now
		while ( /$re/go ) {
		    my ($k,$v) = split /=/, $1, 2;
		    $k =~ tr/_-//d;
		    $result=$v if ( $good_rsl{lc($k)} && $v > $result );
		}
	    } elsif ( /$site_re/o ) {
		# GVDS agreement
		$site=$4;
	    } elsif ( /^\#!\s+site=(\S+)/ ) {
		# Euryale specific comment
		$site=$1;
	    }
	}
	close SUB;
    } else {
	log( "unable to parse $fn: $!" ) if defined $fn;
    }

    #log( "FOUND site=\"$site\"" );

    wantarray ? ($result,$site) : $result;
}

sub aggregate($$$) {
    # purpose: aggregates pending information into raster intervals. 
    # paramtr: $site (IN): run site
    #          $stamp (IN): current timestamp
    #          $pending (IN): pending record
    # returns: -
    use integer;
    my $site = shift || return undef;
    my $stamp = shift;
    my $pending = shift;

    # rasterize by 1 minute intervals
    my $slot = int( $stamp / 60 );
    my $diff = abs( $stamp - $pending->[0] );

    # FIXME: Insert clean-up code here to remove any but last four slots

    # aggregate information
    $main::waiting{$site}{$slot}[0]++;
    $main::waiting{$site}{$slot}[1]+= $diff;

    if ( $main::DEBUG > 1 ) {
	no integer;
	my $n = $main::waiting{$site}{$slot}[0];
	log( "$site:$slot $diff / $n = ", sprintf("%.3f", $diff / $n ) );
    }
}

# events that constitute a pending job. Event SUBMIT is excluded on purpose,
# because due to throttling inside DAGMan and Condor-G, a locally SUBMITted
# job may only become remotely GLOBUS_SUBMITted as throttles permit. 
my %pending = ( 'GLOBUS_SUBMIT' => 1, 'GRID_SUBMIT' => 1 );

# events that constitute a running job. 
my %running = ( 'EXECUTE' => 1,
		'GLOBUS_RESOURCE_DOWN' => 1, 
		'GLOBUS_RESOURCE_UP' => 1,
		'JOB_SUSPENDED' => 1, 
		'JOB_UNSUSPENDED' => 1 );

# when to scratch remembered site info
my %unsubmitted = ( 'UN_READY' => 1,
		    'PRE_SCRIPT_STARTED' => 1,
		    'PRE_SCRIPT_SUCCESS' => 1,
		    'PRE_SCRIPT_FAILURE' => 1 );

sub add ($$$;$) {
    # purpose: append atomically a line to the jobstate file
    # paramtr: $stamp (IN): time stamp when the state change was seen
    #          $jobid (IN): what job
    #          $event (IN): new status of job
    #          $add (opt. IN): additional data
    # globals: $workdb: (IN): database handler
    #          $main::workid: (IN): workflow ID number, can be undef'd
    # returns: number of bytes written
    my $stamp = shift || die "need a stamp\n";
    my $jobid = shift || die "need a job id\n";
    my $event = shift || die "need an event\n";
    my $addon = shift;

    # remove existing site info during replanning
    if ( $unsubmitted{$event} ) {
	delete $main::job_site{$jobid} if exists $main::job_site{$jobid};
	delete $main::walltime{$jobid} if exists $main::walltime{$jobid};
    }

    # variables originally from submit file information
    my $site = ( exists $main::job_site{$jobid} ? 
		 $main::job_site{$jobid} : undef );
    my $time = ( exists $main::walltime{$jobid} ?
		 $main::walltime{$jobid} : undef );

    # obtain planning information from submit file when entering Condor
    if ( $event eq 'SUBMIT' ) {
	# figure out how long the jobs _intends_ to run maximum
	($time,$site) = extract_knowledge($stamp,$main::subfn{$jobid});
	undef $site if $site eq '!!SITE!!';

	# if defined, convert into seconds
	if ( defined $time ) {
	    $time *= 60;
	    log( 'job ', $jobid, ' requests ', $time, ' s walltime' )
		if $main::DEBUG;
	    $main::walltime{$jobid} = $time;
	} else {
	    log( 'job ', $jobid, ' does not request a walltime' )
		if $main::DEBUG;
	}

	# remember the run-site
	if ( defined $site ) {
	    log( 'job ', $jobid, ' is planned for site ', $site )
		if $main::DEBUG;
	    $main::job_site{$jobid} = $site;
	} else {
	    log( 'job ', $jobid, ' does not have a site information!' );
	}
    }

    # remember when we changed into a pending state
    if ( $pending{$event} ) {
	unless ( exists $main::pending{$jobid} ) {
	    # remember when -- and which Condor ID
	    $main::pending{$jobid} = [ $stamp, $addon, $time, $site ];
	} else {
	    log( $event, ' remains a pending event for ', $jobid )
		if $main::DEBUG > 1;
	}
    } else {
	# remember time spent in pending, if previous state was pending
	aggregate( $site, $stamp, $main::pending{$jobid} )
	    if ( $pending{$main::jobstate{$jobid}->[1]} );

	# remove when transitioning into any other state
	delete $main::pending{$jobid};
    }

    # remember when we changed into a running state
    if ( $running{$event} ) {
	unless ( exists $main::running{$jobid} ) {
	    # remember when -- and which Condor ID
	    $main::running{$jobid} = [ $stamp, $addon, $time, $site ];

	    # increase the window size when in slow start
	    # WARNING: This may be blocking indefinitely!!!
	    if ( defined $sitedb && defined $site &&
		 $main::siteinfo{$site}{$jobid} eq 'P' ) {
		local $SIG{__WARN__} = sub { log(substr($_[0],0,-1)) };
		local $main::DEBUG = 1;
		my $n = $sitedb->inc($site);
		log( "new window size for $site is $n" );
	    }
	} else {
	    log( $event, ' remains a running event for ', $jobid )
		if $main::DEBUG > 1;
	}
    } else {
	# remove when transitioning into any other state
	delete $main::running{$jobid};
    }

    # create content -- use one space only
    my $line = "$stamp $jobid $event " .
	( $addon || '-' ) . ' ' . ( $site || '-' ) . ' ' . ( $time || '-' );
    log( "new state $line" ) if $main::DEBUG > 1;

    # prepare for atomic append
    syswrite( JSDB, "$line\n" );
    $main::jobstate{$jobid} = [ $stamp, $event, $addon, $time, $site ];

    # Add to job state table in database -- if it exists
    if ( defined $workdb && defined $main::workid ) {
	my $rv = $main::seen{$jobid} ? 
	    $workdb->update_jobstate($main::workid,$jobid,$event,$stamp,$site) :
	    $workdb->add_jobstate($main::workid,$jobid,$event,$stamp,$site);
	if ( $rv == 1 ) {
	    # OK
	} elsif ( defined $rv && $rv == 0 ) {
	    log( 'Warning: Unable to update state for job ', $jobid );
	} else {
	    log( 'Warning: Updateing job ', $jobid, ': ', $workdb->error );
	}
    }

	   

    # NEW: maintain site statistics
    if ( defined $site ) {
	my $state;
	if ( $pending{$event} ) {
	    $state = 'P';
	} elsif ( $running{$event} ) {
	    $state = 'R';
	} elsif ( $event eq 'POST_SCRIPT_SUCCESS' ) { #||
		 # $event eq 'SUCCESS' ) {
	    $state = 'S';
	} elsif ( $event eq 'POST_SCRIPT_FAILURE' || 
		  $event eq 'JOB_FAILURE' ||
		  $event eq 'JOB_ABORTED' ) {
	    $state = 'F';
	} else {
	    $state = 'O';
	}


	# NEW: Add new sites to database (unless they already exist)
	if ( defined $workdb && ! exists $main::first{$site} ) {
	    # check for id and create site if missing
	    my $id = $workdb->siteinfo_id($site);
	    if ( defined $id ) {
		log( 'site ', $site, ' exists with id=', $id );
	    } else {
		$workdb->new_siteinfo($site,$stamp);
		log( 'inserted new site ', $site );
	    }
	    $main::first{$site} = 1;
	}

	if ( exists $main::siteinfo{$site}{$jobid} ) {
	    my $old = $main::siteinfo{$site}{$jobid};
	    if ( $old ne $state ) {
		# job changed state
		if ( $old ne 'S' && $old ne 'F' ) {
		    # gauge
		    --$main::siteinfo{$site}{$old};
		    $workdb->update_siteinfo( $site, $old, -1, $stamp )
			if defined $workdb;
		}
		$main::siteinfo{$site}{$state}++;
		$workdb->update_siteinfo( $site, $state, 1, $stamp )
		    if defined $workdb;
	    }
	} else {
	    # new state
	    $main::siteinfo{$site}{$state}++;
	    $workdb->update_siteinfo( $site, $state, 1, $stamp ) 
		if defined $workdb;
	}
	$main::siteinfo{$site}{'mtime_succ'} = $stamp if $state eq 'S';
	$main::siteinfo{$site}{'mtime_fail'} = $stamp if $state eq 'F';
	$main::siteinfo{$site}{$jobid} = $state;
	$main::siteinfo{$site}{mtime} = $stamp;	# last update time
	$workdb->commit if defined $workdb; # update site stats now
    }

    # count how this job changed states
    $main::seen{$jobid}++;
}

sub finally_siteinfo {
    # purpose: During shut-down, ensure that no "gauge" jobs are present
    # globals: %main::siteinfo, $workdb
    my $now = time;

    my $diff;
    my $count = 0;
    foreach my $site ( keys %main::siteinfo ) {
	foreach my $state ( qw(P R O) ) {
	    if ( ($diff = $main::siteinfo{$site}{$state}) > 0 ) {
		$workdb->update_siteinfo( $site, $state, -$diff, $now );
		$main::siteinfo{$site}{$state} = 0;
		$count++;
	    }
	}
    }
    $count;
}

sub process ($) {
    # purpose: process a log line and look for the data we are interested in 
    # paramtr: $line (IN): the line
    # globals: $main::stamp (OUT): maintains latest timestamp from DAGMan
    # returns: $main::stamp
    local($_) = shift;
    s/\s*$//;			# trim tail, including CR and LF

    if ( m{^\s*(\d{1,2})/(\d{1,2})(/(\d{1,2}))?\s+(\d{1,2}):(\d{2}):(\d{2})} ) {
	if ( $main::DEBUG > 2 ) {
	    my ($a,$b,$y) = split /\s+/, $_, 3;
	    my $x = length($y) > 64 ? substr($y,0,64) . '...' : $y;
	    warn "## ", $main::line, ": $x\n";
	}

	my @now = localtime();
	if ( $3 eq '' ) {
	    # old timestamp format -- we need a year (from localtime())
	    @now[0..4] = ($7, $6, $5, $2, $1-1 );
	} else {
	    # new timestamp format -- we have a year (see: perldoc Time::Local)
	    @now[0..5] = ($7, $6, $5, $2, $1-1, $4+100 ); 
	}
	$main::stamp = timelocal( @now[0..5] ) + $adjustment;

	# search for more content
	if ( /Event:\s+ULOG_(\S+) for Condor (?:Job|Node) (\S+)\s+\(([0-9]+\.[0-9]+)(\.[0-9]+)?\)$/ ) {
	    # found event
	    my ($event,$jobid,$condor) = ($1,$2,$3);
	    add( $main::stamp, $jobid, $event, $condor );

	# change in regexec to account for . in the jobnames
	#} elsif ( /\d{2}\sRunning (PRE|POST) script of (?:Job|Node) ([^.]+)/ ) {
	 } elsif ( /\d{2}\sRunning (PRE|POST) script of (?:Job|Node) (.+)\.{3}/ ) {
	    # pre scripts are not a regular Condor event
	    # starting of scripts is not a regular Condor event
	    my $script = uc($1);
	    my $jobid = $2;
	    #print ("[DEBUG]Script $script JobID $jobid\n");
	    add( $main::stamp, $jobid, $script . '_SCRIPT_STARTED' );

	} elsif ( /\d{2}\s(PRE|POST) Script of (?:Job|Node) (\S+)/ ) {
	    my $script = uc($1);
	    my $jobid = $2;

	    if ( /completed successfully\.$/ ) {
		# remember success with artificial jobstate
		add( $main::stamp, $jobid, $script . '_SCRIPT_SUCCESS' );
		$main::done{$jobid} = $main::stamp if $script eq 'POST';
	    } elsif ( /failed with status\s+(-?\d+)\.?$/ ) {
		# remember failure with artificial jobstate
		add( $main::stamp, $jobid, $script . '_SCRIPT_FAILURE', $1 );
		if ( $1==42 || $main::flag{$jobid} > 0 ) {
		    # detected permanent failure
		    log( 'detected permanent failure for ', $jobid );
		    log( 'Warning: No successful jobs so far!' ) 
			if ( 0+keys(%main::done) == 0 );
		}
	    } else {
		# ignore
		log( 'warning: unknown pscript state: ', substr($_,14) );
	    }

	} elsif ( /\d{2}\sNode (\S+) job proc \(([0-9\.]+)\) failed with status\s+(-?\d+)\.$/ ) {
	    # job has failed
	    my $jobid = $1;
	    my $jobstatus = $3;
	    # remember failure with artificial jobstate
	    add ( $main::stamp, $jobid, 'JOB_FAILURE', $jobstatus );

	} elsif ( /\d{2}\sNode (\S+) job proc \(([0-9\.]+)\) completed successfully\.$/ ) {
	    # job succeeded
	    my $jobid = $1;
	    # remember success with artificial jobstate
	    add ( $main::stamp, $jobid, 'JOB_SUCCESS' );

	} elsif ( /Retrying node (\S+) \(retry \#(\d+) of (\d+)\)/ ) {
	    # found a retry, save maxed-out retries for later...
	    $main::flag{$1}=$3 if ( $2 == $3 );

	} elsif ( /\(condor_DAGMAN\)[\w\s]+EXITING WITH STATUS (\d+)$/ ) {
	    # DAG finished -- done parsing
	    $main::terminate = $1;
	    log( 'DAGMan finished with exit code ', $main::terminate );
	    syswrite( JSDB, $main::stamp . " INTERNAL *** DAGMAN_FINISHED ***\n" );

	} elsif ( /\*\* PID = (\d+)$/ ) {
	    # DAGMan's pid
	    if ( $main::replay_mode == 0 ) {
		# Only set pid if not running in replay mode (otherwise pid may belong to another process)
		$main::pid = $1;
	    }
	    undef $main::terminate;
	    log( 'DAGMan runs at pid ', $main::pid );
	    syswrite( JSDB, $main::stamp . " INTERNAL *** DAGMAN_STARTED ***\n" );

	    # also mark all !DONE jobs as UN_READY
	    if ( defined $workdb ) {
		foreach my $jobid ( keys %main::subfn ) {
		    add( $main::stamp, $jobid, 'UN_READY' )
			unless exists $main::seen{$jobid};
		}
	    }

	} elsif ( m{\*\* \$CondorVersion: ((\d+\.\d+)\.\d+)} ) {
	    # Version of this logfile format
	    $main::condor_version = $1;
	    $main::condor_major = $2;
	    log( 'Using DAGMan version ', $main::condor_version );

	} elsif ( /Condor log will be written to ([^,]+)/ ||
		  ( $main::myInsaneFlag && /\d{2}\s{3,}(\S+)/ ) ) {
	    # Condor's common log file location, DAGMan 6.6
	    $main::condorlog = $1;
	    log( 'Condor writes its logfile to ', $main::condorlog );

	    # make a symlink for NFS-secured files
	    my ($log,$base) = out2log( $out );
	    if ( -l $log ) {
		log( "Symlink $log already exists" );
	    } elsif ( -r $log ) {
		log( "$base is a regular file, not touching" );
	    } else {
		log( 'Trying to create local symlink to common log' );
		if ( -r $main::condorlog || ! -e _ ) {
		    rename( $log, "$log.bak" ) if -r $log;
		    if ( symlink($main::condorlog,$log) == 1 ) {
			log( "symlink ", $main::condorlog, " -> ", $log );
		    } else {
			log( "unable to symlink ", $main::condorlog, ": $!" );
		    }
		} else {
		    log( $main::condorlog, ' exists but is not readable!' );
		}
	    }

	    # we only expect one of such files
	    undef $main::myInsaneFlag;

	} elsif ( /All DAG node user log files:/ ) {
	    # multiline user log files, DAGMan > 6.6
	    $main::myInsaneFlag = 1;
	}
    }

    # done
    $main::stamp;
}

sub plot ($) {
    # purpose: run show-run over the output files
    # paramtr: $out (IN): filename of DAGMan's log file
    # globals: $ENV{'PEGASUS_HOME'} (IN):
    #          $dag (IN): name of .dag file
    #          $run (IN): directory where everything resides
    # returns: -
    my $out = shift;
    my $log = File::Spec->catfile( $run, 'show-run.txt' );

    my $dagbase = basename( $dag );
    $dagbase =~ s/(?:\.(?:rescue|dag))+$//;
    $dagbase =~ s/-\d+$//;

    my $ypic = File::Spec->catfile( $run, $dagbase . '-1.jpeg' );
    my $zpic = File::Spec->catfile( $run, $dagbase . '-2.jpeg' );
    my $show = File::Spec->catfile( $ENV{'PEGASUS_HOME'}, 'contrib', 'showlog',
				    'show-run' );

    # show-run
    if ( -x $show && -r $dag ) {
	my @args = ( $show, '-D', $dag, '-b', $run, 
		     '-o', $ypic, '-O', $zpic, '-p' );
	push( @args, '-a', $adjustment ) if ( $adjustment != 0 );
	log( "@args" );
	local(*PLOT,*LOG);
	my $child = 0;
	local $SIG{ALRM} = sub { kill(15,$child) if $child>0; close PLOT };

	open( LOG, ">$log" ) || return;
	if ( ($child=open( PLOT, "@args 2>&1|" )) ) {
	    alarm($fuse);	# limit time for drawing
	    while ( <PLOT> ) {
		print LOG $_ unless ( /^\#/ );
		s/[\r\n]*$//;
		log( 'plot: ', $_ ) if ( $main::DEBUG > 1 );
	    }
	    close PLOT;
	    alarm(0);
	} else {
	    log( "$show had problems: $!\n" );
	}
	close LOG;
    }
    
    # show-job
    $log = File::Spec->catfile( $run, 'show-job.txt' );
    $show = File::Spec->catfile( $ENV{'PEGASUS_HOME'}, 'contrib', 'showlog',
				 'show-job' );
    if ( -x $show && -r $dag ) {
	my @args = ( $show, $dag );
	log( "@args" );
	local(*PLOT,*LOG);
	my $child = 0;
	local $SIG{ALRM} = sub { kill(15,$child) if $child>0; close PLOT };

	open( LOG, ">$log" ) || return;
	if ( ($child=open( PLOT, "@args 2>&1|" )) ) {
	    alarm($fuse);	# limit time for drawing
	    while ( <PLOT> ) {
		print LOG $_ unless ( /^\#/ );
		s/[\r\n]*$//;
		log( 'plot: ', $_ ) if ( $main::DEBUG > 1 );
	    }
	    close PLOT;
	    alarm(0);
	} else {
	    log( "$show had problems: $!\n" );
	}
	close LOG;
    }
}

sub condor_rm {
    # purpose: Run condor_rm on one or more Condor IDs
    # paramtr: One or more valid Condor IDs
    # globals: %main::remove (IO): maintain removals to turn forceful
    # returns: number of successful condor_rm operations
    my $result = 0;

    local(*RM);			# protect other components
    foreach my $condor ( @_ ) {
	$condor = basename($condor, '.0') if ( $condor =~ tr/././ > 1 );
	unless ( $condor =~ /^\d+(\.\d+)?$/ ) {
	    log( 'invalid condor id "', $condor, '"' );
	    next;
	}

	my @args = ( $condor_rm );
	push( @args, '-f' ) if $main::remove{$condor} > 10;
	push( @args, $condor );
        if ( open( RM, "@args 2>&1|" ) ) {
            while ( <RM> ) {
		s/[\r\n]*$//;
		log( 'condor_rm: ', $_ );
		$main::remove{$condor}++
		    if ( /(?:Job|Node) [0-9.]+ already marked for removal/ );
	    }

	    if ( $? == 0 ) {
		$result++;
		delete $main::remove{$condor}; # may not be there
	    }
	} else {
	    log( "unable to execute $condor_rm: $!" );
	}
    }

    $result;
}

sub check_starvation(;$) {
    # purpose: check if there are starving jobs
    # paramtr: $now (IN): current time to check against
    # globals: %main::pending (IN): used to determine starving jobs
    # returns: -
    my $now = shift || time();
    return if $starvation == 0;	# skip starvation checks for Pegasus

    log( 'Start: checking for starvation' ); # if $main::DEBUG > 1;

    # candidates entered GLOBUS_SUBMIT more than $starvation/3 ago
    my $warn = $starvation / 3;
    foreach my $jobid ( # 3) order by worst case first
			sort { $main::pending{$a}->[0] <=>
				   $main::pending{$b}->[0] } 
			# 2) reduce to those that ran too long
			grep { $now - $main::pending{$_}->[0] > $warn } 
			# 1) for all jobids
			keys %main::pending ) {

	my $diff = $now - $main::pending{$jobid}->[0];
	my $condor = substr( $main::pending{$jobid}->[1], 0, -2 );
	log( "$jobid ($condor) is pending for $diff s" );

	# if pending for more than $starvation ago, remove job from Condor
	condor_rm($condor) if ( $diff > $starvation );
    }
    
    
    # candidates for hidden starvation entered EXECUTE a lot longer ago
    # than they intended to obtain walltime for. However, we can do this
    # check only for "nice" jobs that declare their walltime in Globus RSL!

    return if $liedetector == 0;	# skip walltime starvation execution checks for Pegasus

    my $n = 0.75 * $liedetector;
    foreach my $jobid ( # 4) order by worst case first
			sort { $main::running{$a}->[0] <=> 
				   $main::running{$b}->[0] } 
			# 3) reduce to those which ran over
			grep { ($now - $main::running{$_}->[0]) > 
				   ($n * $main::running{$_}->[2]) } 
			# 2) reduce to those with a declared walltime
			#    nothing we can do about secretive jobs w/o RSL
			grep { defined $main::running{$_}->[2] }
			# 1) for all jobids
			keys %main::running ) {

	my $diff = $now - $main::running{$jobid}->[0];
	#my $condor = substr( $main::running{$jobid}->[1], 0, -2 );
	my $condor = $main::running{$jobid}->[1];
	my $wall = $main::running{$jobid}->[2];
	log( "$jobid ($condor) execution: requested=$wall s, runtime=$diff s",
	     sprintf( " (%.1f)", 1.0 * $diff / $wall) );

	# hidden starvation for more than N * $wall and 10 minutes
	# JSV: 20050419: added constraint of 10min minimum wait
	condor_rm($condor) if ( $diff > $liedetector * $wall && $diff > 600 );
    }
    log( 'Done: checking for starvation' ); # if $main::DEBUG > 1;
}

sub server_socket($$;$) {
    # purpose: create a local TCP server socket to listen for sitesel requests
    # paramtr: $lo (IN): minimum port from bind range
    #          $hi (IN): maximum port from bind range
    #          $bind (opt. IN): hostaddr_in to bind to, default LOOPBACK
    # returns: open socket handle, or undef on error (see $!)
    my $lo = shift;
    my $hi = shift;
    my $bind = shift || INADDR_LOOPBACK;
    local(*SOCK);

    eval {
	# create socket
	socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') || 6 ) ||
	    die "create socket: $!";

	# set options
	setsockopt( SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l",1) ) ||
	    die "setsockopt SO_REUSEADDR: $!";

	# bind to a free port
	my $port;
	for ( $port = $lo; $port < $hi; ++$port ) {
	    my $sin = sockaddr_in( $port, $bind );
	    bind( SOCK, $sin ) && last;
	}
	die "no free port to bind to" if ( $port >= $hi );

	# make server socket non-blocking to not have a race condition
	# when doing select() before accept() on a server socket.
	my $buffer;
	if ( fcntl( SOCK, F_GETFL, $buffer ) ) {
	    my $flags = unpack("l",$buffer);
	    fcntl( SOCK, F_SETFL, pack("l",$flags | O_NONBLOCK ) );
	} else {
	    die "fcntl: $!";
	}

	# start listener
	listen( SOCK, SOMAXCONN ) ||
	    die "listen: $!";
    };

    if ( $@ ) {
	log( "While creating server socket: $@" );
	close(SOCK);
	return undef;
    } else {
	return *SOCK;
    }
}

sub show_job(*$;$) {
    # purpose: print job information onto the given socket descriptor
    # paramtr: *R (IO): socket descriptor to client
    #          $jid (IN): job id into %main::jobstate
    #          $x (opt. IN): array ref from %main::jobstate
    # globals: %main::jobstate (IN)
    # returns: undef on error, 1 on success
    local(*R) = shift;
    my $jid = shift;
    my $x = shift || $main::jobstate{$jid};

    my $line = sprintf( "%s %u %s %s %s %s\r\n", $jid,
			$x->[0], $x->[1], $x->[2] || '-',
			$x->[3] || '-', $x->[4] || '-' );
    unless ( defined syswrite( R, $line ) ) {
	log( "writing to socket: $!" );
	return undef;
    }

    1;
}

sub service_request_job(*$) {
    # purpose: service a request for a job status
    # paramtr: *R (IO): socket descriptor to client
    #          $job (IN): Either asterisk (*) for all, or a specific job
    # returns: number of entries written
    local(*R) = shift;
    my $job = shift;

    my ($jid,$x,$count);
    if ( $job eq '*' || ! defined $job ) {
	# all jobs -- optimization over regexp match below
#	foreach $jid ( sort keys %main::jobstate ) {
#	    $x = $main::jobstate{$jid};
	while ( ($jid,$x) = each %main::jobstate ) {
	    last unless defined show_job(R,$jid,$x);
	    $count++;
	}
    } elsif ( exists $main::jobstate{$job} ) {
	# specific job
	$count++ if defined show_job(R,$job);
    } else {
	# treat as regular expression
	foreach $jid ( grep { /$job/ } keys %main::jobstate ) {
	    last unless defined show_job(R,$jid);
	    $count++;
	}
    }

    $count;
}

sub show_site(*$;$) {
    # purpose: print job information onto the given socket descriptor
    # paramtr: *R (IO): socket descriptor to client
    #          $site (IN): site handle into %main::siteinfo
    #          $x (opt. IN): array ref from %main::siteinfo
    # globals: %main::siteinfo (IN)
    #          %main::waiting (IN): history of P->R transitions
    # returns: undef on error, 1 on success
    local(*R) = shift;
    my $site = shift;
    my $x = shift || $main::siteinfo{$site};

    my $line  = sprintf( "%-16s %-21s %4u %4u %4u %6u %6u %-20s %s\r\n", 
			 $site, isodate($x->{mtime},0,1), 
			 0+$x->{P}, 0+$x->{R}, 0+$x->{O}, 0+$x->{S}, 0+$x->{F},
			 ( exists $x->{'mtime_succ'} ?
			   isodate($x->{'mtime_succ'},0,1) :
			   'null' ),
			 ( exists $x->{'mtime_fail'} ?
			   isodate($x->{'mtime_fail'},0,1) :
			   'null' ) );
    unless ( defined syswrite( R, $line ) ) {
	log( "writing to socket: $!" );
	return undef;
    }

    my $now = $main::stamp || time();
    my @out = sort { $b <=> $a } keys %{$main::waiting{$site}};
    for ( my $i=0; $i < @out; ++$i ) {
	$x = $main::waiting{$site}{$out[$i]};
	$line = sprintf( "\t%-20s %lu %lu %.3f\r\n", 
			 isodate($out[$i]*60,0,1), $x->[0], $x->[1], 
			 ( $x->[0] != 0 ? $x->[1] / $x->[0] : $x->[1] ) );
	unless ( defined syswrite( R, $line ) ) {
	    log( "writing to socket: $!" );
	    return undef;
	}
    }

    1;
}	


sub service_request_site(*$) {
    # purpose: service a request for site status
    # paramtr: *R (IO): file descriptor to client
    # returns: number of entries written, undef on immediate error
    local(*R) = shift;
    my $site = shift;

    my ($handle,$x,$count);
    if ( $site eq '*' || ! defined $site ) {
	# dump all
	while ( ($handle,$x) = each %main::siteinfo ) {
	    last unless defined show_site(R,$handle,$x);
	    $count++;
	}
    } elsif ( exists $main::siteinfo{$site} ) {
	# dump one specific site
	$count++ if defined show_site(R,$site);
    } else {
	# treat as regular expression
	foreach $handle ( grep { /$site/ } keys %main::siteinfo ) {
	    last unless defined show_site(R,$handle);
	    $count++;
	}
    }

    $count;
}
    
my $speak = 'TSSP/1.0';
my %jumptable = ( 'site' => \&service_request_site,
		  'job' => \&service_request_job );
my %checksize = ( 'site' => sub { ( $_[0] eq '*' || ! defined $_[0] ) ?
				      scalar %main::siteinfo :
				      scalar grep { /$_[0]/ } 
				  keys %main::siteinfo },
		  'job' => sub { ( $_[0] eq '*' || ! defined $_[0] ) ?
				     scalar %main::jobstate :
				     scalar grep { /$_[0]/ } 
				 keys %main::jobstate } );

sub untaint($) {
    # purpose: Do not trust anything from the internet
    # paramtr: $_ (IN): A word received from the internet
    # returns: a safe string with Perl escapisms removed
    local($_) = shift;
    tr/-A-Za-z0-9_.,[]^*?+\///csd;
    $_;
}

sub service_request($) {
    # purpose: accept an incoming connection and service its request
    # paramtr: $server (IN): server socket with pending connection request
    # returns: number of status lines, or undef in case of error
    my $server = shift;
    local(*R);
    local $SIG{PIPE} = 'IGNORE';

    if ( accept( R, $server ) ) {
	my $count;
	my ($port,$host,$line) = sockaddr_in(getpeername(R));
	log( 'processing request from ', inet_ntoa($host), ':', $port );

	# DO NOT use keep-alive as in "while ( <R> ) {"
	# until this service is implement using concurrent servers!
	# read request
	if ( defined ($_ = <R>) ) {
 	    s/^\s+//;		# trim front
 	    s/[ \t\r\n]+$//;	# trim rear
 
 	    # requests are 1-liners
 	    my ($method,@args) = map { untaint $_ } split ;
	    my $proto = pop(@args); # last element is protocol id
	    my $what = lc(shift(@args)); # first element is what to do

 	    if ( $proto ne $speak ) {
 		# illegal or unknown protocol
 		syswrite( R, "$speak 400 Bad request\r\n" );
 	    } elsif ( uc($method) ne 'GET' ) {
 		# unsupported method
 		syswrite( R, "$speak 405 Method not allowed\r\n" );
 	    } elsif ( ! exists $jumptable{$what} ) {
		# requested item is not supported
		syswrite( R, "$speak 501 Not implemented\r\n" );
	    } else {
 		# ok
		no strict q/subs/;
		if ( $checksize{$what}->(@args) ) {
		    syswrite( R, "$speak 200 OK\r\n" );
		    $count = $jumptable{$what}->( R, @args );
		} else {
		    syswrite( R, "$speak 204 No Content\r\n" );
		    $count = '0 but true';
		}
	    }
 	}

	close R;
	$count;
    } else {
	log( "accept: $!" );
	undef;
    }
}

sub check_request($;$) {
    # purpose: check for a pending service request, and service it
    # paramtr: $server (IN): server socket
    #          $timeout (opt. IN): timeout in seconds, defaults to 0
    # returns: return value from select on server socket
    my $server = shift;
    my $timeout = shift || 0;

    my $rin = '';
    vec($rin,fileno($server),1)=1;
    my $rout;
    my $n = select( $rout=$rin, undef, undef, $timeout );
    service_request($server) if ( $n == 1 );

    $n;
}

sub sleepy($$) {
    # purpose: sleep or work on client requests
    # paramtr: $retries (IN): number of retries we are in
    #          $server (IN): server listening socket, may be undef'd
    # returns: -
    my $sleeptime = sleeptime( shift() );
    my $server = shift;

    if ( defined $server ) {
	# elaborate iterative (non-concurrent) internet daemon 
	my $start = time();
	my $diff;
	do { 
	    $diff = time() - $start;
	    my $t = ( $diff < $sleeptime ? $sleeptime - $diff : 0 );
	    check_request( $server, $t );
	} while ( $diff < $sleeptime );
    } else {
	# no server, just sleep regularly
	sleep( $sleeptime ) if $sleeptime;
    }
}

sub sleeptime($) {
    # purpose: compute suggested sleep time as a function of retries
    # paramtr: $retries (IN): number of retries so far
    # returns: recommended sleep time
    my $x = shift;

    my $y;
    if ( $x < 5 ) {
	$y = 1;
    } elsif ( $x < 50 ) {
	$y = 5;
    } elsif ( $x < 500 ) {
	$y = 30;
    } else {
	$y = 60;
    }

    $y;
}

sub daemonize ($) {
    # purpose: Turn process into a daemon
    # paramtr: $fn (IN): name of file to connect stdout to
    # returns: -
    # warning: forks a couple of times
    my $fn = shift || croak "ERROR: Need a filename";

    # go to a safe place that is not susceptible to sudden umounts
    # FIXME: This may break some things
    chdir('/') || die "chdir /: $!\n";

    # open logfile as stdout
    open( STDOUT, ">$fn" ) || die "open $fn: $!\n";

    # fork and go 
    my $pid = fork();
    fatal( "fork" ) if ( $pid == -1 );
    exit(0) if ( $pid > 0 );	#  parent exits

    # daemon child -- fork again for System-V
    $pid = fork();
    fatal( "fork" ) if ( $pid == -1 );
    exit(0) if ( $pid > 0 );	# parent exits

    # setsid
    fatal( "setsid" ) if ( setsid() < 0 );
}

sub keep_foreground ($) {
    # purpose: Turn into almost deamon, but keep in foreground for Condor
    # paramtr: $fn (IN): name of file to connect stdout to
    # returns: -
    my $fn = shift || croak "ERROR: Need a filename";

    # go to a safe place that is not susceptible to sudden umounts
    # FIXME: This may break some things
    chdir('/') || die "chdir /: $!\n";

    # open logfile as stdout -- dunno, if this shouldnt be rather
    # a "output = $fn" line in the submit file. 
    open( STDOUT, ">>$fn" ) || die "open $fn: $!\n";

    # we cannot set sid, but we can become process group leader
    setpgid( 0, 0 ) || die "setpgid: $!\n";
}

#
# --- main ---------------------------------------------------
#

# sanity check: Be permissive
umask 0002;

# turn into daemon process
if ( $nodaemon == 0 ) {
    daemonize($logfile);
} elsif ( $nodaemon == 2 ) {
    keep_foreground($logfile);
}

# NOW -- after most fork() calls -- connect to the database
## TODO FIX THIS TO ignore the database errors.

if ($database){
    $workdb = eval { Pegasus::Workflow->new($props,0) }; # fire-proofing
    unless ( defined $workdb ) {
	my $msg = 'ERROR: Your database handle is undefined';
	$msg .= ": $@" if ( $@ );
	warn "$msg\n";
    }
    
    $main::workid = ( %config ?
		  infer_from_config(%config) :
		      infer_from_directory($run) ) ||
		      die( "FATAL: Workflow was not entered in wf_work database\n" );
    END {
	if ( defined $workdb ) {
	    #### finally_siteinfo();
	    $workdb->commit unless $workdb->handle->{AutoCommit};
	}
    }
}

# dup2( STDOUT, STDERR )
close STDIN;
open( STDERR, ">&STDOUT" ); # dup2 STDERR onto STDOUT
select( STDERR ); $|=1; # autoflush
select( STDOUT ); $|=1; # autoflush

# say hi
log( 'starting [', $main::revision, '], using pid ', $$ );
log( "using simulation delay of $millisleep ms" ) if defined $millisleep;

# ignore dying shells
$SIG{HUP} = 'IGNORE';

# die nicely when asked to (Ctrl+C, system shutdown)
$SIG{INT} = $SIG{TERM} = sub {
    log( 'graceful exit on signal ', $_[0] );
    exit(1);
};

# permit dynamic changes of debug level
$SIG{USR1} = sub { ++$main::DEBUG };
$SIG{USR2} = sub { $main::DEBUG-- };

# create server socket for communication with site selector
my $sockfn = File::Spec->catfile( dirname($out), 'tailstatd.sock' );
my $server = undef;
if ( $main::replay_mode == 0 ) {
    $server = server_socket( 49152, 65536 );
}
END { 
    if ( defined $server ) {
	close($server);
	unlink($sockfn);
    }
}
if ( defined $server ) {
    # save our address so that site selectors know where to connect to
    my ($port,$host) = sockaddr_in(getsockname($server));
    if ( open( OUT, ">$sockfn" ) ) {
	printf OUT "%s %d\n", inet_ntoa($host), $port;
	close OUT;
    } else {
	log( 'Warning: Unable to write ', $sockfn, ": $!" );
    }
}

# Warning: Due to %SIG, we need to make atexit signal safe
END {
    # Attempt to copy the Condor common logfile to the current directory
    if ( $main::replay_mode == 0 && $main::condorlog && -r $main::condorlog && 
	 index($main::condorlog,'/')==0 ) {
	# copy common Condor log to local directory
	my $log = out2log( $out );
	my @args = ( '/bin/cp', '-p', $main::condorlog, "$log.copy" );
	if ( system(@args) == 0 ) {
	    if ( unlink( $log ) == 1 ) {
		rename( "$log.copy", $log );
		log( 'copied common log to ', $run );
	    }
	} else { 
	    log( "@args: ", $? >> 8, '/', ($? & 127) );
	}
    }

    # remember to tell me that it is ok to run post-processing now
    if ( $main::replay_mode == 0 && defined $main::terminate && defined $run ) {
	my $touch = File::Spec->catfile( $run, 'tailstatd.done' );
	if ( sysopen( TOUCH, $touch, O_WRONLY | O_CREAT | O_TRUNC ) ) {
	    $main::stamp ||= time();
	    syswrite( TOUCH, isodate($main::stamp) . 
		      sprintf( " %.3f\n", ($main::stamp - $main::start) ) );
	    close TOUCH;
	}
    }
}

# for future reference
my $plus;
foreach ( split /:/, $ENV{'LD_LIBRARY_PATH'} ) {
    log( "env: LD_LIBRARY_PATH$plus=$_" );
    $plus = '+';
}
log( 'env: GLOBUS_TCP_PORT_RANGE=', $ENV{'GLOBUS_TCP_PORT_RANGE'} );
log( 'env: GLOBUS_TCP_SOURCE_RANGE=', $ENV{'GLOBUS_TCP_SOURCE_RANGE'} );
log( 'env: GLOBUS_LOCATION=', $ENV{'GLOBUS_LOCATION'} );

# phase: wait for .out file to appear
my @stat;
my $retries = 0;

# Test if dagman.out file is there in case we are running in replay_mode
if ( $main::replay_mode == 1 ) {
    @stat=stat($out);
    if ( @stat == 0 ) {
        log( "error: workflow not started, $out does not exist, exiting..." );
        exit(42);
    }
}

while ( (@stat=stat($out)) == 0 ) {
    fatal( "stat $out" ) unless $!{ENOENT};
    fatal( "$out never made an appearance") if ( ++$retries > 100 );
    log( "waiting for out file, retry $retries" ) if $main::DEBUG;
    sleepy($retries,$server);
}
# post-condition: @stat is a valid stat record from daglog file

# open daglog file
sysopen( DMOF, $out, O_RDONLY ) || fatal( "sysopen $out" );

# 
# main loop
#
# phase: read job state from file
$retries = 0;
my $buffer = '';
my $current = 0;
for (;;) {
    # say IAA (i am alive)
    log( 'wake up and smell the silicon' ) if $main::DEBUG > 1;

    # periodically check for starving jobs -- but not in reparse mode
    if ( $last_check < $main::stamp ) {
	my $now = time();
	if ( $now - $last_check > $job_check_interval ) {
	    check_starvation($now);
	    $last_check = $now;
	}
    }

    # periodically check for service requests
    check_request($server) if defined $server;

    @stat = stat($out);
    if ( $stat[7] == $current ) {
	# death by natural causes
	last if defined $main::terminate; 

	# check if DAGMan is alive -- if we know where it lives
	if ( $retries > 10 && $main::pid > 0 ) {
	    # Perl: sending signal 0 just checks, if the pid is ours
	    if ( kill( 0, $main::pid ) == 0 ) {
		log( "DAGMan is gone! Sudden death syndrome detected!" );
		$main::terminate = 42;
		last;
	    }
	}

	# no change, wait a while
	if ( ++$retries > 17280 ) {
	    # too long without change
	    log( "too long without action, self-destructing" );
	    last;
	}

	# sleep or work on client requests now
	sleepy($retries,$server);
    } elsif ( $stat[7] < $current ) {
	# truncated file, booh!
	log( "file truncated, time to exit" );
	last;
    } elsif ( $stat[7] > $current ) {
	# something to read
	my $size = length($buffer);
	my $rsize = sysread( DMOF, $buffer, 32768-$size, $size );
	if ( ! defined $rsize || $rsize == -1 ) {
	    # error while reading
	    next if ( $!{EINTR} || $!{EAGAIN} );
	    fatal( "while reading" );
	} elsif ( $rsize == 0 ) {
	    # detected EOF, grrr
	    log( "detected EOF, resetting to position $current" );
	    sysseek( DMOF, $current, 0 );
	} else {
	    # yeah, something in the buffer... 
	    my $pos = index($buffer,"\n");
	    while ( $pos >= 0 ) {
		# take out 1 line and adjust buffer
		process( substr($buffer,0,$pos) );
		$buffer = substr($buffer,$pos+1);
		$main::line++;
		$pos = index($buffer,"\n");

		if ( defined $millisleep ) {
		    if ( defined $server ) {
			check_request( $server, $millisleep / 1000.0 );
		    } else {
			Time::HiRes::sleep($millisleep/1000.0);
		    }
		}
	    }
	    $pos = systell(DMOF);
	    log( "processed chunk of ", $pos-$current, " byte" );
	    $current = $pos;
	    $retries = 0;
	}

	# NEW: Commit changes into transaction
	if ( $retries == 0 ) {
	    $workdb->commit if defined $workdb;
	    #Time::HiRes::sleep($millisleep/1000.0) if defined $millisleep;
	}
    } else {
	# should not happen; should not be harmful, either
    }
}
close DMOF;

if ( $main::replay_mode == 0 ) {
    # finish trailing connection requests
    while ( check_request($server) ) { }
    close $server;
    unlink $sockfn;
    undef $server;

    # NEW: dump siteinfo at end
    if ( open( SI, ">$run/sitedump.txt" ) ) {
	service_request_site(SI,undef);
	close SI;
    }
}

$main::terminate += 0;		# make numeric
syswrite( JSDB, "@{[time]} INTERNAL *** TAILSTATD_FINISHED $main::terminate ***\n" );
close JSDB;

if ( defined $workdb ) {
    $workdb->update_work( $main::workid, $main::terminate, $main::stamp )
	if defined $main::workid;
    $workdb->commit;
    $workdb->handle->disconnect; # Grrr
}
undef $workdb;

# try to run the hurricane graphics :-)
if ( $doplot ) {
    plot($out) if ( -r $out && exists $ENV{'PEGASUS_HOME'} );
} else {
    log( "skipping plots" );
}

# clean up
if ( $main::terminate == 0 ) {
    unlink $rmdb;
}

# done
log( 'finishing, exit with ', $main::terminate );
exit( $main::terminate );
