# -*- perl -*-

#
#   Copyright (C) Heinz-Josef Claes (2001-2004)
#                 hjclaes@web.de
#   
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#   
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#   
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#


push @VERSION, '$Id: forkProc.pl 336 2005-08-12 21:03:30Z hjc $ ';

#use strict;

use POSIX;
use POSIX ":sys_wait_h";

require 'checkObjPar.pl';
require 'prLog.pl';
require 'fileDir.pl';


############################################################
package simpleFork;

sub new
{
    my $class = shift;
    my $self = {};

    my (%params) = ('-function' => undef,  # function to call
		    '-funcPar'  => []      # parameter of that function
		    );
    &::checkObjectParams(\%params, \@_, 'simpleFork::new',
			 ['-function']);

    # fork now
    my $pid = fork;
    unless ($pid)    # we are now in the client
    {
	my $function = $params{'-function'};
	exit &$function(@{$params{'-funcPar'}});
    }

    $self->{'pid'} = $pid;      # we are now in the parent
    $self->{'status'} = undef;

    bless $self, $class;
}


##################################################
sub get
{
    my $self = shift;

    my (%params) = ('-what'        => undef);

    &::checkObjectParams(\%params, \@_, 'forkProc::get',
			 ['-what']);

    return undef unless defined $self->{$params{'-what'}};
    return $self->{$params{'-what'}};
}


##################################################
sub wait
{
    my $self = shift;
    waitpid $self->{'pid'}, 0;
    $self->{'status'} = $? >> 8 if $self->{'status'} eq undef;
}


##################################################
# returns 1 if process still running
# returns 0 if process is not running
sub processRuns
{
    my $self = shift;

    my $pid = $self->{'pid'};
    return 0 if (waitpid($pid, &::WNOHANG) == -1);  # leider besser!
    $self->{'status'} = $? >> 8 if $? != -1 and $self->{'status'} eq undef;
    return 0 if (waitpid($pid, &::WNOHANG) == -1);  # leider besser!
    $self->{'status'} = $? >> 8 if $? != -1 and $self->{'status'} eq undef;
    return 1;     # läuft noch
}


##################################################
# send signal to forked process
# returns 1, if process was reachable, else 0
sub signal
{
    my $self = shift;

    my (%params) = ('-value' => 2);   # default: SIGINT

    &::checkObjectParams(\%params, \@_, 'forkProc:',
			 ['-value']);

    my $ret = kill $params{'-value'}, $self->{'pid'};

    return $ret;
}


############################################################
package forkProc;

sub new
{
    my $class = shift;
    my $self = {};

    my (%params) = ('-exec'        => undef,
		    '-param'       => [],
		    '-workingDir'  => undef,

		    '-stdin'       => undef,

		    '-stdout'      => undef, # hat Vorrang vor '-outRandom',
		                             # falls gesetzt
		    '-stderr'      => undef, # hat Vorrang vor '-outRandom',
		                             # falls gesetzt
		    '-outRandom'   => undef, # wenn auf String gesetzt,
		                             # (z.B. "/tmp/test") wird
		                             # dieser als Anfang des
		                             # Dateinamens für '-stdout'
		                             # und '-stderr' genommen
		    '-delStdout'   => 'yes', # lösche Datei für stdout
		                             # automatisch

		    '-prLog'       => undef,

		    '-info'        => undef, # beliebige zusätzliche Info

		    '-prLogError'  => 'E',
		    '-exitIfError' => 1      # Exit-Wert bei Error
		    );

    &::checkObjectParams(\%params, \@_, 'forkProc::new',
			 ['-exec', '-prLog']);
    &::setParamsDirect($self, \%params);

    my $proc = $params{'-exec'};
    my $par = $params{'-param'};     # Pointer auf Parameter
    my $dir = $params{'-workingDir'};
    my $stdin = $params{'-stdin'};
    my $stdout = $params{'-stdout'};
    my $stderr = $params{'-stderr'};
    my $outRandom = $params{'-outRandom'};
    my $prLog = $params{'-prLog'};
    my $err = $params{'-prLogError'};
    my $ex = $params{'-exitIfError'};

    # zufällig Dateinamen erstellen, falls nötig
    if ($outRandom ne undef)
    {
	$self->{'stdout'} = $stdout = &::uniqFileName($outRandom)
	    if $stdout eq undef;
	$self->{'stderr'} = $stderr = &::uniqFileName($outRandom)
	    if $stderr eq undef;
    }

    # jetzt forken
    my $pid = fork;
    unless ($pid)   # im Client
    {
	if (defined $dir)
	{
	    unless (chdir "$dir")
	    {
		$prLog->print('-kind' => $err,
			      '-str' =>
			      ["Cannot chdir to <$dir> for <$proc>"]);
		exit $ex;
	    }
	}
	if (defined $stdin)
	{
	    unless (sysopen(STDIN, $stdin, 0))
	    {
		$prLog->print('-kind' => $err,
			      '-str' =>
			      ["Cannot read <$stdin> when starting <$proc>"]);
		exit $ex;
	    }
	}
	if (defined $stdout)
	{
	    unless (open STDOUT, "> $stdout")
	    {
		$prLog->print('-kind' => $err,
			      '-str' =>
			      ["Cannot write <$stdout> when starting <$proc>"]);
		exit $ex;
	    }
	}
	if (defined $stderr)
	{
	    unless (open STDERR, "> $stderr")
	    {
		$prLog->print('-kind' => $err,
			      '-str' =>
			      ["Cannot dup stderr when starting $proc"]);
		exit $ex;
	    }
	}

	unless (exec $proc, @$par)
	{
	    $prLog->print('-kind' => $err,
			  '-str' => ["cannot exec $proc @$par"]);
	    exit $ex;
	}
    }

    $self->{'pid'} = $pid;      # im Parent
    $self->{'status'} = undef;

    bless $self, $class;
}


##################################################
sub get
{
    my $self = shift;

    my (%params) = ('-what'        => undef);

    &::checkObjectParams(\%params, \@_, 'forkProc::get',
			 ['-what']);

    return undef unless defined $self->{$params{'-what'}};
    return $self->{$params{'-what'}};
}


##################################################
sub wait
{
    my $self = shift;
    waitpid $self->{'pid'}, 0;
    $self->{'status'} = $? >> 8 if $self->{'status'} eq undef;
}


##################################################
# returns 1 if process still running
# returns 0 if process is not running
sub processRuns
{
    my $self = shift;

    my $pid = $self->{'pid'};
    return 0 if (waitpid($pid, &::WNOHANG) == -1);  # doppelt hält hier
    $self->{'status'} = $? >> 8 if $? != -1 and $self->{'status'} eq undef;
    return 0 if (waitpid($pid, &::WNOHANG) == -1);  # leider besser!
    $self->{'status'} = $? >> 8 if $? != -1 and $self->{'status'} eq undef;
    return 1;     # läuft noch
}


##################################################
sub getSTDOUT
{
    my $self = shift;

    local *FILE;
    my ($l, @lines);
    open(FILE, "< " . $self->{'stdout'})
	or return [];
    while ($l = <FILE>)
    {
	chomp $l;
	push @lines, $l;
    }
    close(FILE);
    return \@lines;
}


##################################################
sub getSTDERR
{
    my $self = shift;

    local *FILE;
    my ($l, @lines);
    open(FILE, "< " . $self->{'stderr'})
	or return [];
    while ($l = <FILE>)
    {
	chomp $l;
	push @lines, $l;
    }
    close(FILE);
    return \@lines;
}


##################################################
sub delSTDOUT
{
    my $self = shift;

    unlink $self->{'stdout'} if ($self->{'stdout'} and
				 $self->{'stdout'} ne '/dev/null');
    $self->{'stdout'} = undef;
}


##################################################
# send signal to forked process
# returns 1, if process was reachable, else 0
sub signal
{
    my $self = shift;

    my (%params) = ('-value' => 2);   # default: SIGINT

    &::checkObjectParams(\%params, \@_, 'forkProc:',
			 ['-value']);

    my $ret = kill $params{'-value'}, $self->{'pid'};

    if ($ret)
    {
	$self->{'prLog'}->print('-kind' => 'W',
				'-str' =>
				["killing process " . $self->{'pid'}]);
	$self->delSTDOUT();
    }
    return $ret;
}


##################################################
sub DESTROY
{
    my $self = shift;

    unlink $self->{'stderr'} if ($self->{'stderr'} and
				 $self->{'stderr'} ne '/dev/null');

    $self->delSTDOUT() if ($self->{'delStdout'} eq 'yes');
}


############################################################
# fork von mehreren Prozessen, die parallel gestart und
# verwaltet werden können
# arbeitet mit Klasse forcProc
package parallelForkProc;

##################################################
sub new
{
    my $class = shift;
    my $self = {};

    my (%params) = ('-maxParallel'   => undef,
		    '-prLog'         => undef,
		    '-prLogError'    => 'E',
		    '-exitIfError'   => 1,     # Exit-Wert bei Error
		    '-maxWaitTime'   => 1,     # in seconds (-> add())
		    '-noOfWaitSteps' => 10
		    );

    &::checkObjectParams(\%params, \@_, 'parallelForkProc::new',
			 ['-maxParallel', '-prLog']);
    &::setParamsDirect($self, \%params);

    @{$self->{'jobs'}} = ();
    foreach (1..$params{'-maxParallel'})
    {
	push @{$self->{'jobs'}}, undef;
    }

    $self->{'sched'} =
 	tinyWaitScheduler->new('-maxWaitTime'   => $params{'-maxWaitTime'},
			       '-noOfWaitSteps' => $params{'-noOfWaitSteps'});

    bless $self, $class;
}


##################################################
sub getMaxParallel
{
    my $self = shift;

    return $self->{'maxParallel'};
}


##################################################
sub getNoUsedEntries
{
    my $self = shift;

    my $n = 0;
    my $entry;
    foreach $entry (@{$self->{'jobs'}})
    {
	++$n if $entry;
    }
    return $n;
}


##################################################
sub getNoFreeEntries
{
    my $self = shift;

    my $n = 0;
    my $entry;
    foreach $entry (@{$self->{'jobs'}})
    {
	++$n unless $entry;
    }
    return $n;
}


##################################################
# Liefert eine Liste mit den Infos der jobs, die
# vom Objekt verwaltet werden.
sub getAllInfos
{
    my $self = shift;

    my @ret = ();
    my $i;
    my $jobs = $self->{'jobs'};
    for ($i = 0 ; $i < @$jobs ; $i++)
    {
	my $job = $$jobs[$i];
	next if $job eq undef;

	push @ret, $job->get('-what' => 'info');
    }
    return @ret;
}


##################################################
# Überprüft, welche Jobs fertig sind. Liefert eine Liste mit Pointern
# mit den Jobs (Typ forkProc) zurück und löscht die Jobs aus der Liste
# Falls kein Job fertig ist, wird eine leere Liste zurückgegeben
sub checkAll
{
    my $self = shift;

    my @ret = ();
    my $i;
    my $jobs = $self->{'jobs'};
    for ($i = 0 ; $i < @$jobs ; $i++)
    {
	my $job = $$jobs[$i];
	next if ($job eq undef or $job->processRuns());
                              # gibt's nicht oder läuft noch, nächsten prüfen

	# den neuen Job (anstelle des alten) eintragen und einen Pointer
	# auf den alten, der noch ausgewertet werden muß, in @ret eintragen
	# alten Wert aus der Liste löschen
	$$jobs[$i] = undef;
	push @ret, $job if $job;    # falls wirklich job lief (Eintrag
	                            # kann leer gewesen sein
    }

    return @ret;
}


##################################################
# Überprüft, ob einer der Jobs fertig ist. Liefert einen Pointer auf
# den Job (Typ forkProc) zurück und löscht den Job aus der Liste
# Falls kein Job fertig ist, wird undef zurückgeliefert
sub checkOne
{
    my $self = shift;

    my $i;
    my $jobs = $self->{'jobs'};
    for ($i = 0 ; $i < @$jobs ; $i++)
    {
	my $job = $$jobs[$i];
	next if ($job eq undef or $job->processRuns());
                                      # läuft noch, nächsten prüfen

	# den neuen Job (anstelle des alten) eintragen und einen Pointer
	# auf den alten, der noch ausgewertet werden muß, zurückgeben
	# alten Wert aus der Liste löschen
	$$jobs[$i] = undef;
	return $job;
    }

    return undef;       # nix mehr da
}


##################################################
# Fuegt einen weiteren Job, der parallel abgearbeiten werden soll, hinzu.
# Rückgabewert ist eine Liste:
# 1. Pointer auf den alten Job (Typ forcProc), der dann noch ausgewertet
#    werden muß. Falls kein alter vorhanden war, wird undef zurückgeben.
# 2. Pointer auf den gerade gestarteten Job (Typ forcProc)
sub add
{
    my $self = shift;

    my (%params) = ('-exec'        => undef,
		    '-param'       => [],
		    '-workingDir'  => undef,
		    '-stdin'       => undef,

		    '-stdout'      => undef, # hat Vorrang vor '-outRandom',
		                             # falls gesetzt
		    '-stderr'      => undef, # hat Vorrang vor '-outRandom',
		                             # falls gesetzt
		    '-outRandom'   => undef, # wenn auf String gesetzt,
		                             # (z.B. "/tmp/test") wird
		                             # dieser als Anfang des
		                             # Dateinamens für '-stdout'
		                             # und '-stderr' genommen
		    '-delStdout'   => 'yes', # lösche Datei für stdout
		                             # automatisch

		    '-info'        => undef, # beliebige zusätzliche Info
		    );

    &::checkObjectParams(\%params, \@_, 'parallelForkProc::add',
			 ['-exec']);

    my $p = forkProc->new('-exec'        => $params{'-exec'},
			  '-param'       => $params{'-param'},
			  '-workingDir'  => $params{'-workingDir'},
			  '-stdin'       => $params{'-stdin'},
			  '-stdout'      => $params{'-stdout'},
			  '-outRandom'   => $params{'-outRandom'},
			  '-delStdout'   => $params{'-delStdout'},
			  '-info'        => $params{'-info'},
			  '-prLog'       => $self->{'prLog'},
			  '-prLogError'  => $self->{'prLogError'},

			  '-exitIfError' => $self->{'exitIfError'});

    $self->{'sched'}->reset();
    my $jobs = $self->{'jobs'};
    # den neuen Job (anstelle des alten) eintragen und einen Pointer
    # auf den alten, der noch ausgewertet werden muß, zurückgeben +
    # einen Pointer auf den neuen
    do
    {
	my $i;
	for ($i = 0 ; $i < @$jobs ; $i++)
	{
	    my $job = $$jobs[$i];

	    if ($job eq undef)             # freien gefunden
	    {
		$$jobs[$i] = $p;
		return (undef, $p);
	    }
	    unless ($job->processRuns())     # läuft nicht mehr, nehmen
	    {
		$$jobs[$i] = $p;
		$self->{'jobs'} = $jobs;
		return ($job, $p);
	    }
	}

	$self->{'sched'}->wait();
    } while (42);
}


##################################################
# liefert der Reihe nach Zeiger auf die beendeten Jobs
# wenn alle fertig sind, wird undef geliefert
sub waitForAllJobs
{
    my $self = shift;

    my $jobs = $self->{'jobs'};
    my $i;
    for ($i = 0 ; $i < @$jobs ; $i++)
    {
	my $job = $$jobs[$i];
	next unless $job;        # schon auf undef gesetzt

	$job->wait();            # warten, bis er fertig ist

	$$jobs[$i] = undef;
	return $job;
    }

    return undef;                # nix mehr da
}


##################################################
sub signal
{
    my $self = shift;

    my (%params) = ('-value' => 2);   # default: SIGINT

    &::checkObjectParams(\%params, \@_, 'forkProc:',
			 ['-value']);

    my $job;
    foreach $job (@{$self->{'jobs'}})
    {
	$job->signal('-value' => $params{'-value'})
	    if $job;
    }
}


############################################################
# wartet nach Vorgabe von Parametern in new()
# zählt beim mehrfachen Aufruf die Wartezeit linear hoch, bis Maximalwert
package tinyWaitScheduler;

sub new
{
    my $class = shift;
    my $self = {};

    my (%params) = ('-maxWaitTime'   => 1,     # in seconds (-> add())
		    '-noOfWaitSteps' => 10,
		    '-firstFast'     => 0      # falls 1, beim ersten Mal
		    );                         # nicht warten!

    &::checkObjectParams(\%params, \@_, 'tinyWaitScheduler::new',
			 []);
    &::setParamsDirect($self, \%params);

    $self->{'step'} = $params{'-maxWaitTime'} / $params{'-noOfWaitSteps'};
    
    $self->{'waitTime'} = 0;
    bless $self, $class;
}


##################################################
sub reset
{
    my $self = shift;

    $self->{'waitTime'} = 0;
}


##################################################
sub wait
{
    my $self = shift;

    unless ($self->{'firstFast'})
    {
	$self->{'waitTime'} += $self->{'step'}
            if $self->{'waitTime'} < $self->{'maxWaitTime'};
    }

    select(undef, undef, undef, $self->{'waitTime'});

    if ($self->{'firstFast'})
    {
	$self->{'waitTime'} += $self->{'step'}
            if $self->{'waitTime'} < $self->{'maxWaitTime'};
    }

    return $self->{'waitTime'};
}


1