ChangeLogTag:Thu Dec 7 16:09:42 2000 Darrell Brunsch <brunsch@uci.edu>

6 files changed, 713 insertions, 0 deletions

diff --git a/bin/PerlACE/ConfigList.pm b/bin/PerlACE/ConfigList.pm
new file mode 100644
index 00000000000..dbfcee5b70b
--- /dev/null
+++ b/bin/PerlACE/ConfigList.pm
@@ -0,0 +1,134 @@
+# $Id$
+
+package PerlACE::ConfigList;
+use strict;
+use FileHandle;
+
+sub new () 
+{
+    my $self = {};
+    @{$self->{MY_CONFIGS}} = @::CONFIGS;
+    bless $self;
+    return $self;
+}
+
+sub my_config_list
+{
+    my $self = shift;
+    if (@_) { @{$self->{MY_CONFIGS}} = @_; }
+    return @{$self->{MY_CONFIGS}};
+}
+
+sub add_one_config ($)
+{
+    my $self = shift;
+    my $newconfig = shift;
+    push @{$self->{MY_CONFIGS}}, $newconfig;
+}
+
+sub check_config (@)
+{
+    my $self = shift;
+    my @testconfigs = @_;
+    my $included = 0;
+    my $excluded = 0;
+    my $noincludes = 1;
+
+    foreach my $config (@testconfigs) {
+        if ($config =~ /^\w/) { $noincludes = 0; }
+        foreach my $myconfig (@{$self->{MY_CONFIGS}}) {
+            if ($config eq "!$myconfig") { $excluded = 1; }
+            if ($config eq $myconfig) { $included = 1; }
+        }
+    }
+    return ($included || $noincludes) && !$excluded;
+}
+
+sub load ($)
+{
+    my $self = shift;
+    my $filename = shift;
+
+    my $fh = new FileHandle;
+    if (!$fh->open ("< $filename")) {
+        print STDERR "Could not open $filename: $!\n";
+        exit (1);
+    }
+
+    while (<$fh>) {
+        chomp;
+	if (/^\s*$/ || /^#/) { 
+            next; 
+        }
+        # compress white space
+	s/\s+/ /g;
+
+        my $entry = '';
+        my $configs = '';
+            
+        ($entry, $configs) = split /:/;
+
+        push @{$self->{ENTRIES}}, $entry;
+	if (defined $configs) {
+            @{$self->{CONFIGS}->{$entry}} =  split (" ", $configs);
+        }
+    }
+
+    $fh->close ();
+}
+
+sub valid_entries () 
+{
+    my $self = shift;
+    my @entries = ();
+
+    foreach my $entry (@{$self->{ENTRIES}}) {
+        if ($self->check_config (@{$self->{CONFIGS}->{$entry}})) {
+            push @entries, $entry;
+        }
+    }
+    return @entries;
+}
+
+sub list_configs ()
+{
+    my $self = shift;
+    my %allconfigs = {};
+    my $list = '';
+
+    foreach my $entry (@{$self->{ENTRIES}}) {
+	
+        foreach my $config (@{$self->{CONFIGS}->{$entry}}) {
+            $config =~ s/!//g;
+            if ($allconfigs{$config} != 1) {
+                $list .= $config.' ';
+                $allconfigs{$config} = 1;
+            }
+        }
+    }
+
+    return $list;
+}
+
+sub dump ()
+{
+    my $self = shift;	
+
+    print "============================================================\n";
+    print "Config\n";
+    foreach my $config (@{$self->{MY_CONFIGS}}) {
+        print $config, "\n";
+    }
+    print "\n";
+    print "Entries\n";
+    foreach my $entry (@{$self->{ENTRIES}}) {
+        print "- ", $entry, ": ";
+        foreach my $config (@{$self->{CONFIGS}->{$entry}}) {
+            print $config, " ";
+        }
+        print "\n";
+    }
+    print "============================================================\n";
+}
+
+1;
\ No newline at end of file
diff --git a/bin/PerlACE/Process.pm b/bin/PerlACE/Process.pm
new file mode 100644
index 00000000000..52df7aa6c8f
--- /dev/null
+++ b/bin/PerlACE/Process.pm
@@ -0,0 +1,36 @@
+# $Id$
+
+package PerlACE::Process;
+
+use strict;
+use English;
+
+$PerlACE::Process::ExeSubDir = './';
+
+### Check for -ExeSubDir commands, store the last one
+my @new_argv = ();
+
+for(my $i = 0; $i <= $#ARGV; ++$i) {
+    if ($ARGV[$i] eq '-ExeSubDir') {  
+        if (defined $ARGV[$i + 1]) {
+            $PerlACE::Process::ExeSubDir = $ARGV[++$i].'/';
+        }
+        else {
+            print STDERR "You must pass a directory with ExeSubDir\n";
+            exit(1);
+        }
+    }
+    else {
+        push @new_argv, $ARGV[$i];
+    }
+}
+@ARGV = @new_argv;
+
+if ($OSNAME eq "MSWin32") {
+	require PerlACE::Process_Win32;
+}
+else {
+	require PerlACE::Process_Unix;
+}
+
+1;
diff --git a/bin/PerlACE/Process_Unix.pm b/bin/PerlACE/Process_Unix.pm
new file mode 100644
index 00000000000..4f5a37ae611
--- /dev/null
+++ b/bin/PerlACE/Process_Unix.pm
@@ -0,0 +1,101 @@
+# $Id$
+
+package PerlACE::Process;
+
+use POSIX "sys_wait_h";
+use Cwd;
+
+### @todo finish
+
+$EXEPREFIX = "./";
+$TARGETHOSTNAME = "localhost";
+
+$cwd = getcwd();
+PerlACE::checkForTarget($cwd);
+
+  for($i = 0; $i <= $#ARGV; $i++) {
+    if ($ARGV[$i] eq '-chorus') {  
+      if (defined $ARGV[$i + 1]) {
+        $::TARGETHOSTNAME = $ARGV[$i + 1];
+        $::EXEPREFIX = "rsh $::TARGETHOSTNAME arun $cwd$::DIR_SEPARATOR";
+      }
+      else {
+        print STDERR "The -chorus option requires " .
+                     "the hostname of the target\n";
+        exit(1);
+      }
+      splice(@ARGV, $i, 2);
+      # Don't break from the loop just in case there
+      # is an accidental duplication of the -chorus option
+    }
+  }
+
+
+sub Create
+{
+  my $name = shift;
+  my $args = shift;
+  my $self = [];
+
+  FORK:
+  {
+    if ($self->[0] = fork)
+    {
+      #parent here
+      bless $self;
+    }
+    elsif (defined $self->[0])
+    {
+      #child here
+      exec $name." ".$args;
+      die "ERROR: exec failed for <$name> <$args>";
+    }
+    elsif ($! =~ /No more process/)
+    {
+      #EAGAIN, supposedly recoverable fork error
+      sleep 5;
+      redo FORK;
+    }
+    else 
+    {
+      # weird fork error
+      print STDERR "ERROR: Can't fork: $!\n";
+    }
+  }
+}
+
+sub Terminate
+{
+  my $self = shift;
+  kill ('TERM', $self->[0]);
+  # print STDERR "Process_Unix::Kill 'TERM' $self->[0]\n";
+}
+
+sub Kill
+{
+  my $self = shift;
+  kill ('KILL', $self->[0]);
+  # print STDERR "Process_Unix::Kill 'TERM' $self->[0]\n";
+}
+
+sub Wait
+{
+  my $self = shift;
+  waitpid ($self->[0], 0);
+}
+
+sub TimedWait
+{
+  my $self = shift;
+  my $maxtime = shift;
+  while ($maxtime-- != 0) {
+    my $pid = waitpid ($self->[0], &WNOHANG);
+    if ($pid != 0 && $? != -1) {
+      return $?;
+    }
+    sleep 1;
+  }
+  return -1;
+}
+
+1;
diff --git a/bin/PerlACE/Process_Win32.pm b/bin/PerlACE/Process_Win32.pm
new file mode 100644
index 00000000000..94a1e1ca2de
--- /dev/null
+++ b/bin/PerlACE/Process_Win32.pm
@@ -0,0 +1,211 @@
+# $Id$
+
+package PerlACE::Process;
+
+use strict;
+use Win32::Process;
+use File::Basename;
+
+###############################################################################
+
+# This is what GetExitCode will return if the process is still running.
+my $STILL_ACTIVE = 259;
+
+###############################################################################
+
+### Constructor
+
+sub new  
+{
+    my $proto = shift;
+    my $class = ref ($proto) || $proto;
+    my $self = {};
+    
+    $self->{RUNNING} = 0;
+    $self->{PROCESS} = undef;
+    $self->{EXECUTABLE} = shift;
+    $self->{ARGUMENTS} = shift;
+    
+    bless ($self, $class);
+    return $self;
+}
+
+###############################################################################
+
+### Some Accessors
+
+sub Executable
+{
+    my $self = shift;
+
+    if (@_ != 0) {
+        $self->{EXECUTABLE} = shift;
+    }
+
+    my $executable = $self->{EXECUTABLE};
+
+    my $basename = basename ($executable);
+    my $dirname = dirname ($executable). '/';
+
+    $executable = $dirname.$PerlACE::Process::ExeSubDir.$basename.".EXE";
+
+    $executable =~ s/\//\\/g;
+
+    return $executable;
+}
+
+sub Arguments
+{
+    my $self = shift;
+
+    if (@_ != 0) {
+        $self->{ARGUMENTS} = shift;
+    }
+	
+    return $self->{ARGUMENTS};
+}
+
+sub CommandLine ()
+{
+    my $self = shift;
+
+    my $commandline = $self->Executable ();
+
+    if (defined $self->{ARGUMENTS}) {
+        $commandline .= ' '.$self->{ARGUMENTS};
+    }
+	
+    return $commandline;
+}
+
+###############################################################################
+
+### Spawning processes
+
+
+# Spawn the process and continue.
+
+sub Spawn ()
+{
+    my $self = shift;
+
+    if ($self->{RUNNING} == 1) {
+        print STDERR "ERROR: Cannot Spawn: <$self->{EXECUTABLE}> ",
+                     "already running\n";
+	return -1;
+    }
+
+    if (!defined $self->{EXECUTABLE}) {
+        print STDERR "ERROR: Cannot Spawn: No executable specified\n";
+	    return -1;
+    }
+
+    Win32::Process::Create ($self->{PROCESS}, 
+                            $self->Executable (),
+                            $self->CommandLine (), 
+                            0, 
+                            0, 
+                            '.');
+
+    my $status = 0;
+
+    Win32::Process::GetExitCode ($self->{PROCESS}, $status);
+
+    if ($status != $STILL_ACTIVE) {
+        print STDERR "ERROR: Spawn failed for <", $self->CommandLine (), ">\n";
+        exit $status;
+    }
+
+    $self->{RUNNING} = 1;
+}
+
+
+# Wait for the process to exit or kill after a time period
+
+sub WaitKill ($)
+{
+    my $self = shift;
+    my $maxtime = shift;
+
+    my $status = $self->TimedWait ($maxtime);
+
+    if ($status == -1) {
+        print STDERR "ERROR: $self->{EXECUTABLE} timedout\n";
+        $self->Kill (); 
+        # Don't need to Wait since we are on Win32
+    }
+	
+    $self->{RUNNING} = 0;
+
+    return $status;
+}
+
+
+# Do a Spawn and immediately WaitKill
+
+sub SpawnWaitKill ($)
+{
+    my $self = shift;
+    my $maxtime = shift;
+
+    if ($self->Spawn () == -1) {
+        return -1;
+    }
+
+    return $self->WaitKill ($maxtime);
+}
+
+
+# Kill the process
+
+sub Kill ()
+{
+    my $self = shift;
+    Win32::Process::Kill ($self->{PROCESS}, -1);
+	$self->{RUNNING} = 0;
+}
+
+
+# Termnate the process
+
+sub Terminate ()
+{
+    my $self = shift;
+    Win32::Process::Kill ($self->{PROCESS}, -1);
+	$self->{RUNNING} = 0;
+}
+
+
+# Wait until a process exits.
+
+sub Wait ()
+{
+    my $self = shift;
+
+    if ($self->{RUNNING}) {
+        Win32::Process::Wait ($self->{PROCESS}, INFINITE);
+    }
+}
+
+
+# Wait for a process to exit with a timeout
+
+sub TimedWait
+{
+    my $self = shift;
+    my $maxtime = shift;
+
+    if (!$self->{RUNNING}) {
+        return 0;
+    }
+
+    if (Win32::Process::Wait ($self->{PROCESS}, $maxtime * 1000) == 0) {
+        return -1;
+    }
+
+    my $status = 0;
+    Win32::Process::GetExitCode ($self->{PROCESS}, $status);
+    return $status;
+}
+
+1;
diff --git a/bin/PerlACE/Run_Test.pm b/bin/PerlACE/Run_Test.pm
new file mode 100644
index 00000000000..f41bfccf8bc
--- /dev/null
+++ b/bin/PerlACE/Run_Test.pm
@@ -0,0 +1,86 @@
+# $Id$
+
+# This module contains a few miscellanous functions and some
+# startup ARGV processing that is used by all tests.
+
+# @todo Move config into Config
+@CONFIGS = ();
+
+use PerlACE::Process;
+package PerlACE;
+
+sub CheckForConfig
+{
+    my @new_argv = ();
+
+    for($i = 0; $i <= $#ARGV; ++$i) {
+        if ($ARGV[$i] eq '-Config') {  
+            if (defined $ARGV[$i + 1]) {
+                push @::CONFIGS, $ARGV[++$i];
+            }
+            else {
+              print STDERR "You must pass a directory with Config\n";
+              exit(1);
+            }
+        }
+        else {
+            push @new_argv, $ARGV[$i];
+        }
+    }
+    @ARGV = @new_argv;
+}
+
+CheckForConfig ();
+
+
+
+# Returns a unique id, uid for unix, last digit of IP for NT
+sub uniqueid
+{
+  if ($^O eq "MSWin32")
+  {
+    my $uid = 1;
+
+    open (IPNUM, "ipconfig|") || die "Can't run ipconfig: $!\n";
+
+    while (<IPNUM>)
+    {
+      if (/Address/)
+      {
+        $uid = (split (/: (\d+)\.(\d+)\.(\d+)\.(\d+)/))[4];
+      }
+    }
+
+    close IPNUM;
+
+    return $uid;
+  }
+  else
+  {
+    return getpwnam (getlogin ());
+  }
+}
+
+# Waits until a file exists
+sub waitforfile
+{
+  local($file) = @_;
+  sleep 1 while (!(-e $file && -s $file));
+}
+
+sub waitforfile_timed
+{
+  my $file = shift;
+  my $maxtime = shift;
+  while ($maxtime-- != 0) {
+    if (-e $file && -s $file) {
+      return 0;
+    }
+    sleep 1;
+  }
+  return -1;
+}
+
+$sleeptime = 5;
+
+1;
diff --git a/docs/run_test.txt b/docs/run_test.txt
new file mode 100644
index 00000000000..f0f8a35238d
--- /dev/null
+++ b/docs/run_test.txt
@@ -0,0 +1,145 @@
+/**
+@page run_test_howto How to write a run_test.pl
+
+ACE/TAO's auto_builds expect run_test.pl's to follow some guidelines
+that are needed to keep the auto_builds from hanging and to make
+sure the run_test.pl works on all platforms
+
+- The run_test must not hang or block.
+- The run_test must clean up any temporary files when it is done.  
+- The run_test must not require any user input
+- The run_test should return a non-zero value if the test failed
+
+Following is an example
+
+@subsection example Example
+
+@verbatim
+eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}'
+    & eval 'exec perl -S $0 $argv:q'
+    if 0;
+
+# $Id$
+# -*- perl -*-
+
+use lib '../../../bin';
+use PerlACE::Run_Test;
+use Cwd;
+
+$server_ior = $getcwd . "/server.ior";
+unlink $server_ior;
+
+$SV = new PerlACE::Process ("server", "-o $server_ior");
+
+$SV->Spawn ();
+
+if (PerlACE::waitforfile_timed ($server_ior, 5) == -1) {
+    print STDERR "ERROR: cannot find file <$server_ior>\n";
+    $SV->Kill (); $SV->TimedWait (1);
+    exit 1;
+} 
+
+$CL = new PerlACE::Process ("client", " -k file://$server_ior ");
+
+$client = $CL->SpawnWaitKill (60);
+$server = $SV->WaitKill (5);
+
+unlink $server_ior;
+ 
+if ($server != 0 || $client != 0) {
+    exit 1;
+}
+
+exit 0;
+@endverbatim
+
+@subsection details Example Details
+
+@verbatim
+eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}'
+    & eval 'exec perl -S $0 $argv:q'
+    if 0;
+
+# $Id$
+@endverbatim
+
+This is the standard header stuff.  The eval is a trick used
+to get the perl script to run if it a unix shell treats it as
+a shell script.
+
+The CVS ID string is the usual one we put in.
+
+@verbatim
+use lib '../../../bin';
+use PerlACE::Run_Test;
+@endverbatim
+
+The use lib line is used to tell Perl where the PerlACE modules are.
+It should be a relative path to the bin directory.
+
+And PerlACE::Run_Test is a module to be used by all run_test.pl's.
+It does a couple of things, including parsing some common command
+line arguments (like -Config and -ExeSubDir) and also brings in
+the PerlACE::Process module.
+
+@verbatim
+use Cwd;
+
+$server_ior = $getcwd . "/server.ior";
+
+unlink $server_ior;
+@endverbatim
+
+Because of the way tests work on chorus, we need to have a fully 
+qualified path to all *.ior and *.conf files.  We unlink the file
+immediately because we use PerlACE::waitforfile_timed later.
+
+@verbatim
+$SV = new PerlACE::Process ("server", "-o $server_ior");
+
+$SV->Spawn ();
+@endverbatim
+
+The PerlACE::Process is constructed with an executable and 
+arguments.  @note Unlike the old Process module, the process
+isn't started until one of the Spawn's is called.
+
+@verbatim
+if (PerlACE::waitforfile_timed ($server_ior, 5) == -1) {
+    print STDERR "ERROR: cannot find file <$server_ior>\n";
+    $SV->Kill (); $SV->TimedWait (1);
+    exit 1;
+} 
+@endverbatim
+
+The PerlACE::waitforfile_timed method waits until the file is
+created.  In this way, we know when to start the client.
+
+@verbatim
+$CL = new PerlACE::Process ("client", " -k file://$server_ior ");
+
+$client = $CL->SpawnWaitKill (60);
+$server = $SV->WaitKill (5);
+@endverbatim
+
+Here are two more methods on the PerlACE::Process object.
+SpawnWaitKill will start the process and wait for the specified
+number of seconds for the process to end.  If the time limit
+is reached, it will kill the process.  WaitKill will do the same,
+but is used after the process is already spawned.
+
+@verbatim
+unlink $server_ior;
+ 
+if ($server != 0 || $client != 0) {
+    exit 1;
+}
+ 
+exit 0;
+@endverbatim
+
+And finally, we just check the return codes of the server and 
+client and return 1 from this perl script if they aren't 0.
+
+This return code is used by the auto_run_tests.pl script.
+*/
\ No newline at end of file