#
# $Id: qutils.pm,v 1.21 1996/11/13 16:36:04 ejb Exp $
# $Source: /home/ejb/source/perl/modules/RCS/qutils.pm,v $
# $Author: ejb $
#
# This is just a collection of useful functions.
#

package qutils;
my $package = "qutils";

require 5.001;

use strict;

# Mini package for testing
package qutils::test;
sub new { bless {}; }
sub DESTROY { print "*** goodbye qutils::test $$ ***\n"; }

package qutils;
require Exporter;
BEGIN
{
    no strict 'vars';
    @ISA = qw(Exporter);
    @EXPORT_OK = qw(&assert_args $assert_args);
    %EXPORT_TAGS = ('assert_args' => [qw(&assert_args $assert_args)]);
}

my $whoami = $package;

sub set_whoami
{
    $whoami = $_[0];
}

sub timeout
{
    #
    # This routine handles timeouts as well as works around a perl bug
    # present in pre-5.002 perls under Linux.  This bug causes INT,
    # QUIT, and ALRM signal handlers to get messed up after a call to
    # alarm as well as causing SIGALRM to be blocked.  (The workaround
    # is harmless when used unnecessarily.)
    #

    my ($timeout, $f1, $f1args) = @_;
    my $work_around_bug = ($] < 5.002);
    my ($alrm, $int, $quit);
    $alrm = $SIG{'ALRM'};
    if ($work_around_bug)
    {
	($int, $quit) = ($SIG{'INT'}, $SIG{'QUIT'});
    }
    $SIG{'ALRM'} = sub { die "--timeout--\n"; };
    alarm($timeout);
    my $t = undef;
    eval
    {
	# Need to use nested evals to avoid race condition if alarm goes
	# off between termination of eval and resetting of alarm.
	eval { &$f1(@$f1args) };
	$t = $@;
	alarm(0);
	my $oldw = $^W;
	$^W = 0;
	$SIG{'ALRM'} = $alrm;
	$^W = $oldw;
    };
    
    if ($work_around_bug)
    {
	my $oldw = $^W;
	$^W = 0;
	($SIG{'INT'}, $SIG{'QUIT'}) = ($int, $quit);
	$^W = $oldw;
	
	use POSIX qw(sigprocmask SIG_UNBLOCK SIGALRM);
	sigprocmask(&SIG_UNBLOCK(),
		    new POSIX::SigSet(&SIGALRM()),
		    new POSIX::SigSet());
    }

    if ($t)
    {
	if ($t =~ m/--timeout--/)
	{
	    1;
	}
	else
	{
	    die $t;
	}
    }
    else
    {
	0;
    }
}

sub mkdir_p
{
    my $dir = shift;
    my $mode = shift;
    my $cur_path = (($dir =~ s,^/,,) ? "/" : "");
    my @components = split('/', $dir);
    while (@components)
    {
	$cur_path .= shift(@components);
	# It's better to let mkdir return failure if -d $cur_path,
	# but this code is motivated by the fact that in linux, at least
	# version 1.3.84 and earlier, ncpfs gets messed up if you try
	# mkdir `.' or `..'.  Yes, it's a general case to combat a specific
	# problem, but it should be harmless.
	mkdir $cur_path, $mode unless -d $cur_path;
	$cur_path .= "/";
    }
}
 
sub system_pid
{
    #
    # Run a command but save its pid.  Useful so that an abnormal return
    # from system (such as via a die breaking out of an eval containing a
    # system) can occur wihtout loss of the pid.  This routine is used
    # by system_timeout.
    #
    my ($pidp, @rest) = @_;
    my $pid = fork;
    die "$whoami: fork failed: $!\n" if ! defined($pid);
    if ($pid == 0)
    {
	#
	# We must exit with kill 9, $$ if exec fails to avoid
	# having destructors be called before exiting.  Perl doesn't
	# provide anything like _exit for us to use...
	#
	(exec @rest) || kill 9, $$;
    }
    else
    {
	$$pidp = $pid;
	waitpid($pid, 0);
	my $t = $?;
	if ($t !~ m/^\d+$/)
	{
	    warn $t;
	    $t = 255 << 8;
	}
	$t;
    }
}

sub system_timeout
{
    #
    # Run a command with a given timeout, and kill the command if it times out.
    #
    my ($timeout, @rest) = @_;
    my $r;
    my $pid;
    my $t = &timeout($timeout, sub { $r = &system_pid(\$pid, @rest) }, []);
    if ($t)
    {
	kill &POSIX::SIGTERM(), $pid;
	(kill 0, $pid) && (kill &POSIX::SIGKILL(), $pid);
	waitpid($pid, 0);
	undef;
    }
    else
    {
	$r;
    }
}

sub arg_is_ref_to
{
    #
    # True if first argument's type (as returned by ref) matches
    # second argument.  Expected calling sequence:
    # &arg_is_ref_to(ref($something), "something")
    # This routine is tested by the assert_args testing.
    #
    my ($actual, $expected) = @_;
    my $result = 0;
    my $builtin = '^(REF|SCALAR|ARRAY|HASH|CODE|GLOB)\$';

    if ($expected eq "*")
    {
	$result = 1;
    }
    elsif ($actual eq $expected)
    {
	$result = 1;
    }
    elsif ($expected =~ m/$builtin/)
    {
	$result = 0;
    }
    else
    {
	# Traverse the inheritance tree
	my %tried = ();
	my @classes = ($actual);
	while (@classes)
	{
	    my $cur_class = shift(@classes);
	    if (! exists $tried{$cur_class})
	    {
		if ($cur_class eq $expected)
		{
		    $result = 1;
		    last;
		}
		
		$tried{$cur_class} = 1;
		my @isa = (eval "\@${cur_class}::ISA");
		if (defined(@isa))
		{
		    push(@classes, @isa);
		}
	    }
	    
	}
    }

    $result;
}

#
# Put assert_args routines here in special package
#

package qutils::assert;
use Carp;

sub arg_is_type
{
    &qutils::arg_is_ref_to(@_);
}

sub unparse
{
    my $arg = shift;
    (($arg eq "") ? "<non-reference>" :
     ($arg =~ m/^(SCALAR|ARRAY|HASH|CODE|GLOB)$/) ? "$arg reference" :
     $arg);
}

package qutils;

$qutils::assert_args = 0 unless defined($qutils::assert_args);
sub assert_args
{
    package qutils::assert;

    #
    # This routine takes four arguments: a reference to an array of
    # actual arguments (usually \@_), a reference to an array of
    # required argument types (as returned by ref), and a reference to
    # an array of optional argument types, and an optional function
    # name for error messages.	(If the function name is not supplied,
    # it is determined by "caller.")  This can be used to assert that
    # a function was called with the proper arguments.	To make most
    # effective use of this routine, you should include qutils by saying
    #
    # use qutils qw(:assert_args);
    #
    # Then you can set the variable $assert_args to whether or not you
    # want to do this assertion and call conditionally.  The overhead in
    # perl of making this function call is very high, so it should be
    # disabled when not debugging.
    #
    # If f wants to make sure that it is called with a string, an
    # array reference, and an optional potato, it could call
    #
    #  &assert_args(\@_, ["", "ARRAY"], ["potato"]) if $assert_args;
    #
    # If g wanted to make sure it was called with a hash reference only, it
    # could call
    #
    #  &assert_args(\@_, ["HASH"], []) if $assert_args;
    #
    # The special argument type "*" means that any type is valid.
    #

    # in case the caller forgot the if $assert_args;

    return 1 unless $qutils::assert_args;

    push(@_, "") if (@_ == 3);
    if (! ((@_ == 4) &&
	   (ref($_[0]) eq "ARRAY") &&
	   (ref($_[1]) eq "ARRAY") &&
	   (ref($_[2]) eq "ARRAY") &&
	   (ref($_[3]) eq "")))
    {
	confess "$whoami: assert_args takes three ARRAY references and " .
	    "an optional non-reference\n";
    }

    my ($args, $required, $optional, $caller) = (@_, "");
    ((undef, undef, undef, $caller) = (caller(1))) if $caller eq "";
    my $num_args = scalar(@$args);
    my $num_required = scalar(@$required);
    my $num_optional = scalar(@$optional);
    my $min_args = $num_required;
    my $max_args = $num_required + $num_optional;

    if (($num_args < $min_args) || ($num_args > $max_args))
    {
	if ($min_args != $max_args)
	{
	    confess "$whoami: $caller expects between $min_args and " .
		"$max_args arguments\n";
	}
	else
	{
	    confess "$whoami: $caller expects exactly $min_args argument" .
		(($min_args == 1) ? "" : "s") . "\n";
	}
    }

    my @actual_args = @$args;
    my @expected_args = (@$required, @$optional);
    splice(@expected_args, scalar(@actual_args));
    my $argno = 1;
    while (@expected_args)
    {
	my $actual = ref(shift(@actual_args));
	my $expected = shift(@expected_args);
	if (! &arg_is_type($actual, $expected))
	{
	    confess sprintf("$whoami: $caller: argument type mismatch for " .
			    "argument $argno (expected: %s, actual: %s)\n",
			    &unparse($expected), &unparse($actual));
	}
	$argno++;
    }
    1;
}

sub test
{
    &set_whoami("qutils_test");
    shift;
    if ($_[0] eq "timeout")
    {
	my $int;
	$int = sub { print "hello\n"; $SIG{'INT'} = $int; };
	$SIG{'INT'} = $int;
	print "1\n";
	sleep 1;
	print "2\n";
	print "Now hit CTRL-C\n";
	sleep;
	print "3\n";
	&timeout(1, sub { while(1) {}; }, []);
	print "4\n";
	&timeout(1, sub { while(1) {}; }, []);
	print "5\n";
	print "Now hit CTRL-C again\n";
	sleep;
	print "6\n";
	print "Now hit CTRL-C again\n";
	sleep;
	print "7\n";
    }
    elsif ($_[0] eq "mkdir_p")
    {
	&mkdir_p($_[1], 0777);
    }
    elsif ($_[0] eq "system_pid")
    {
	my $pid = 0;
	my $r;
	my $test = new qutils::test;
	print "I am $$\n";
	my $status = sub { print "pid: $pid, r: $r, ?: $?\n"; };
	print "==> running ls\n";
	$r = &system_pid(\$pid, "ls");
	&$status;
	print "==> running exit 1\n";
	$r = &system_pid(\$pid, "sh -c 'exit 1'");
	&$status;
	print "==> running /trash/farbage\n";
	$r = &system_pid(\$pid, "/trash/farbage");
	&$status;
	print "==> running sleep 10 in timeout\n";
	$r = 16059;
	&timeout(1, sub { $r = &system_pid(\$pid, "sleep 10"); }, []);
	system("ps $pid");
	&$status;
    }
    elsif ($_[0] eq "system_timeout")
    {
	my $r;
	$r = &system_timeout(1, "sleep 20");
	print +(defined($r) ? $r : "undef"), "\n";
	$r = &system_timeout(2, "sleep 1");
	print +(defined($r) ? $r : "undef"), "\n";
	$r = &system_timeout(2, "sh -c 'exit 1'");
	print +(defined($r) ? $r : "undef"), "\n";
    }
    elsif ($_[0] eq "assert_args")
    {
	$qutils::assert_args = 1;
	my $f = sub { my $r = eval { &{$_[0]} }; print $@ ? $@ : "$r\n" };
	print "Expect 1\n";
	&$f(sub {&assert_args([1, \@ARGV, "test"],
			      ["", "ARRAY", ""], [],
			      "test")});
	print "Expect 1\n";
	&$f(sub {&assert_args([1, \@ARGV, "test"],
			      ["", "ARRAY", ""], [""],
			      "test")});
	print "Expect 1\n";
	&$f(sub {&assert_args([1, \@ARGV, "test", "quack"],
			      ["", "ARRAY", ""], [""],
			      "test")});
	print "Expect ... exactly 3 ...\n";
	&$f(sub {&assert_args([1, \@ARGV, "test", "quack"],
			      ["", "ARRAY", ""], [],
			      "test")});
	print "Expect 1\n";
	&$f(sub {&assert_args([1, \@ARGV, "test", \%main::ENV],
			      ["", "ARRAY", ""], ["HASH"],
			      "test")});
	print "Expect ... between 3 and 4 ...\n";
	&$f(sub {&assert_args([1, \@ARGV, "test", "quack", "moo"],
			      ["", "ARRAY", ""], [""],
			      "test")});
	print "Expect ... exactly 1 ...\n";
	&$f(sub {&assert_args([\%main::PATH, 1],
			      ["HASH"], [],
			      "test")});
	print "Expect 1\n";
	&$f(sub {&assert_args([\%main::PATH, [1]],
			      ["HASH"], ["ARRAY"],
			      "test")});
	print "Expect 1\n";
	&$f(sub {&assert_args([\%main::PATH],
			      ["HASH"], ["ARRAY"],
			      "test")});
	print "Expect 1\n";
	&$f(sub {&assert_args([bless {}, "potato"],
			      ["potato"], [],
			      "test")});
	print "Expect ... mismatch for argument 1 ... HASH ... potato ...\n";
	&$f(sub {&assert_args([bless {}, "potato"],
			      ["HASH"], [],
			      "test")});
	print "Expect 1\n";
	&$f(sub {&assert_args([bless {}, "potato"],
			      ["*"], [],
			      "test")});
	print "Expect ... __ANON__ ... mismatch for argument " .
	    "1 ... potato ... salad ...\n";
	&$f(sub {&assert_args([bless {}, "salad"],
			      ["potato"], [])});
	@salad::ISA = qw(potato);
	print "Expect 1\n";
	&$f(sub {&assert_args([bless {}, "salad"],
			      ["potato"], [],
			      "test")});
    }
}

1;