diff options
Diffstat (limited to 'ACE/bin/PerlACE')
| -rw-r--r-- | ACE/bin/PerlACE/ConfigList.pm | 176 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/MSProject.pm | 393 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/MSProject/DSP.pm | 28 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/MSProject/VCP.pm | 30 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/Makefile.am | 23 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/Process.pm | 65 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/ProcessLVRT.pm | 375 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/ProcessVX.pm | 252 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/ProcessVX_Unix.pm | 486 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/ProcessVX_Win32.pm | 434 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/Process_Unix.pm | 526 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/Process_VMS.pm | 358 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/Process_Win32.pm | 405 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/Run_Test.pm | 246 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/TestTarget.pm | 87 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/TestTarget_LVRT.pm | 161 | ||||
| -rw-r--r-- | ACE/bin/PerlACE/perlace.mpc | 13 |
17 files changed, 0 insertions, 4058 deletions
diff --git a/ACE/bin/PerlACE/ConfigList.pm b/ACE/bin/PerlACE/ConfigList.pm deleted file mode 100644 index 023e2f8cc9c..00000000000 --- a/ACE/bin/PerlACE/ConfigList.pm +++ /dev/null @@ -1,176 +0,0 @@ -# $Id$ - -package PerlACE::ConfigList; -use strict; -use FileHandle; - -@PerlACE::ConfigList::Configs = (); -@PerlACE::ConfigList::Excludes = (); - -my @new_argv = (); - -for(my $i = 0; $i <= $#ARGV; ++$i) { - if ($ARGV[$i] eq '-Config') { - if (defined $ARGV[$i + 1]) { - push @PerlACE::ConfigList::Configs, $ARGV[++$i]; - } - else { - print STDERR "You must pass a configuration with -Config\n"; - exit(1); - } - } - elsif ($ARGV[$i] eq '-Exclude') { - if (defined $ARGV[$i + 1]) { - push @PerlACE::ConfigList::Excludes, $ARGV[++$i]; - } - else { - print STDERR "You must pass an exclude pattern with -Exclude\n"; - exit(1); - } - } - else { - push @new_argv, $ARGV[$i]; - } -} -@ARGV = @new_argv; - - -sub new () -{ - my $self = {}; - @{$self->{MY_CONFIGS}} = @PerlACE::ConfigList::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 $the_config_allows_this = 1; # default case is true - - # Go though each ID on the line in turn... - foreach my $config (@testconfigs) { - my $required_found = !($config =~ /^\w/); - foreach my $myconfig (@{$self->{MY_CONFIGS}}) { - if ($config eq "!$myconfig") { $the_config_allows_this = 0; } - if ($config eq $myconfig) { $required_found = 1; } - } - if (!$required_found) { $the_config_allows_this = 0; } - } - return $the_config_allows_this; -} - -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 /:/; - - # remove trailing white spaces - $entry =~ s/\s+$//; - - push @{$self->{ENTRIES}}, $entry; - if (defined $configs) { - @{$self->{CONFIGS}->{$entry}} = split (" ", $configs); - } - } - - $fh->close (); -} - -sub valid_entries () -{ - my $self = shift; - my @entries = (); - my $exclude = 0; - - foreach my $entry (@{$self->{ENTRIES}}) { - $exclude = 0; - foreach my $expat (@PerlACE::ConfigList::Excludes) { - if ($entry =~ /$expat/) { - $exclude = 1; - last; - } - } - if (!$exclude && $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; diff --git a/ACE/bin/PerlACE/MSProject.pm b/ACE/bin/PerlACE/MSProject.pm deleted file mode 100644 index 86e6548456a..00000000000 --- a/ACE/bin/PerlACE/MSProject.pm +++ /dev/null @@ -1,393 +0,0 @@ -# $Id$ - -package PerlACE::MSProject; - -use strict; -use FileHandle; - -############################################################################### - -# Constructor - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = {}; - - $self->{FILENAME} = shift; - $self->{VERSION} = undef; - $self->{NAME} = undef; - %{$self->{CONFIGS}} = (); - - bless ($self, $class); - return $self; -} - -############################################################################### - -# Accessors - -sub Filename -{ - my $self = shift; - - if (@_ != 0) { - $self->{FILENAME} = shift; - } - - return $self->{FILENAME}; -} - -sub Version () -{ - my $self = shift; - return $self->{VERSION}; -} - -sub Name () -{ - my $self = shift; - return $self->{NAME}; -} - -sub Configs () -{ - my $self = shift; - return keys %{$self->{CONFIGS}}; -} - -sub DepOutputFile ($) -{ - my $self = shift; - my $config = shift; - - if (!defined $config) { - print STDERR "Error: No configuration specified\n"; - return; - } - - my $name = $self->OutputFile ($config); - - if ($name =~ m/\.dll$/) { - $name = $self->LibraryFile ($config); - } - - $name =~ s/.*\\//; # / <- For devenv - $name =~ s/.*\///; - - return $name; -} - -sub OutputFile ($) -{ - my $self = shift; - my $config = shift; - - if (!defined $config) { - print STDERR "Error: No configuration specified\n"; - return; - } - - if (%{$self->{CONFIGS}}->{$config}->{LINK} =~ m/out\:\"([^\"]*)\"/) { - return $1; - } - elsif (defined $self->Name ()) { - my $filename = $self->Filename; - my $ext = ""; - - if (%{$self->{CONFIGS}}->{$config}->{LINK} =~ m/\/dll/) { - $ext = ".dll"; - } - elsif (%{$self->{CONFIGS}}->{$config}->{LINK} =~ m/\/subsystem\:/) { - $ext = ".exe"; - } - else { - $ext = ".lib"; - } - - $filename =~ s/\.[^\.]*$/$ext/; - return $filename; - } -} - - -sub LibraryFile ($) -{ - my $self = shift; - my $config = shift; - my $dll = undef; - - if (!defined $config) { - print STDERR "Error: No configuration specified\n"; - return; - } - - if ($self->OutputFile ($config) =~ m/([^\/\\]*)\.dll$/i) { - $dll = $1; - } - - if (defined $dll) { - if (%{$self->{CONFIGS}}->{$config}->{LINK} =~ m/implib\:\"([^\"]*)\"/i) { - return $1; - } - else { - $dll =~ s/.*\\//ig; # / <- Just here to fix color coding in devenv beta - return $self->OutputDir ($config). $dll . ".lib"; - } - } -} - -sub OutputDir ($) -{ - my $self = shift; - my $config = shift; - - if (!defined $config) { - print STDERR "Error: No configuration specified\n"; - return; - } - - return %{$self->{CONFIGS}}->{$config}->{OUTPUTDIR}; -} - -sub IntermidiateDir ($) -{ - my $self = shift; - my $config = shift; - - if (!defined $config) { - print STDERR "Error: No configuration specified\n"; - return; - } - - return %{$self->{CONFIGS}}->{$config}->{INTERMEDIATEDIR}; -} - -sub TargetDir ($) -{ - my $self = shift; - my $config = shift; - - if (!defined $config) { - print STDERR "Error: No configuration specified\n"; - return; - } - - return %{$self->{CONFIGS}}->{$config}->{TARGETDIR}; -} - -sub CPPOptions ($) -{ - my $self = shift; - my $config = shift; - - if (!defined $config) { - print STDERR "Error: No configuration specified\n"; - return; - } - - return %{$self->{CONFIGS}}->{$config}->{CPP}; -} - -sub LINKOptions ($) -{ - my $self = shift; - my $config = shift; - - if (!defined $config) { - print STDERR "Error: No configuration specified\n"; - return; - } - - return %{$self->{CONFIGS}}->{$config}->{LINK}; -} - -sub Libs($) -{ - my $self = shift; - my $config = shift; - - if (!defined $config) { - print STDERR "Error: No configuration specified\n"; - return; - } - - return %{$self->{CONFIGS}}->{$config}->{LIBS}; -} - -sub UsesTAOIDL () -{ - my $self = shift; - - return $self->{TAOIDL}; -} - -sub Compiler () -{ - my $self = shift; - - return $self->{COMPILER}; -} - -############################################################################### - -# Big methods - -sub Load () -{ - my $self = shift; - my $config = "Unknown"; - - $self->{valid} = 0; - - my $fh = new FileHandle; - - unless ($fh->open ("<" . $self->{FILENAME})) { - print "Could not open file ", $self->{FILENAME}, ": ", $_; - return; - } - - while (<$fh>) { - if (m/^\#.*Project File - Name=\"([^\"]*)\"/) { - $self->{NAME} = $1; - } - - if (m/^\#.*Format Version (.*)/) { - $self->{VERSION} = $1; - } - - # Check for configurations - - if (m/^\!.*IF \"\$\(CFG\)\" == \".* - (.*)$\"/) { - $config = $1; - } - elsif (m/^\!ENDIF$/) { - $config = ""; - } - - # Check for directories - - if (m/\# PROP Output_Dir \"(.*)\"/) { - %{$self->{CONFIGS}}->{$config}->{OUTPUTDIR} = $1; - } - elsif (m/\# PROP Intermediate_Dir \"(.*)\"/) { - %{$self->{CONFIGS}}->{$config}->{INTERMEDIATEDIR} = $1; - } - elsif (m/\# PROP Target_Dir \"(.*)\"/) { - %{$self->{CONFIGS}}->{$config}->{TARGETDIR} = $1; - } - - # Look at CPP options - - if (m/\# ADD BASE CPP(.*)$/ || m/\# ADD CPP(.*)$/) { - my @flags = split (/ \//, $1); - - foreach my $flag (@flags) { - if ($flag && %{$self->{CONFIGS}}->{$config}->{CPP} !~ m/$flag/) { - %{$self->{CONFIGS}}->{$config}->{CPP} .= " /$flag"; - } - } - } - elsif (m/\# SUBTRACT CPP(.*)$/ || m/\# SUBTRACT BASE CPP(.*)$/) { - my @flags = split (/ \//, $1); - - foreach my $flag (@flags) { - if ($flag && %{$self->{CONFIGS}}->{$config}->{CPP} =~ m/$flag/) { - %{$self->{CONFIGS}}->{$config}->{CPP} =~ s/ \/$flag//g; - } - } - } - - # Look at LINK32 options - - if (m/\# ADD BASE LINK32(.*)$/ || m/\# ADD LINK32(.*)$/ - || m/\# ADD BASE LIB32(.*)$/ || m/\# ADD LIB32(.*)$/) { - my @flags = split (/ \//, $1); - - foreach my $flag (@flags) { - my $found = 0; - my @libs = split (/ /, $flag); - - foreach my $lib (@libs) { - if ($lib =~ m/\.lib$/) { - if (%{$self->{CONFIGS}}->{$config}->{LIBS} !~ m/\Q$lib\E/) { - %{$self->{CONFIGS}}->{$config}->{LIBS} .= " $lib"; - } - $found = 1; - } - } - - if (!$found && $flag) { - my $shortflag = $flag; - if ($flag =~ m/^(.*)\:/) { - $shortflag = $1; - } - - if (%{$self->{CONFIGS}}->{$config}->{LINK} !~ m/ \/$shortflag/) { - %{$self->{CONFIGS}}->{$config}->{LINK} .= " /$flag"; - } - } - } - } - elsif (m/\# SUBTRACT BASE LINK32(.*)$/ || m/\# SUBTRACT LINK32(.*)$/ - || m/\# SUBTRACT BASE LIB32(.*)$/ || m/\# SUBTRACT LIB32(.*)$/) { - my @flags = split (/ \//, $1); - - foreach my $flag (@flags) { - my $shortflag = $flag; - if ($flag =~ m/^(.*)\:/) { - $shortflag = $1; - } - - if ($flag && %{$self->{CONFIGS}}->{$config}->{LINK} =~ m/ (\/$shortflag\:[^ ]*)/) { - %{$self->{CONFIGS}}->{$config}->{LINK} =~ s/ \Q$1\E//ig; - } - } - } - - if (m/^\# Name \".* - (.*)\"/ && defined %{$self->{CONFIGS}}->{"Unknown"}) { - %{$self->{CONFIGS}}->{$1} = %{$self->{CONFIGS}}->{"Unknown"}; - delete %{$self->{CONFIGS}}->{"Unknown"}; - } - - if (m/tao\_idl/ && m/\$\(InputName\)\.idl/ || m/tao\_idl/ && m/\$\(InputPath\)/) { - $self->{TAOIDL} = 1; - } - } - $fh->close (); - $self->{valid} = 1; -} - -############################################################################### - -# Build functions - -sub Build ($) -{ - my $self = shift; - my ($config) = @_; - - my $command = $self->Compiler () . " " . $self->Filename () - . " /USEENV" - . " /MAKE \"" . $self->Name () - . " - " . $config . "\""; - - system $command; -} - -sub Clean ($) -{ - my $self = shift; - my ($config) = @_; - - my $command = $self->Compiler () . " " . $self->Filename () - . " /USEENV" - . " /MAKE \"" . $self->Name () - . " - " . $config . "\" /CLEAN"; - - system $command; -} - - -1;
\ No newline at end of file diff --git a/ACE/bin/PerlACE/MSProject/DSP.pm b/ACE/bin/PerlACE/MSProject/DSP.pm deleted file mode 100644 index b7ca0276a82..00000000000 --- a/ACE/bin/PerlACE/MSProject/DSP.pm +++ /dev/null @@ -1,28 +0,0 @@ -# $Id$ - -package PerlACE::MSProject::DSP; - -use strict; -use PerlACE::MSProject; - -our @ISA = ("PerlACE::MSProject"); - -############################################################################### - -# Constructor - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = $class->SUPER::new (@_); - - $self->{COMPILER} = "msdev.com"; - - bless ($self, $class); - return $self; -} - -############################################################################### - -1;
\ No newline at end of file diff --git a/ACE/bin/PerlACE/MSProject/VCP.pm b/ACE/bin/PerlACE/MSProject/VCP.pm deleted file mode 100644 index 8377d22788b..00000000000 --- a/ACE/bin/PerlACE/MSProject/VCP.pm +++ /dev/null @@ -1,30 +0,0 @@ -# $Id$ - -package PerlACE::MSProject::VCP; - -use strict; -use PerlACE::MSProject; - -our @ISA = ("PerlACE::MSProject"); - -############################################################################### - -# Constructor - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = $class->SUPER::new (@_); - - $self->{COMPILER} = "evc.com"; - - bless ($self, $class); - return $self; -} - -############################################################################### - -# Accessors - -1;
\ No newline at end of file diff --git a/ACE/bin/PerlACE/Makefile.am b/ACE/bin/PerlACE/Makefile.am deleted file mode 100644 index d02bf527aa5..00000000000 --- a/ACE/bin/PerlACE/Makefile.am +++ /dev/null @@ -1,23 +0,0 @@ -## Process this file with automake to create Makefile.in -## -## $Id$ -## -## This file was generated by MPC. Any changes made directly to -## this file will be lost the next time it is generated. -## -## MPC Command: -## /acebuilds/ACE_wrappers-repository/bin/mwc.pl -include /acebuilds/MPC/config -include /acebuilds/MPC/templates -feature_file /acebuilds/ACE_wrappers-repository/local.features -noreldefs -type automake -exclude build,Kokyu - - -## Makefile.PerlACE.am - -noinst_SCRIPTS = ConfigList.pm Process.pm Process_Unix.pm Process_Win32.pm Run_Test.pm - - -## Clean up template repositories, etc. -clean-local: - -rm -f *~ *.bak *.rpo *.sym lib*.*_pure_* core core.* - -rm -f gcctemp.c gcctemp so_locations *.ics - -rm -rf cxx_repository ptrepository ti_files - -rm -rf templateregistry ir.out - -rm -rf ptrepository SunWS_cache Templates.DB diff --git a/ACE/bin/PerlACE/Process.pm b/ACE/bin/PerlACE/Process.pm deleted file mode 100644 index 130df8166c5..00000000000 --- a/ACE/bin/PerlACE/Process.pm +++ /dev/null @@ -1,65 +0,0 @@ -# $Id$ - -package PerlACE::Process; - -use strict; -use English; -use POSIX qw(:time_h); - -$PerlACE::Process::ExeSubDir = './'; - -sub delay_factor { - my($lps) = 128; - my($factor) = 1; - - ## Keep increasing the loops per second until the amount of time - ## exceeds the number of clocks per second. The original code - ## did not multiply $ticks by 8 but, for faster machines, it doesn't - ## seem to return false values. The multiplication is done to minimize - ## the amount of time it takes to determine the correct factor. - while(($lps <<= 1)) { - my($ticks) = clock(); - for(my $i = $lps; $i >= 0; $i--) { - } - $ticks = clock() - $ticks; - if ($ticks * 8 >= CLOCKS_PER_SEC) { - $factor = 500000 / (($lps / $ticks) * CLOCKS_PER_SEC); - last; - } - } - - return $factor; -} - -### 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; - -$PerlACE::Process::WAIT_DELAY_FACTOR = $ENV{"ACE_RUNTEST_DELAY"}; - -if ($OSNAME eq "MSWin32") { - require PerlACE::Process_Win32; -} -elsif ($OSNAME eq "VMS") { - require PerlACE::Process_VMS; -} -else { - require PerlACE::Process_Unix; -} - -1; diff --git a/ACE/bin/PerlACE/ProcessLVRT.pm b/ACE/bin/PerlACE/ProcessLVRT.pm deleted file mode 100644 index edd0d9f81a4..00000000000 --- a/ACE/bin/PerlACE/ProcessLVRT.pm +++ /dev/null @@ -1,375 +0,0 @@ -# $Id$ -# -# ProcessLVRT - how to run ACE+TAO tests on a LabVIEW RT target. -# Tests on LabVIEW RT are not executables - LabVIEW RT can't start plain -# executables; the tests are built/packaged as DLLs and loaded and executed -# from a DLL loaded at LabVIEW RT boot time. The DLL on the target listens -# on a TCP port (8888 by default) for connections from the host. Host requests -# actions using text commands to the target. -# -# NOTE: This module requires the Net-Telnet Perl module. -# -# We can FTP files to and from the LabVIEW target, but there's no NFS or -# SMB shares. - -package PerlACE::ProcessLVRT; -our @ISA = "PerlACE::Process"; - -use strict; -use Cwd; -use English; -use File::Basename; -use Net::FTP; -use Net::Telnet; -use POSIX qw(:time_h); - -$PerlACE::ProcessLVRT::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::ProcessLVRT::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; - -### Constructor and Destructor - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = {}; - - $self->{EXECUTABLE} = shift; - $self->{ARGUMENTS} = shift; - $self->{RUNNING} = 0; - $self->{IGNOREEXESUBDIR} = 1; - $self->{FTP} = undef; - $self->{TARGET} = undef; - $self->{REBOOT_CMD} = $ENV{"ACE_REBOOT_LVRT_CMD"}; - if (!defined $self->{REBOOT_CMD}) { - $self->{REBOOT_CMD} = 'I_Need_A_Reboot_Command'; - } - $self->{REBOOT_TIME} = $ENV{"ACE_LVRT_REBOOT_TIME"}; - if (!defined $self->{REBOOT_TIME}) { - $self->{REBOOT_TIME} = 200; - } - - bless ($self, $class); - return $self; -} - -sub DESTROY -{ - my $self = shift; - - if ($self->{RUNNING} == 1) { - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> still running upon object destruction\n"; - $self->Kill (); - } - - # Reboot if needed; set up clean for the next test. - if ($self->{NEED_REBOOT} == 1 && $self->{REBOOT_CMD}) { - print STDERR "Attempting to reboot target...\n"; - system ($self->{REBOOT_CMD}); - sleep ($self->{REBOOT_TIME}); - } - - if (defined $self->{FTP}) { - $self->{FTP}->close; - } - if (defined $self->{TARGET}) { - $self->{TARGET}->close; - } -} - -############################################################################### - -# Adjust executable name for LabVIEW RT testing needs. These tests are DLLs. - -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.".DLL"; - $executable =~ s/\//\\/g; # / <- # color coding issue in devenv - - return $executable; -} - -sub Arguments -{ - my $self = shift; - - if (@_ != 0) { - $self->{ARGUMENTS} = shift; - } - - return $self->{ARGUMENTS}; -} - -sub CommandLine () -{ - my $self = shift; - - my $commandline = "run " . basename($self->Executable(), ".dll"); - if (defined $self->{ARGUMENTS}) { - $commandline .= ' '.$self->{ARGUMENTS}; - } - - return $commandline; -} - -############################################################################### - -# 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; - } - - if ($self->{IGNOREEXESUBDIR} == 0) { - if (!-f $self->Executable ()) { - print STDERR "ERROR: Cannot Spawn: <", $self->Executable (), - "> not found\n"; - return -1; - } - } - - my $targethost; - if (defined $ENV{'ACE_RUN_LVRT_TGTHOST'}) { - $targethost = $ENV{'ACE_RUN_LVRT_TGTHOST'}; - } - else { - print STDERR "You must define target hostname/IP with ", - "ACE_RUN_LVRT_TGTHOST\n"; - return -1; - } - my $targetport; - if (defined $ENV{'ACE_RUN_LVRT_TGTPORT'}) { - $targetport = $ENV{'ACE_RUN_LVRT_TGTPORT'}; - } - else { - $targetport = 8888; - } - - my $status = 0; - - my $program = $self->Executable (); - my $cwdrel = dirname ($program); - if (length ($cwdrel) > 0) { - $cwdrel = File::Spec->abs2rel( cwd(), $ENV{"ACE_ROOT"} ); - } - else { - $cwdrel = File::Spec->abs2rel( $cwdrel, $ENV{"ACE_ROOT"} ); - } - - $self->{FTP} = new Net::FTP ($targethost); - if (!defined $self->{FTP}) { - print STDERR "$@\n"; - $self->{NEED_REBOOT} = 1; - return -1; - } - $self->{FTP}->login("",""); - $self->{FTP}->cwd("/ni-rt"); - $self->{FTP}->binary(); - $self->{FTP}->put($program); - - $self->{TARGET} = new Net::Telnet(Timeout => 600, Errmode => 'return'); - if (!$self->{TARGET}->open(Host => $targethost, Port => $targetport)) { - print STDERR "ERROR: target $targethost:$targetport: ", - $self->{TARGET}->errmsg(), "\n"; - $self->{NEED_REBOOT} = 1; - $self->{FTP}->delete($program); - return -1; - } - my $cmdline = $self->CommandLine(); - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "-> $cmdline\n"; - } - $self->{TARGET}->print("$cmdline"); - my $reply; - $reply = $self->{TARGET}->getline(); - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "<- $reply\n"; - } - if ($reply eq "OK\n") { - $self->{RUNNING} = 1; - return 0; - } - print STDERR "ERROR: can't $cmdline: " . $reply . "\n"; - $self->{FTP}->delete($program); - $self->{NEED_REBOOT} = 1; - return -1; -} - - -# Wait for the process to exit or kill after a time period - -sub WaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - my $status = $self->TimedWait ($timeout); - - if ($status == -1) { - print STDERR "ERROR: $self->{EXECUTABLE} timedout\n"; - $self->{NEED_REBOOT} = 1; - $self->Kill (); - } - - $self->{RUNNING} = 0; - - # Now get the log file from the test, and delete the test from the target. - # The FTP session should still be open. - my $program = $self->Executable (); - my $logname = basename($program,".dll") . ".log"; - $program = basename($program); - $self->{FTP}->delete($program); - $self->{FTP}->cwd("\\ni-rt\\system\\log"); - $self->{FTP}->get($logname,"log\\$logname"); - $self->{FTP}->delete($logname); - - return $status; -} - - -# Do a Spawn and immediately WaitKill - -sub SpawnWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->Spawn () == -1) { - return -1; - } - - return $self->WaitKill ($timeout); -} - -sub TerminateWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->{RUNNING}) { - print STDERR "INFO: $self->{EXECUTABLE} being killed.\n"; - $self->Kill(); - } - - return $self->WaitKill ($timeout); -} - -sub Kill () -{ - my $self = shift; - - if ($self->{RUNNING}) { - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "-> kill\n"; - } - $self->{TARGET}->print("kill"); - # Just wait for any reply; don't care what it is. - my $reply = $self->{TARGET}->getline(); - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "<- $reply\n"; - } - } - - $self->{RUNNING} = 0; -} - -# Wait until a process exits. -# return -1 if the process is still alive. -sub Wait ($) -{ - my $self = shift; - my $timeout = shift; - if (!defined $timeout || $timeout < 0) { - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "-> wait\n"; - } - $self->{TARGET}->print("wait"); - my $reply = $self->{TARGET}->getline(); - $self->{RUNNING} = 0; - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "<- $reply\n"; - } - return 0+ $reply; - } else { - return TimedWait($self, $timeout); - } - -} - -sub TimedWait ($) -{ - my $self = shift; - my $timeout = shift; - my $reply; - if (!$self->{RUNNING}) { - return -1; - } - -CHECK: - while ($timeout > 0) { - $self->{TARGET}->print ("status"); - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "-> status\n"; - } - $reply = $self->{TARGET}->getline(Timeout => $timeout); - if (!defined $reply) { - last CHECK; - } - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "<- $reply\n"; - } - if ($reply =~ /^RUNNING/) { - sleep 2; - $timeout -= 2; - next CHECK; - } - # Have a status; return it. - $self->{RUNNING} = 0; - return 0+ $reply; - } - - return -1; -} - -1; diff --git a/ACE/bin/PerlACE/ProcessVX.pm b/ACE/bin/PerlACE/ProcessVX.pm deleted file mode 100644 index 7681a9538d9..00000000000 --- a/ACE/bin/PerlACE/ProcessVX.pm +++ /dev/null @@ -1,252 +0,0 @@ -# $Id$ - -package PerlACE::ProcessVX; - -use strict; -use English; -use POSIX qw(:time_h); - -$PerlACE::ProcessVX::ExeSubDir = './'; -$PerlACE::ProcessVX::DoVxInit = (defined $ENV{"ACE_RUN_VX_NO_INITIAL_REBOOT"}) ? 0 : 1; -$PerlACE::ProcessVX::VxDefGw = 1; -$PerlACE::ProcessVX::RebootTime = (defined $ENV{"ACE_RUN_VX_REBOOT_TIME"}) ? $ENV{"ACE_RUN_VX_REBOOT_TIME"} : 90; -$PerlACE::ProcessVX::ExeExt = ($PerlACE::VxWorks_RTP_Test) ? '.vxe' : '.out'; -$PerlACE::ProcessVX::RebootCmd = $ENV{"ACE_RUN_VX_REBOOT_CMD"}; - -sub delay_factor { - my($lps) = 128; - my($factor) = 1; - - ## Keep increasing the loops per second until the amount of time - ## exceeds the number of clocks per second. The original code - ## did not multiply $ticks by 8 but, for faster machines, it doesn't - ## seem to return false values. The multiplication is done to minimize - ## the amount of time it takes to determine the correct factor. - while(($lps <<= 1)) { - my($ticks) = clock(); - for(my $i = $lps; $i >= 0; $i--) { - } - $ticks = clock() - $ticks; - if ($ticks * 8 >= CLOCKS_PER_SEC) { - $factor = 500000 / (($lps / $ticks) * CLOCKS_PER_SEC); - last; - } - } - - return $factor; -} - -sub iboot_cycle_power { - my $self = shift; - - my ($iboot_host, - $iboot_outlet, - $iboot_user, - $iboot_passwd ) = ($ENV{'ACE_RUN_VX_IBOOT'}, - $ENV{'ACE_RUN_VX_IBOOT_OUTLET'}, - $ENV{'ACE_RUN_VX_IBOOT_USER'}, - $ENV{'ACE_RUN_VX_IBOOT_PASSWORD'}); - - my $v = $ENV{'ACE_TEST_VERBOSE'}; - - if ($v) { - print "Using iBoot: $iboot_host\n"; - if (defined $iboot_outlet) { - print "Using iBoot Outlet #: $iboot_outlet\n"; - } - } - - # There are three cases to handle here: - # 1. using a single-outlet iBoot - # 2. using a multi-outlet iBootBar with custom firmware - # 3. using a multi-outlet iBootBar with standard firmware - # - # In cases 1 & 2, we use the iPAL protocol; in case 3 we - # use a telnet connection and the command-line syntax. - # - # We determine that it's case #3 by the concurrent presence - # of an outlet number, an iboot username, and an iboot password - # in the environment. - # - - if (defined($iboot_outlet) && defined($iboot_user) && defined($iboot_passwd)) { - # We perform case #3 - - my $t = new Net::Telnet(); - - $t->prompt('/iBootBar \> /'); - my $savedmode = $t->errmode(); - $t->errmode("return"); - - my $retries = 5; - my $is_open = 0; - - while ($retries--) { - my $r = $t->open($iboot_host); - if ($r == 1) { - $is_open = 1; - last; - } - } - continue { - print "Couldn't open connection; sleeping then retrying\n" if ($v); - sleep(5); - } - - if (! $is_open) { - print "Unable to open $iboot_host.\n" if ($v); - return 0; - } - - $t->errmode($savedmode); - - # Simple login b/c Net::Telnet::login hardcodes the prompts - $t->waitfor('/User Name:\s*$/i'); - $t->print($iboot_user); - $t->waitfor('/password:\s*/i'); - $t->print($iboot_passwd); - - $t->waitfor($t->prompt); - - print "successfully logged in to $iboot_host\n" if ($v); - - my $output = $t->cmd("set outlet $iboot_outlet cycle"); - - print "successfully cycled power on outlet $iboot_outlet\n" if ($v); - - $t->close(); - } - else { - # Perform cases 1 & 2 - my $iboot; - my $text; - if (!defined($iboot_passwd)) { - $iboot_passwd = "PASS"; - } - - my $ipal_command_series = (defined $iboot_outlet) ? ['E', 'D'] : ['f', 'n']; - - foreach my $ipal_cmd (@$ipal_command_series) { - my $retries = 3; - my $is_open = 0; - while ($retries--) { - $iboot = IO::Socket::INET->new ("$iboot_host"); - if ($iboot) { - # if ACE_RUN_VX_IBOOT_OUTLET is defined, we're using - # the iBootBar, and we're using the iPAL Protocol - # to communicate with the iBootBar - if (defined $iboot_outlet) { - $iboot->send ("\e".$iboot_passwd."\e".$iboot_outlet.$ipal_cmd); - } - else { - $iboot->send ("\e".$iboot_passwd."\e$ipal_cmd\r"); - } - $iboot->recv ($text,128); - print "iBoot is currently: $text\n" if ($v); - $iboot->close(); - if ($text eq "OFF" || $text eq "ON") { - $is_open = 1; - last; - } - else { - print "iBoot is $text; sleeping then retrying\n" if ($v); - sleep(5); - } - } - else { - print "ERROR: FAILED to execute 'reboot' command!\n"; - } - } - if (!$is_open) { - print "Unable to reboot using $iboot_host.\n" if ($v); - return 0; - } - } - } -} - -sub reboot { - my $self = shift; - my $iboot; - my $text; - my $t; - my $ok; - - my $target_login = $ENV{'ACE_RUN_VX_LOGIN'}; - my $target_password = $ENV{'ACE_RUN_VX_PASSWORD'}; - - ## - ## initialize VxWorks kernel (reboot!) if needed - if ($PerlACE::ProcessVX::DoVxInit || $ENV{'ACE_RUN_VX_TGT_REBOOT'}) { - if (defined $ENV{'ACE_RUN_VX_REBOOT_TOOL'}) { - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "Calling: $ENV{'ACE_RUN_VX_REBOOT_TOOL'}\n"; - } - system ($ENV{'ACE_RUN_VX_REBOOT_TOOL'}); - } - else { - if (defined $ENV{'ACE_RUN_VX_IBOOT'}) { - $self->iboot_cycle_power(); - } - else { - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "Executing 'reboot' command over Telnet to ".$ENV{'ACE_RUN_VX_TGTHOST'}.".\n"; - } - $t = new Net::Telnet(Timeout => 10, - Prompt => '/-> $/', - Errmode => 'return'); - $t->open($ENV{'ACE_RUN_VX_TGTHOST'}); - $t->print(""); - if (defined $target_login) { - $t->waitfor('/VxWorks login: $/'); - $t->print("$target_login"); - } - if (defined $target_password) { - $t->waitfor('/Password: $/'); - $t->print("$target_password"); - } - $ok = $t->waitfor('/-> $/'); - if ($ok) { - $t->print($PerlACE::ProcessVX::RebootCmd); - } - else { - print "ERROR: FAILED to execute 'reboot' command!\n"; - } - $t->close(); - } - } - $PerlACE::ProcessVX::VxDefGw = 1; - $PerlACE::ProcessVX::DoVxInit = 0; - sleep($PerlACE::ProcessVX::RebootTime); - } -} - -### 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::ProcessVX::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; - -$PerlACE::ProcessVX::WAIT_DELAY_FACTOR = $ENV{"ACE_RUNTEST_DELAY"}; - -if ($OSNAME eq "MSWin32") { - require PerlACE::ProcessVX_Win32; -} -else { - require PerlACE::ProcessVX_Unix; -} - -1; diff --git a/ACE/bin/PerlACE/ProcessVX_Unix.pm b/ACE/bin/PerlACE/ProcessVX_Unix.pm deleted file mode 100644 index 5138b15f617..00000000000 --- a/ACE/bin/PerlACE/ProcessVX_Unix.pm +++ /dev/null @@ -1,486 +0,0 @@ -# $Id$ - -package PerlACE::ProcessVX; - -use strict; -use POSIX "sys_wait_h"; -use File::Basename; -use File::Spec; -use Config; -use FileHandle; -use Cwd; - -require Net::Telnet; - -############################################################################### - -### Grab signal names - -my @signame; - -if (defined $Config{sig_name}) { - my $i = 0; - foreach my $name (split (' ', $Config{sig_name})) { - $signame[$i] = $name; - $i++; - } -} -else { - my $i; - for ($i = 0; $i < 255; ++$i) { - $signame[$i] = $i; - } -} - -############################################################################### - -# This is what GetExitCode will return if the process is still running. -my $STILL_ACTIVE = 259; - -############################################################################### - -### Constructor and Destructor - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = {}; - - $self->{RUNNING} = 0; - $self->{IGNOREEXESUBDIR} = 1; - $self->{PROCESS} = undef; - $self->{EXECUTABLE} = shift; - $self->{ARGUMENTS} = shift; - if (!defined $PerlACE::ProcessVX::WAIT_DELAY_FACTOR) { - $PerlACE::ProcessVX::WAIT_DELAY_FACTOR = 2; - } - if (!defined $PerlACE::ProcessVX::RebootCmd) { - $PerlACE::ProcessVX::RebootCmd = "reboot 0x02"; - } - bless ($self, $class); - return $self; -} - -sub DESTROY -{ - my $self = shift; - - if ($self->{RUNNING} == 1) { - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> still running upon object destruction\n"; - $self->Kill (); - } -} - -############################################################################### - -### Some Accessors - -sub Normalize_Executable_Name -{ - my $self = shift; - my $executable = shift; - - my $basename = basename ($executable); - my $dirname = dirname ($executable). '/'; - - $executable = $dirname.$PerlACE::ProcessVX::ExeSubDir.$basename.$PerlACE::ProcessVX::ExeExt; - - ## Installed executables do not conform to the ExeSubDir - if (! -e $executable && -e $dirname.$basename.$PerlACE::ProcessVX::ExeExt) { - $executable = $dirname.$basename.$PerlACE::ProcessVX::ExeExt; - } - - return $executable; -} - - -sub Executable -{ - my $self = shift; - - if (@_ != 0) { - $self->{EXECUTABLE} = shift; - } - - my $executable = $self->{EXECUTABLE}; - - if ($self->{IGNOREEXESUBDIR} == 0) { - $executable = $self->Normalize_Executable_Name ($executable); - } - else { - $executable = $executable.$PerlACE::ProcessVX::ExeExt; - } - - 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; -} - -sub IgnoreExeSubDir -{ - my $self = shift; - - if (@_ != 0) { - $self->{IGNOREEXESUBDIR} = shift; - } - - return $self->{IGNOREEXESUBDIR}; -} - -############################################################################### - -### 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; - } - - if ($self->{IGNOREEXESUBDIR} == 0) { - if (!-f $self->Executable ()) { - print STDERR "ERROR: Cannot Spawn: <", $self->Executable (), - "> not found\n"; - return -1; - } - } - - my $status = 0; - - my $cmdline; - - # Reboot the target if necessery - $self->reboot(); - - my $program = $self->Executable (); - my $cwdrel = dirname ($program); - my $prjroot = defined $ENV{"ACE_RUN_VX_PRJ_ROOT"} ? $ENV{"ACE_RUN_VX_PRJ_ROOT"} : $ENV{"ACE_ROOT"}; - if (length ($cwdrel) > 0) { - $cwdrel = File::Spec->abs2rel( cwd(), $prjroot ); - } - else { - $cwdrel = File::Spec->abs2rel( $cwdrel, $prjroot ); - } - $program = basename($program, $PerlACE::ProcessVX::ExeExt); - - my @cmds; - my $cmdnr = 0; - my $arguments = ""; - my $prompt = ''; - - if ($PerlACE::VxWorks_RTP_Test) { - @cmds[$cmdnr++] = 'cmd'; - if ( defined $ENV{"ACE_RUN_VX_TGTSVR_DEFGW"} && $self->{SET_VX_DEFGW}) { - @cmds[$cmdnr++] = "C mRouteAdd(\"0.0.0.0\", \"" . $ENV{"ACE_RUN_VX_TGTSVR_DEFGW"} . "\", 0,0,0)"; - $self->{SET_VX_DEFGW} = 0; - } - - @cmds[$cmdnr++] = 'cd "' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel . '"'; - @cmds[$cmdnr++] = 'C putenv("TMPDIR=' . $ENV{"ACE_RUN_VX_TGTSVR_ROOT"} . "/" . $cwdrel . '")'; - - if (defined $ENV{'ACE_RUN_ACE_DEBUG'}) { - @cmds[$cmdnr++] = 'putenv("ACE_DEBUG=' . $ENV{"ACE_RUN_ACE_DEBUG"} . '")'; - } - - if (defined $ENV{'ACE_RUN_TAO_ORB_DEBUG'}) { - @cmds[$cmdnr++] = 'putenv("TAO_ORB_DEBUG=' . $ENV{"ACE_RUN_TAO_ORB_DEBUG"} . '")'; - } - - if (defined $ENV{'ACE_RUN_VX_CHECK_RESOURCES'}) { - @cmds[$cmdnr++] = 'C memShow()'; - } - - $cmdline = $program . $PerlACE::ProcessVX::ExeExt . ' ' . $self->{ARGUMENTS}; - @cmds[$cmdnr++] = $cmdline; - $prompt = '/\[vxWorks \*]# $/'; - } else { - if ( defined $ENV{"ACE_RUN_VX_TGTSVR_DEFGW"} && $self->{SET_VX_DEFGW}) { - @cmds[$cmdnr++] = "mRouteAdd(\"0.0.0.0\", \"" . $ENV{"ACE_RUN_VX_TGTSVR_DEFGW"} . "\", 0,0,0)"; - $self->{SET_VX_DEFGW} = 0; - } - - @cmds[$cmdnr++] = 'cd "' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel . '"'; - @cmds[$cmdnr++] = 'putenv("TMPDIR=' . $ENV{"ACE_RUN_VX_TGTSVR_ROOT"} . "/" . $cwdrel . '")'; - - if (defined $ENV{'ACE_RUN_VX_CHECK_RESOURCES'}) { - @cmds[$cmdnr++] = 'memShow()'; - } - - if (defined $ENV{'ACE_RUN_ACE_DEBUG'}) { - @cmds[$cmdnr++] = 'putenv("ACE_DEBUG=' . $ENV{"ACE_RUN_ACE_DEBUG"} . '")'; - } - - if (defined $ENV{'ACE_RUN_TAO_ORB_DEBUG'}) { - @cmds[$cmdnr++] = 'putenv("TAO_ORB_DEBUG=' . $ENV{"ACE_RUN_TAO_ORB_DEBUG"} . '")'; - } - - @cmds[$cmdnr++] = 'ld <'. $program . $PerlACE::ProcessVX::ExeExt; - $cmdline = $program . $PerlACE::ProcessVX::ExeExt . ' ' . $self->{ARGUMENTS}; - if (defined $self->{ARGUMENTS}) { - ($arguments = $self->{ARGUMENTS})=~ s/\"/\\\"/g; - $arguments = ",\"" . $arguments . "\""; - } - @cmds[$cmdnr++] = 'ace_vx_rc = vx_execae(ace_main' . $arguments . ')'; - @cmds[$cmdnr++] = 'unld "'. $program . $PerlACE::ProcessVX::ExeExt . '"'; - $prompt = '/-> $/'; - } - - FORK: - { - if ($self->{PROCESS} = fork) { - #parent here - bless $self; - } - elsif (defined $self->{PROCESS}) { - #child here - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "$cmdline\n"; - } - - my $t; - $t = new Net::Telnet(Timeout => 600, Errmode => 'return'); - $t->open($ENV{'ACE_RUN_VX_TGTHOST'}); - $t->print(""); - - my $target_login = $ENV{'ACE_RUN_VX_LOGIN'}; - my $target_password = $ENV{'ACE_RUN_VX_PASSWORD'}; - - if (defined $target_login) { - $t->waitfor('/VxWorks login: $/'); - $t->print("$target_login"); - } - - if (defined $target_password) { - $t->waitfor('/Password: $/'); - $t->print("$target_password"); - } - - my $ok; - $ok = $t->waitfor('/-> $/'); - if ($ok) { - $t->prompt ($prompt); - my $i = 0; - my @lines; - while($i < $cmdnr) { - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print @cmds[$i]."\n"; - } - @lines = $t->cmd (@cmds[$i++]); - print @lines; - } - } - else { - die "ERROR: exec failed for <" . $cmdline . ">"; - } - $t->close(); - sleep(2); - exit; - } - elsif ($! =~ /No more process/) { - #EAGAIN, supposedly recoverable fork error - sleep 5; - redo FORK; - } - else { - # weird fork error - print STDERR "ERROR: Can't fork <" . $cmdline . ">: $!\n"; - } - } - $self->{RUNNING} = 1; - return 0; -} - -# Wait for the process to exit or kill after a time period - -sub WaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - my $status = $self->TimedWait ($timeout); - - if ($status == -1) { - print STDERR "ERROR: $self->{EXECUTABLE} timedout\n"; - $self->Kill (); - - $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run - } - - $self->{RUNNING} = 0; - - return $status; -} - - -# Do a Spawn and immediately WaitKill - -sub SpawnWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->Spawn () == -1) { - return -1; - } - - return $self->WaitKill ($timeout); -} - - -# Terminate the process and wait for it to finish - -sub TerminateWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->{RUNNING}) { - print STDERR "INFO: $self->{EXECUTABLE} being killed.\n"; - kill ('TERM', $self->{PROCESS}); - - $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run - } - - return $self->WaitKill ($timeout); -} - -# really only for internal use -sub check_return_value ($) -{ - my $self = shift; - my $rc = shift; - - my $CC_MASK = 0xff00; - - # Exit code processing - if ($rc == 0) { - return 0; - } - elsif ($rc == $CC_MASK) { - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> failed: $!\n"; - - $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run - - return ($rc >> 8); - } - elsif (($rc & 0xff) == 0) { - $rc >>= 8; - return $rc; - } - - # Remember Core dump flag - my $dump = 0; - - if ($rc & 0x80) { - $rc &= ~0x80; - $dump = 1; - } - - # check for ABRT, KILL or TERM - if ($rc == 6 || $rc == 9 || $rc == 15) { - return 0; - } - - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> exited with "; - - print STDERR "coredump from " if ($dump == 1); - - print STDERR "signal $rc : ", $signame[$rc], "\n"; - - $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run - - return 0; -} - -sub Kill () -{ - my $self = shift; - - if ($self->{RUNNING} && !defined $ENV{'ACE_TEST_WINDOW'}) { - kill ('KILL', $self->{PROCESS}); - waitpid ($self->{PROCESS}, 0); - $self->check_return_value ($?); - } - - $self->{RUNNING} = 0; -} - -# Wait until a process exits. -# return -1 if the process is still alive. -sub Wait ($) -{ - my $self = shift; - my $timeout = shift; - if (!defined $timeout || $timeout < 0) { - waitpid ($self->{PROCESS}, 0); - } else { - return TimedWait($self, $timeout); - } - -} - -sub TimedWait ($) -{ - my $self = shift; - my $timeout = shift; - - if ($PerlACE::Process::WAIT_DELAY_FACTOR > 0) { - $timeout *= $PerlACE::Process::WAIT_DELAY_FACTOR; - } - - while ($timeout-- != 0) { - my $pid = waitpid ($self->{PROCESS}, &WNOHANG); - if ($pid != 0 && $? != -1) { - return $self->check_return_value ($?); - } - sleep 1; - } - - $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run - - return -1; -} - - - - - -1; diff --git a/ACE/bin/PerlACE/ProcessVX_Win32.pm b/ACE/bin/PerlACE/ProcessVX_Win32.pm deleted file mode 100644 index 3ecd7a1d06e..00000000000 --- a/ACE/bin/PerlACE/ProcessVX_Win32.pm +++ /dev/null @@ -1,434 +0,0 @@ -# $Id$ - -package PerlACE::ProcessVX; - -use strict; -use Win32::Process; -use File::Basename; -use File::Spec; -use FileHandle; -use Cwd; - -require Net::Telnet; - -############################################################################### - -# This is what GetExitCode will return if the process is still running. -my $STILL_ACTIVE = 259; - -############################################################################### - -### Constructor and Destructor - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = {}; - - $self->{RUNNING} = 0; - $self->{IGNOREEXESUBDIR} = 1; - $self->{PROCESS} = undef; - $self->{EXECUTABLE} = shift; - $self->{ARGUMENTS} = shift; - if (!defined $PerlACE::ProcessVX::WAIT_DELAY_FACTOR) { - $PerlACE::ProcessVX::WAIT_DELAY_FACTOR = 3; - } - if (!defined $PerlACE::ProcessVX::RebootCmd) { - $PerlACE::ProcessVX::RebootCmd = "reboot"; - } - bless ($self, $class); - return $self; -} - -sub DESTROY -{ - my $self = shift; - - if ($self->{RUNNING} == 1) { - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> still running upon object destruction\n"; - $self->Kill (); - } - - if (!defined $ENV{'ACE_TEST_VERBOSE'}) { - unlink "run_vx.pl"; - } -} - -############################################################################### - -### Some Accessors - -sub Normalize_Executable_Name -{ - my $self = shift; - my $executable = shift; - - my $basename = basename ($executable); - my $dirname = dirname ($executable). '/'; - - $executable = $dirname.$PerlACE::ProcessVX::ExeSubDir.$basename.$PerlACE::ProcessVX::ExeExt; - - ## Installed executables do not conform to the ExeSubDir - if (! -e $executable && -e $dirname.$basename.$PerlACE::ProcessVX::ExeExt) { - $executable = $dirname.$basename.$PerlACE::ProcessVX::ExeExt; - } - - return $executable; -} - - -sub Executable -{ - my $self = shift; - - if (@_ != 0) { - $self->{EXECUTABLE} = shift; - } - - my $executable = $self->{EXECUTABLE}; - - if ($self->{IGNOREEXESUBDIR} == 0) { - $executable = $self->Normalize_Executable_Name ($executable); - } - else { - $executable = $executable.$PerlACE::ProcessVX::ExeExt; - } - - 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; -} - -sub IgnoreExeSubDir -{ - my $self = shift; - - if (@_ != 0) { - $self->{IGNOREEXESUBDIR} = shift; - } - - return $self->{IGNOREEXESUBDIR}; -} - -############################################################################### - -### 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; - } - - if ($self->{IGNOREEXESUBDIR} == 0) { - if (!-f $self->Executable ()) { - print STDERR "ERROR: Cannot Spawn: <", $self->Executable (), - "> not found\n"; - return -1; - } - } - - my $status = 0; - - my $cmdline; - - # Reboot the target if necessery - $self->reboot(); - - my $program = $self->Executable (); - my $cwdrel = dirname ($program); - my $prjroot = defined $ENV{"ACE_RUN_VX_PRJ_ROOT"} ? $ENV{"ACE_RUN_VX_PRJ_ROOT"} : $ENV{"ACE_ROOT"}; - if (length ($cwdrel) > 0) { - $cwdrel = File::Spec->abs2rel( cwd(), $prjroot ); - } - else { - $cwdrel = File::Spec->abs2rel( $cwdrel, $prjroot ); - } - $cwdrel =~ s/\\/\//g; - $program = basename($program, $PerlACE::ProcessVX::ExeExt); - - unlink "run_vx.pl"; - my $oh = new FileHandle(); - if (!open($oh, ">run_vx.pl")) { - print STDERR "ERROR: Unable to write to run_vx.pl\n"; - exit -1; - } - - my @cmds; - my $cmdnr = 0; - my $arguments = ""; - my $prompt = ''; - - if ($PerlACE::VxWorks_RTP_Test) { - @cmds[$cmdnr++] = 'cmd'; - if ( defined $ENV{"ACE_RUN_VX_TGTSVR_DEFGW"} && $PerlACE::ProcessVX::VxDefGw) { - @cmds[$cmdnr++] = "C mRouteAdd(\"0.0.0.0\", \"" . $ENV{"ACE_RUN_VX_TGTSVR_DEFGW"} . "\", 0,0,0)"; - $PerlACE::ProcessVX::VxDefGw = 0; - } - - @cmds[$cmdnr++] = 'cd "' . $ENV{"ACE_RUN_VX_TGTSVR_ROOT"} . "/" . $cwdrel . '"'; - @cmds[$cmdnr++] = 'C putenv("TMPDIR=' . $ENV{"ACE_RUN_VX_TGTSVR_ROOT"} . "/" . $cwdrel . '")'; - - if (defined $ENV{'ACE_RUN_ACE_DEBUG'}) { - @cmds[$cmdnr++] = 'putenv("ACE_DEBUG=' . $ENV{"ACE_RUN_ACE_DEBUG"} . '")'; - } - - if (defined $ENV{'ACE_RUN_TAO_ORB_DEBUG'}) { - @cmds[$cmdnr++] = 'putenv("TAO_ORB_DEBUG=' . $ENV{"ACE_RUN_TAO_ORB_DEBUG"} . '")'; - } - - if (defined $ENV{'ACE_RUN_VX_CHECK_RESOURCES'}) { - @cmds[$cmdnr++] = 'C memShow()'; - } - - $cmdline = $program . $PerlACE::ProcessVX::ExeExt . ' ' . $self->{ARGUMENTS}; - @cmds[$cmdnr++] = $cmdline; - $prompt = '/\[vxWorks \*]# $/'; - } else { - if ( defined $ENV{"ACE_RUN_VX_TGTSVR_DEFGW"} && $PerlACE::ProcessVX::VxDefGw) { - @cmds[$cmdnr++] = "mRouteAdd(\"0.0.0.0\", \"" . $ENV{"ACE_RUN_VX_TGTSVR_DEFGW"} . "\", 0,0,0)"; - $PerlACE::ProcessVX::VxDefGw = 0; - } - - @cmds[$cmdnr++] = 'cd "' . $ENV{"ACE_RUN_VX_TGTSVR_ROOT"} . "/" . $cwdrel . '"'; - @cmds[$cmdnr++] = 'putenv("TMPDIR=' . $ENV{"ACE_RUN_VX_TGTSVR_ROOT"} . "/" . $cwdrel . '")'; - - if (defined $ENV{'ACE_RUN_VX_CHECK_RESOURCES'}) { - @cmds[$cmdnr++] = 'memShow()'; - } - - if (defined $ENV{'ACE_RUN_ACE_DEBUG'}) { - @cmds[$cmdnr++] = 'putenv("ACE_DEBUG=' . $ENV{"ACE_RUN_ACE_DEBUG"} . '")'; - } - - if (defined $ENV{'ACE_RUN_TAO_ORB_DEBUG'}) { - @cmds[$cmdnr++] = 'putenv("TAO_ORB_DEBUG=' . $ENV{"ACE_RUN_TAO_ORB_DEBUG"} . '")'; - } - - @cmds[$cmdnr++] = 'ld <'. $program . $PerlACE::ProcessVX::ExeExt; - $cmdline = $program . $PerlACE::ProcessVX::ExeExt . ' ' . $self->{ARGUMENTS}; - if (defined $self->{ARGUMENTS}) { - ($arguments = $self->{ARGUMENTS})=~ s/\"/\\\"/g; - $arguments = ",\"" . $arguments . "\""; - } - @cmds[$cmdnr++] = 'ace_vx_rc = vx_execae(ace_main' . $arguments . ')'; - @cmds[$cmdnr++] = 'unld "'. $program . $PerlACE::ProcessVX::ExeExt . '"'; - $prompt = '/-> $/'; - } - - print $oh "require Net::Telnet;\n"; - print $oh "my \@cmds;\n"; - print $oh "my \$prompt = '$prompt';\n"; - my $i = 0; - while($i < $cmdnr) { - print $oh "\@cmds[$i] = '" . @cmds[$i++] . "';\n"; - } - print $oh "my \$cmdnr = $cmdnr;\n\n"; - - print $oh <<'__END__'; -if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "$cmdline\n"; -} - -my $ok; -my $t = new Net::Telnet(Timeout => 600, Errmode => 'return'); -$t->open($ENV{'ACE_RUN_VX_TGTHOST'}); -$t->print(""); - -my $target_login = $ENV{'ACE_RUN_VX_LOGIN'}; -my $target_password = $ENV{'ACE_RUN_VX_PASSWORD'}; - -if (defined $target_login) { - $t->waitfor('/VxWorks login: $/'); - $t->print("$target_login"); -} - -if (defined $target_password) { - $t->waitfor('/Password: $/'); - $t->print("$target_password"); -} - -$ok = $t->waitfor('/-> $/'); -if ($ok) { - $t->prompt ($prompt); - my $i = 0; - my @lines; - while($i < $cmdnr) { - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print @cmds[$i]."\n"; - } - @lines = $t->cmd (@cmds[$i++]); - print @lines; - } -} -else { - die "ERROR: exec failed for <" . $cmdline . ">"; -} -$t->close(); -sleep(2); -exit; -__END__ - - close($oh); - - Win32::Process::Create ($self->{PROCESS}, - "$^X", - "$^X run_vx.pl", - 0, - 0, - '.'); - - Win32::Process::GetExitCode ($self->{PROCESS}, $status); - - if ($status != $STILL_ACTIVE) { - print STDERR "ERROR: Spawn failed for <", "$^X run_vx.pl", ">\n"; - exit $status; - } - - $self->{RUNNING} = 1; - return 0; -} - -# Wait for a process to exit with a timeout - -sub TimedWait ($) -{ - my($self) = shift; - my($timeout) = shift; - return $self->Wait($timeout); -} - -# Wait for the process to exit or kill after a time period - -sub WaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - my $status = $self->TimedWait ($timeout); - - if ($status == -1) { - print STDERR "ERROR: $self->{EXECUTABLE} timedout\n"; - $self->Kill (); - # Don't need to Wait since we are on Win32 - - $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run - } - - $self->{RUNNING} = 0; - - return $status; -} - - -# Do a Spawn and immediately WaitKill - -sub SpawnWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->Spawn () == -1) { - return -1; - } - - return $self->WaitKill ($timeout); -} - - -# Terminate the process and wait for it to finish - -sub TerminateWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->{RUNNING}) { - print STDERR "INFO: $self->{EXECUTABLE} being killed.\n"; - Win32::Process::Kill ($self->{PROCESS}, 0); - $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run - } - - return $self->WaitKill ($timeout); -} - -# Wait until a process exits. -# return -1 if the process is still alive. -sub Wait ($) -{ - my $self = shift; - my $timeout = shift; - if (!defined $timeout || $timeout < 0) { - $timeout = INFINITE; - } else { - $timeout = $timeout * 1000 * $PerlACE::ProcessVX::WAIT_DELAY_FACTOR; - } - - my $result = 0; - - if ($self->{RUNNING}) { - $result = Win32::Process::Wait ($self->{PROCESS}, $timeout); - if ($result == 0) { - return -1; - } - } - Win32::Process::GetExitCode ($self->{PROCESS}, $result); - if ($result != 0) { - $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run - } - return $result; -} - - - -# Kill the process - -sub Kill () -{ - my $self = shift; - - if ($self->{RUNNING}) { - Win32::Process::Kill ($self->{PROCESS}, -1); - } - - $self->{RUNNING} = 0; -} - - -1; diff --git a/ACE/bin/PerlACE/Process_Unix.pm b/ACE/bin/PerlACE/Process_Unix.pm deleted file mode 100644 index c7c3df46c3d..00000000000 --- a/ACE/bin/PerlACE/Process_Unix.pm +++ /dev/null @@ -1,526 +0,0 @@ -# $Id$ - -package PerlACE::Process; - -use strict; -use POSIX "sys_wait_h"; -use Cwd; -use File::Basename; -use Config; - -############################################################################### - -### Grab signal names - -my @signame; - -if (defined $Config{sig_name}) { - my $i = 0; - foreach my $name (split (' ', $Config{sig_name})) { - $signame[$i] = $name; - $i++; - } -} -else { - my $i; - for ($i = 0; $i < 255; ++$i) { - $signame[$i] = $i; - } -} - -############################################################################### - -### Constructor and Destructor - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = {}; - - $self->{RUNNING} = 0; - $self->{IGNOREEXESUBDIR} = 0; - $self->{IGNOREHOSTROOT} = 0; - $self->{PROCESS} = undef; - $self->{EXECUTABLE} = shift; - $self->{ARGUMENTS} = shift; - $self->{VALGRIND_CMD} = $ENV{"ACE_RUN_VALGRIND_CMD"}; - - if (!defined $PerlACE::Process::WAIT_DELAY_FACTOR) { - if (defined $self->{PURIFY_CMD}) { - $PerlACE::Process::WAIT_DELAY_FACTOR = 10; - } - elsif (defined $self->{VALGRIND_CMD}) { - $PerlACE::Process::WAIT_DELAY_FACTOR = 5; - } - else { - $PerlACE::Process::WAIT_DELAY_FACTOR = 1; - } - } - - bless ($self, $class); - return $self; -} - -sub DESTROY -{ - my $self = shift; - - if ($self->{RUNNING} == 1) { - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> still running upon object destruction\n"; - $self->Kill (); - } -} - -############################################################################### - -### Some Accessors - -sub Executable -{ - my $self = shift; - - if (@_ != 0) { - $self->{EXECUTABLE} = shift; - } - - my $executable = $self->{EXECUTABLE}; - - if ($self->{IGNOREHOSTROOT} == 0) { - if (PerlACE::is_vxworks_test()) { - $executable = PerlACE::VX_HostFile ($executable); - } - } - - if ($self->{IGNOREEXESUBDIR}) { - return $executable; - } - - my $basename = basename ($executable); - my $dirname = dirname ($executable). '/'; - - $executable = $dirname.$PerlACE::Process::ExeSubDir.$basename; - - 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->{REMOTEINFO}) { - my($method) = $self->{REMOTEINFO}->{method}; - my($username) = $self->{REMOTEINFO}->{username}; - my($remote) = $self->{REMOTEINFO}->{hostname}; - my($exepath) = $self->{REMOTEINFO}->{exepath}; - my($libpath) = $self->{REMOTEINFO}->{libpath}; - my($exe) = (defined $exepath ? - "$exepath/" . basename($commandline) : $commandline); - $commandline = "$method -l $username $remote \""; - if (defined $libpath) { - my($csh) = (defined $self->{REMOTEINFO}->{shell} && - $self->{REMOTEINFO}->{shell} =~ /csh/); - foreach my $pvar ('LD_LIBRARY_PATH', 'LIBPATH', 'SHLIB_PATH') { - if ($csh) { - $commandline .= "if (! \\\$?$pvar) setenv $pvar; " . - "setenv $pvar $libpath:\\\$$pvar; "; - } - else { - $commandline .= "$pvar=$libpath:\\\$$pvar; export $pvar; "; - } - } - my($env) = $self->{REMOTEINFO}->{env}; - if (defined $env) { - foreach my $pvar (keys %$env) { - if ($csh) { - $commandline .= "setenv $pvar $$env{$pvar}; "; - } - else { - $commandline .= "$pvar=$$env{$pvar}; export $pvar; "; - } - } - } - } - $commandline .= $exe; - } - - if (defined $self->{ARGUMENTS}) { - $commandline .= ' '.$self->{ARGUMENTS}; - } - - # Avoid modifying TAO/tests run_test.pl scripts by using the - # ACE_RUNTEST_ARGS environment variable to append command line - # arguments. - if ($^O eq "nonstop_kernel") { - my $global_args = $ENV{"ACE_RUNTEST_ARGS"}; - if ((length($global_args) > 0) - && ($commandline !~ /tao_idl/)) { - $commandline = $commandline - . ' ' - . $global_args; - } - } - - if (defined $self->{REMOTEINFO}) { - $commandline .= '"'; - } - - return $commandline; -} - -sub IgnoreExeSubDir -{ - my $self = shift; - - if (@_ != 0) { - $self->{IGNOREEXESUBDIR} = shift; - } - - return $self->{IGNOREEXESUBDIR}; -} - -sub IgnoreHostRoot -{ - my $self = shift; - - if (@_ != 0) { - $self->{IGNOREHOSTROOT} = shift; - } - - return $self->{IGNOREHOSTROOT}; -} - -sub RemoteInformation -{ - my($self) = shift; - my(%params) = @_; - - ## Valid keys for %params - ## hostname - The remote hostname - ## method - either rsh or ssh - ## username - The remote user name - ## exepath - The remote path to the executable - ## shell - The shell of the remote user - ## libpath - A library path for libraries required by the executable - ## env - A hash reference of name value pairs to be set in the - ## environment prior to executing the executable. - ## - ## At a minimum, the user must provide the remote hostname. - - if (defined $params{'hostname'}) { - my(@pwd) = getpwuid($<); - $self->{REMOTEINFO} = \%params; - if (!defined $self->{REMOTEINFO}->{'method'}) { - $self->{REMOTEINFO}->{'method'} = 'ssh'; - } - if (!defined $self->{REMOTEINFO}->{'username'}) { - $self->{REMOTEINFO}->{'username'} = $pwd[0] || - $ENV{LOGNAME} || $ENV{USERNAME}; - } - if (!defined $self->{REMOTEINFO}->{'shell'}) { - $self->{REMOTEINFO}->{'shell'} = basename($pwd[8]); - } - } -} - -############################################################################### - -# Spawn the process and continue; - -sub Normalize_Executable_Name -{ - my $executable = shift; - - my $basename = basename ($executable); - my $dirname = dirname ($executable). '/'; - - $executable = $dirname.$PerlACE::Process::ExeSubDir.$basename; - - return $executable; -} - -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; - } - - if ($self->{IGNOREEXESUBDIR} == 0) { - if (!defined $self->{REMOTEINFO} && !-f $self->Executable ()) { - print STDERR "ERROR: Cannot Spawn: <", $self->Executable (), - "> not found\n"; - return -1; - } - } - - my $cmdline = ""; - my $executable = ""; - - if (defined $self->{VALGRIND_CMD}) { - my $orig_cmdline = $self->CommandLine(); - $executable = $self->{VALGRIND_CMD}; - my $basename = basename ($self->{EXECUTABLE}); - - $cmdline = "$executable $orig_cmdline"; - } - elsif (defined $ENV{'ACE_TEST_WINDOW'}) { - $cmdline = $ENV{'ACE_TEST_WINDOW'} . ' ' . $self->CommandLine(); - } - else { - $executable = $self->Executable(); - $cmdline = $self->CommandLine(); - } - - FORK: - { - if ($self->{PROCESS} = fork) { - #parent here - bless $self; - } - elsif (defined $self->{PROCESS}) { - #child here - my @cmdlist = $self->parse_command_line($cmdline); - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "INFO: $cmdline\n"; - foreach my $arg (@cmdlist) { - print "INFO: argument - '$arg'\n"; - } - } - exec @cmdlist; - die "ERROR: exec failed for <" . $cmdline . ">\n"; - } - elsif ($! =~ /No more process/) { - #EAGAIN, supposedly recoverable fork error - sleep 5; - redo FORK; - } - else { - # weird fork error - print STDERR "ERROR: Can't fork <" . $cmdline . ">: $!\n"; - } - } - $self->{RUNNING} = 1; - return 0; -} - -sub WaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->{RUNNING} == 0) { - return 0; - } - - my $status = $self->TimedWait ($timeout); - - if ($status == -1) { - print STDERR "ERROR: $self->{EXECUTABLE} timedout\n"; - $self->Kill (); - } - - $self->{RUNNING} = 0; - - return $status; -} - - -# Do a Spawn and immediately WaitKill - -sub SpawnWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->Spawn () == -1) { - return -1; - } - - return $self->WaitKill ($timeout); -} - -sub TerminateWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->{RUNNING}) { - print STDERR "INFO: $self->{EXECUTABLE} being killed.\n"; - kill ('TERM', $self->{PROCESS}); - } - - return $self->WaitKill ($timeout); -} - -# really only for internal use -sub check_return_value ($) -{ - my $self = shift; - my $rc = shift; - - # NSK OSS has a 32-bit waitpid() status - my $is_NSK = ($^O eq "nonstop_kernel"); - my $CC_MASK = $is_NSK ? 0xffff00 : 0xff00; - - # Exit code processing - if ($rc == 0) { - return 0; - } - elsif ($rc == $CC_MASK) { - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> failed: $!\n"; - return ($rc >> 8); - } - elsif (($rc & 0xff) == 0) { - $rc >>= 8; - return $rc; - } - - # Ignore NSK 16-bit completion code - $rc &= 0xff if $is_NSK; - - # Remember Core dump flag - my $dump = 0; - - if ($rc & 0x80) { - $rc &= ~0x80; - $dump = 1; - } - - # check for ABRT, KILL or TERM - if ($rc == 6 || $rc == 9 || $rc == 15) { - return 0; - } - - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> exited with "; - - print STDERR "coredump from " if ($dump == 1); - - print STDERR "signal $rc : ", $signame[$rc], "\n"; - - return 255; -} - -# for internal use -sub parse_command_line ($) -{ - my $self = shift; - my $cmdline = shift; - $cmdline =~ s/^\s+//; - - my @cmdlist = (); - while ($cmdline ne '') { - if ($cmdline =~ /^\"([^\"\\]*(?:\\.[^\"\\]*)*)\"(.*)/) { - my $unquoted = $1; - $cmdline = $2; - $unquoted =~ s/\\\"/\"/g; - push @cmdlist, $unquoted; - } - elsif ($cmdline =~ /^\'([^\'\\]*(?:\\.[^\'\\]*)*)\'(.*)/) { - my $unquoted = $1; - $cmdline = $2; - $unquoted =~ s/\\\'/\'/g; - push @cmdlist, $unquoted; - } - elsif ($cmdline =~ /^([^\s]*)(.*)/) { - push @cmdlist, $1; - $cmdline = $2; - } - else { - # this must be some kind of error - push @cmdlist, $cmdline; - } - $cmdline =~ s/^\s+//; - } - - return @cmdlist; -} - -sub Kill ($) -{ - my $self = shift; - my $ignore_return_value = shift; - - if ($self->{RUNNING} && !defined $ENV{'ACE_TEST_WINDOW'}) { - kill ('KILL', $self->{PROCESS}); - for(my $i = 0; $i < 10; $i++) { - my $pid = waitpid ($self->{PROCESS}, WNOHANG); - if ($pid > 0) { - if (! $ignore_return_value) { - $self->check_return_value ($?); - } - last; - } - else { - select(undef, undef, undef, .5); - } - } - } - - $self->{RUNNING} = 0; -} - -# Wait until a process exits. -# return -1 if the process is still alive. -sub Wait ($) -{ - my $self = shift; - my $timeout = shift; - if (!defined $self->{PROCESS}) { - return 0; - } - if (!defined $timeout || $timeout < 0) { - return waitpid ($self->{PROCESS}, 0); - } else { - return TimedWait($self, $timeout); - } - -} - -sub TimedWait ($) -{ - my $self = shift; - my $timeout = shift; - - if (!defined $self->{PROCESS}) { - return 0; - } - - $timeout *= $PerlACE::Process::WAIT_DELAY_FACTOR; - - while ($timeout-- != 0) { - my $pid = waitpid ($self->{PROCESS}, &WNOHANG); - if ($pid != 0 && $? != -1) { - return $self->check_return_value ($?); - } - sleep 1; - } - - return -1; -} - -1; diff --git a/ACE/bin/PerlACE/Process_VMS.pm b/ACE/bin/PerlACE/Process_VMS.pm deleted file mode 100644 index f3f524f78f6..00000000000 --- a/ACE/bin/PerlACE/Process_VMS.pm +++ /dev/null @@ -1,358 +0,0 @@ -# $Id$ - -package PerlACE::Process; - -use strict; -use POSIX "sys_wait_h"; -use Cwd; -use File::Basename; -use Config; -use VmsProcess; - -############################################################################### - -### Chorus stuff - -$PerlACE::Process::chorushostname = "localhost"; -$PerlACE::Process::chorus = 0; - -$PerlACE::Process::cwd = getcwd(); - -for(my $i = 0; $i <= $#ARGV; $i++) { - if ($ARGV[$i] eq '-chorus') { - if (defined $ARGV[$i + 1]) { - $PerlACE::Process::chorus = 1; - $PerlACE::Process::chorushostname = $ARGV[$1 + 1]; - } - 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 - } -} - -############################################################################### - -### Grab signal names - -my @signame; - -if (defined $Config{sig_name}) { - my $i = 0; - foreach my $name (split (' ', $Config{sig_name})) { - $signame[$i] = $name; - $i++; - } -} -else { - my $i; - for ($i = 0; $i < 255; ++$i) { - $signame[$i] = $i; - } -} - -############################################################################### - -### Constructor and Destructor - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = {}; - - $self->{RUNNING} = 0; - $self->{IGNOREEXESUBDIR} = 0; - $self->{PROCESS} = undef; - $self->{EXECUTABLE} = shift; - $self->{ARGUMENTS} = shift; - $self->{VALGRIND_CMD} = $ENV{"ACE_RUN_VALGRIND_CMD"}; - - if (!defined $PerlACE::Process::WAIT_DELAY_FACTOR) { - if (defined $self->{PURIFY_CMD}) { - $PerlACE::Process::WAIT_DELAY_FACTOR = 10; - } - elsif (defined $self->{VALGRIND_CMD}) { - $PerlACE::Process::WAIT_DELAY_FACTOR = 5; - } - else { - $PerlACE::Process::WAIT_DELAY_FACTOR = 1; - } - } - - bless ($self, $class); - return $self; -} - -sub DESTROY -{ - my $self = shift; - - if ($self->{RUNNING} == 1) { - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> still running upon object destruction\n"; - $self->Kill (); - } -} - -############################################################################### - -### Some Accessors - -sub Executable -{ - my $self = shift; - - if (@_ != 0) { - $self->{EXECUTABLE} = shift; - } - - my $executable = $self->{EXECUTABLE}; - - if ($self->{IGNOREEXESUBDIR}) { - return $executable; - } - - my $basename = basename ($executable); - my $dirname = dirname ($executable). '/'; - if ($dirname != "") { - $executable = $dirname.$PerlACE::Process::ExeSubDir.$basename; - } - else { - $executable = $dirname.$basename; - } - - if ( !-x $executable ) { - if ( -x $executable.'.exe' ) { - $executable = $executable.'.exe'; - } - } - - 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}; - } - - if ($PerlACE::Process::chorus == 1) { - $commandline = "rsh " - . $PerlACE::Process::chorushostname - . " arun " - . $PerlACE::Process::cwd - . "/" - . $commandline; - } - - return $commandline; -} - -sub IgnoreExeSubDir -{ - my $self = shift; - - if (@_ != 0) { - $self->{IGNOREEXESUBDIR} = shift; - } - - return $self->{IGNOREEXESUBDIR}; -} - -############################################################################### - -# 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; - } - - if ($self->{IGNOREEXESUBDIR} == 0) { - if (!-f $self->Executable ()) { - print STDERR "ERROR: Cannot Spawn: <", $self->Executable (), - "> not found\n"; - return -1; - } - - if (!$PerlACE::Process::chorus && !-x $self->Executable ()) { - print STDERR "ERROR: Cannot Spawn: <", $self->Executable (), - "> not executable\n"; - return -1; - } - } - - { - $self->{PROCESS} = VmsProcess::Spawn $self->{EXECUTABLE}, $self->{ARGUMENTS}; - if ($self->{PROCESS}) { - #parent here - bless $self; - } - else { - # weird fork error - print STDERR "ERROR: Can't spawn <" . $self->CommandLine () . ">: $!\n"; - } - } - $self->{RUNNING} = 1; - return 0; -} - -sub WaitKill ($) -{ - my $self = shift; - my $timeout = shift; - my $status = $self->TimedWait ($timeout); - - if ($status == -1) { - print STDERR "ERROR: $self->{EXECUTABLE} timedout\n"; - $self->Kill (); - } - - $self->{RUNNING} = 0; - - return $status; -} - - -# Do a Spawn and immediately WaitKill - -sub SpawnWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->Spawn () == -1) { - return -1; - } - - return $self->WaitKill ($timeout); -} - -sub TerminateWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->{RUNNING}) { - print STDERR "INFO: $self->{EXECUTABLE} being killed.\n"; - kill ('TERM', $self->{PROCESS}); - } - - return $self->WaitKill ($timeout); -} - -# really only for internal use -sub check_return_value ($) -{ - my $self = shift; - my $rc = shift; - - if ($rc == 0) { - return 0; - } - elsif ($rc == 0xff00) { - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> failed: $!\n"; - return ($rc >> 8); - } - elsif (($rc & 0xff) == 0) { - $rc >>= 8; - return $rc; - } - - my $dump = 0; - - if ($rc & 0x80) { - $rc &= ~0x80; - $dump = 1; - } - - # check for ABRT, KILL or TERM - if ($rc == 6 || $rc == 9 || $rc == 15) { - return 0; - } - - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> exited with "; - - print STDERR "coredump from " if ($dump == 1); - - print STDERR "signal $rc : ", $signame[$rc], "\n"; - - return 0; -} - -sub Kill () -{ - my $self = shift; - - if ($self->{RUNNING}) { - kill ('KILL', $self->{PROCESS}); - waitpid ($self->{PROCESS}, 0); - $self->check_return_value ($?); - } - - $self->{RUNNING} = 0; -} - -# Wait until a process exits. -# return -1 if the process is still alive. -sub Wait ($) -{ - my $self = shift; - my $timeout = shift; - if (!defined $timeout || $timeout < 0) { - waitpid ($self->{PROCESS}, 0); - } else { - return TimedWait($self, $timeout); - } - -} - -sub TimedWait ($) -{ - my $self = shift; - my $timeout = shift; - - $timeout *= $PerlACE::Process::WAIT_DELAY_FACTOR; - - my $status; - my $pid = VmsProcess::TimedWaitPid ($self->{PROCESS}, $timeout, $status); - if ($pid > 0) { - return $self->check_return_value ($status); - } - return -1; -} - -1; diff --git a/ACE/bin/PerlACE/Process_Win32.pm b/ACE/bin/PerlACE/Process_Win32.pm deleted file mode 100644 index 2f0163b2da6..00000000000 --- a/ACE/bin/PerlACE/Process_Win32.pm +++ /dev/null @@ -1,405 +0,0 @@ -# $Id$ - -use PerlACE::Run_Test; - -package PerlACE::Process; - -use strict; -use Win32::Process; -use File::Basename; -use Cwd; - -############################################################################### - -# This is what GetExitCode will return if the process is still running. -my $STILL_ACTIVE = 259; - -############################################################################### - -### Constructor and Destructor - -# -# Hack in purify support thru 2 environment variables: -# ACE_RUN_PURIFY_CMD: complete path to purify executable -# ACE_RUNTEST_DELAY: wait delay factor, default to 10 if -# ACE_RUN_PURIFY_CMD is defined, or 1 if -# ACE_RUN_PURIFY_CMD is not defined. -# ** Notice that when ACE_RUN_PURIFY_CMD is define, PerlACE::Process -# reports the return status of *purify*, not the process being purified. -# -# Also hack in the ability to run the test on a WinCE device using the -# ACE_WINCE_TEST_CONTROLLER environment variable. If set, it specifies a -# controlling program to use for setting up and executing the test. -# Further setup can be specialized depending on the value of the variable. - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = {}; - - $self->{RUNNING} = 0; - $self->{IGNOREEXESUBDIR} = 0; - $self->{IGNOREHOSTROOT} = 0; - $self->{PROCESS} = undef; - $self->{EXECUTABLE} = shift; - $self->{ARGUMENTS} = shift; - $self->{PURIFY_CMD} = $ENV{"ACE_RUN_PURIFY_CMD"}; - $self->{PURIFY_OPT} = $ENV{"ACE_RUN_PURIFY_OPT"}; - if (!defined $PerlACE::Process::WAIT_DELAY_FACTOR) { - if (defined $self->{PURIFY_CMD}) { - $PerlACE::Process::WAIT_DELAY_FACTOR = 10; - } - else { - $PerlACE::Process::WAIT_DELAY_FACTOR = 1; - } - } - $self->{WINCE_CTL} = $ENV{"ACE_WINCE_TEST_CONTROLLER"}; - - bless ($self, $class); - return $self; -} - -sub DESTROY -{ - my $self = shift; - - if ($self->{RUNNING} == 1) { - print STDERR "ERROR: <", $self->{EXECUTABLE}, - "> still running upon object destruction\n"; - $self->Kill (); - } -} - -############################################################################### - -### Some Accessors - -sub Normalize_Executable_Name -{ - my $executable = shift; - - my $basename = basename ($executable); - my $dirname = dirname ($executable). '/'; - - $executable = $dirname.$PerlACE::Process::ExeSubDir.$basename.".EXE"; - - ## Installed executables do not conform to the ExeSubDir - if (! -x $executable && -x $dirname.$basename.'.EXE') { - $executable = $dirname.$basename.'.EXE'; - } - - $executable =~ s/\//\\/g; # / <- # color coding issue in devenv - - return $executable; -} - - -sub Executable -{ - my $self = shift; - - if (@_ != 0) { - $self->{EXECUTABLE} = shift; - } - - my $executable = $self->{EXECUTABLE}; - - if ($self->{IGNOREHOSTROOT} == 0) { - if (PerlACE::is_vxworks_test()) { - $executable = PerlACE::VX_HostFile ($executable); - } - } - - if ($self->{IGNOREEXESUBDIR} == 0) { - $executable = PerlACE::Process::Normalize_Executable_Name ($executable); - } - else { - if ($executable !~ m/.EXE$/i) { - $executable = $executable.".EXE"; - } - $executable =~ s/\//\\/g; # / <- # color coding issue in devenv - } - - 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; -} - -sub IgnoreExeSubDir -{ - my $self = shift; - - if (@_ != 0) { - $self->{IGNOREEXESUBDIR} = shift; - } - - return $self->{IGNOREEXESUBDIR}; -} - -sub IgnoreHostRoot -{ - my $self = shift; - - if (@_ != 0) { - $self->{IGNOREHOSTROOT} = shift; - } - - return $self->{IGNOREHOSTROOT}; -} - -############################################################################### - -### 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; - } - - if ($self->{IGNOREEXESUBDIR} == 0) { - if (!-f $self->Executable ()) { - print STDERR "ERROR: Cannot Spawn: <", $self->Executable (), - "> not found\n"; - return -1; - } - - if (!-x $self->Executable ()) { - print STDERR "ERROR: Cannot Spawn: <", $self->Executable (), - "> not executable\n"; - return -1; - } - } - - my $state = 0; - my $cmdline = ""; - my $executable = ""; - - if (defined $self->{PURIFY_CMD}) { - my $orig_cmdline = $self->CommandLine (); - $executable = $self->{PURIFY_CMD}; - my $basename = basename ($self->{EXECUTABLE}); - - my $PurifyOptions = $self->{PURIFY_OPT}; - if (!defined $PurifyOptions) { - $PurifyOptions = - "/run ". -# "/save-data=$basename.pfy ". - "/save-text-data=$basename.pfytxt ". - "/AllocCallStackLength=20 ". - "/ErrorCallStackLength=20 ". - "/HandlesInUseAtExit ". - "/InUseAtExit ". - "/LeaksAtExit "; - } - my $basename = basename ($self->{EXECUTABLE}); - $cmdline = - "purify " . - "$PurifyOptions ". - "$orig_cmdline" ; - } - elsif (defined $self->{WINCE_CTL}) { - $executable = $self->Executable (); - $cmdline = $self->CommandLine (); - - # Generate a script to copy the test down to the device, run it, - # copy the log file(s) back to the log directory, then delete the - # program and log files on the remote device. - unless (open (SCRIPT, ">start_test.cmd")) { - print STDERR "ERROR: Cannot Spawn: <", $self->Executable (), - "> failed to create start_test.cmd\n"; - return -1; - } - - my $testname = basename($executable,'.EXE'); - my $here = getcwd(); - $here =~ s/\//\\/g; - $executable =~ s/^\.//; # Chop leading . - $executable = $here . $executable; # Fully qualified name - # Take off the test name from the start of the command line. - # The command name is preprended in the script below. - my @tokens = split(' ', $cmdline); - @tokens = splice(@tokens,1); - $cmdline = join(' ', @tokens); - print SCRIPT "copy $executable 1:\\Windows\n"; - print SCRIPT "start /wait $testname $cmdline\n"; - print SCRIPT "copy 1:\\log\\$testname*.txt $here\\log\n"; - print SCRIPT "del 1:\\Windows\\$testname.exe\n"; - print SCRIPT "del 1:\\log\\$testname*.txt\n"; - close SCRIPT; - - $executable = $ENV{"ComSpec"}; - my $pocket_device_opts = $ENV{"ACE_PCE_DEVICE"}; - $cmdline = "cmd /C start /B /WAIT $self->{WINCE_CTL} $pocket_device_opts -m NAME=start_test.cmd;WAIT=401000; -e" - } - elsif (defined $ENV{'ACE_TEST_WINDOW'}) { - $state = ($ENV{'ACE_TEST_WINDOW'} =~ /\/k/i ? CREATE_NEW_CONSOLE : DETACHED_PROCESS); - $executable = $ENV{'ComSpec'}; - $cmdline = $ENV{'ACE_TEST_WINDOW'} . ' ' . $self->CommandLine(); - } - else { - $executable = $self->Executable (); - $cmdline = $self->CommandLine (); - } - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "$executable $cmdline\n"; - } - Win32::Process::Create ($self->{PROCESS}, - $executable, - $cmdline, - 0, - $state, - '.'); - - my $status = 0; - - Win32::Process::GetExitCode ($self->{PROCESS}, $status); - - if ($status != $STILL_ACTIVE) { - print STDERR "ERROR: Spawn failed for <", $self->CommandLine (), ">\n"; - return -1; - } - - $self->{RUNNING} = 1; - return 0; -} - - -# Wait for the process to exit or kill after a time period - -sub WaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - my $status = $self->TimedWait ($timeout); - - 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 $timeout = shift; - - if ($self->Spawn () == -1) { - return -1; - } - - return $self->WaitKill ($timeout); -} - - -# Kill the process - -sub Kill ($) -{ - my $self = shift; - my $notused = shift; #Used in Process_Unix.pm - - if ($self->{RUNNING} && !defined $ENV{'ACE_TEST_WINDOW'}) { - Win32::Process::Kill ($self->{PROCESS}, -1); - } - - $self->{RUNNING} = 0; -} - - -# Terminate the process and wait for it to finish - -sub TerminateWaitKill ($) -{ - my $self = shift; - my $timeout = shift; - - if ($self->{RUNNING}) { - print STDERR "INFO: $self->{EXECUTABLE} being killed.\n"; - Win32::Process::Kill ($self->{PROCESS}, 0); - } - - return $self->WaitKill ($timeout); -} - - -# Wait until a process exits. -# return -1 if the process is still alive. - -sub Wait ($) -{ - my $self = shift; - my $timeout = shift; - if (!defined $timeout || $timeout < 0) { - $timeout = INFINITE; - } else { - $timeout = $timeout * 1000 * $PerlACE::Process::WAIT_DELAY_FACTOR; - } - - my $result = 0; - - if ($self->{RUNNING}) { - $result = Win32::Process::Wait ($self->{PROCESS}, $timeout); - if ($result == 0) { - return -1; - } - } - Win32::Process::GetExitCode ($self->{PROCESS}, $result); - return $result; -} - - -# Wait for a process to exit with a timeout - -sub TimedWait ($) -{ - my($self) = shift; - my($timeout) = shift; - return $self->Wait($timeout); -} - -1; diff --git a/ACE/bin/PerlACE/Run_Test.pm b/ACE/bin/PerlACE/Run_Test.pm deleted file mode 100644 index edb159f4e4d..00000000000 --- a/ACE/bin/PerlACE/Run_Test.pm +++ /dev/null @@ -1,246 +0,0 @@ -# $Id$ - -# This module contains a few miscellanous functions and some -# startup ARGV processing that is used by all tests. - -use PerlACE::Process; -use PerlACE::ConfigList; - -package PerlACE; -use File::Spec; -use Cwd; - -$PerlACE::ACE_ROOT = $ENV{ACE_ROOT}; -if(exists $ENV{TAO_ROOT}) { - $PerlACE::TAO_ROOT = $ENV{TAO_ROOT}; -} else { - $PerlACE::TAO_ROOT = "$PerlACE::ACE_ROOT/TAO"; -} -if(exists $ENV{CIAO_ROOT}) { - $PerlACE::CIAO_ROOT = $ENV{CIAO_ROOT}; -} else { - $PerlACE::CIAO_ROOT = "$PerlACE::TAO_ROOT/CIAO"; -} - -my $config = new PerlACE::ConfigList; -$PerlACE::TestConfig = $config; - -# load VxWorks Process helpers in case this is a VxWorks target build -$PerlACE::VxWorks_Test = $config->check_config("VxWorks"); -$PerlACE::VxWorks_RTP_Test = $config->check_config("VxWorks_RTP"); -if ($PerlACE::VxWorks_Test or $PerlACE::VxWorks_RTP_Test) { - require PerlACE::ProcessVX; -} - -# Load LabVIEW RT Process helpers in case this is a LabVIEW RT target build. -$PerlACE::LabVIEW_RT_Test = $config->check_config("LabVIEW_RT"); -if ($PerlACE::LabVIEW_RT_Test) { - require PerlACE::ProcessLVRT; -} - -# Figure out the svc.conf extension -$svcconf_ext = $ENV{"ACE_RUNTEST_SVCCONF_EXT"}; -if (!defined $svcconf_ext) { - $svcconf_ext = ".conf"; -} - -# Default timeout. NSCORBA needs more time for process start up. -$wait_interval_for_process_creation = (($PerlACE::VxWorks_Test or $PerlACE::VxWorks_RTP_Test) ? 60 : 15); -if ($^O eq 'VMS') { - $wait_interval_for_process_creation *= 3; -} - -$wait_interval_for_process_shutdown = (($PerlACE::VxWorks_Test or $PerlACE::VxWorks_RTP_Test) ? 30 : 10); - -# Turn on autoflush -$| = 1; - -sub LocalFile ($) -{ - my $file = shift; - - my $newfile = getcwd () . '/' . $file; - - if ($^O eq "MSWin32") { - $newfile =~ s/\//\\/g; - } - elsif ($^O eq 'cygwin') { - chop($newfile = `/usr/bin/cygpath -w $newfile`); - $newfile =~ s/\\/\\\\/g; - } - - return $newfile; -} - -sub VX_HostFile($) -{ - my $file = shift; - $file = File::Spec->rel2abs ($file); - $file = File::Spec->abs2rel ($file, $ENV{"ACE_ROOT"}); - return $ENV{"HOST_ROOT"}."/".$file; -} - -# Returns a random port within the range of 10002 - 32767 -sub random_port { - return (int(rand($$)) % 22766) + 10002; -} - -# 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 $>; - } -} - -# 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; - $maxtime *= (($PerlACE::VxWorks_Test || $PerlACE::VxWorks_RTP_Test) ? $PerlACE::ProcessVX::WAIT_DELAY_FACTOR : $PerlACE::Process::WAIT_DELAY_FACTOR); - - while ($maxtime-- != 0) { - if (-e $file && -s $file) { - return 0; - } - sleep 1; - } - return -1; -} - -sub check_n_cleanup_files -{ - my $file = shift; - my @flist = glob ($file); - - my $cntr = 0; - my $nfile = scalar(@flist); - - if ($nfile != 0) { - for (; $cntr < $nfile; $cntr++) { - print STDERR "File <$flist[$cntr]> exists but should be cleaned up\n"; - } - unlink @flist; - } -} - -sub generate_test_file -{ - my $file = shift; - my $size = shift; - - while ( -e $file ) { - $file = $file."X"; - } - - my $data = "abcdefghijklmnopqrstuvwxyz"; - $data = $data.uc($data)."0123456789"; - - open( INPUT, "> $file" ) || die( "can't create input file: $file" ); - for($i=62; $i < $size ; $i += 62 ) { - print INPUT $data; - } - $i -= 62; - if ($i < $size) { - print INPUT substr($data, 0, $size-$i); - } - close(INPUT); - - return $file; -} - -sub is_vxworks_test() -{ - return ($PerlACE::VxWorks_Test || $PerlACE::VxWorks_RTP_Test); -} - -sub is_vxworks_rtp_test() -{ - return ($PerlACE::VxWorks_RTP_Test); -} - -sub add_path { - my $name = shift; - my $value = shift; - if (defined $ENV{$name}) { - $ENV{$name} .= ($^O eq 'MSWin32' ? ';' : ':') . $value - } - else { - $ENV{$name} = $value; - } -} - -sub add_lib_path { - my($value) = shift; - - # Set the library path supporting various platforms. - add_path('PATH', $value); - add_path('LD_LIBRARY_PATH', $value); - add_path('LIBPATH', $value); - add_path('SHLIB_PATH', $value); - - if (defined $ENV{"HOST_ROOT"}) { - add_path('PATH', VX_HostFile ($value)); - add_path('LD_LIBRARY_PATH', VX_HostFile ($value)); - add_path('LIBPATH', VX_HostFile ($value)); - add_path('SHLIB_PATH', VX_HostFile ($value)); - } -} - -sub check_privilege_group { - if ($^O eq 'hpux') { - my($access) = 'RTSCHED'; - my($status) = 0; - my($getprivgrp) = '/bin/getprivgrp'; - - if (-x $getprivgrp) { - if (open(GPG, "$getprivgrp |")) { - while(<GPG>) { - if (index($_, $access) >= 0) { - $status = 1; - } - } - close(GPG); - } - } - - if (!$status) { - print STDERR "WARNING: You must have $access privileges to run this test.\n", - " Run \"man 1m setprivgrp\" for more information.\n"; - exit(0); - } - } -} - -# Add PWD to the load library path -add_lib_path ('.'); - -$sleeptime = 5; - -1; diff --git a/ACE/bin/PerlACE/TestTarget.pm b/ACE/bin/PerlACE/TestTarget.pm deleted file mode 100644 index af0b39a9eae..00000000000 --- a/ACE/bin/PerlACE/TestTarget.pm +++ /dev/null @@ -1,87 +0,0 @@ -# $Id$ -# -# The TestTarget class is for operations that are per-target while testing. -# They can be overridden for specific needs like embedded systems, etc. - -package PerlACE::TestTarget; - -use strict; -use English; -use POSIX qw(:time_h); - -############################################################################### - -# Create the proper kind of TestTarget based on arguments or test -# configuration. Pass the PerlACE::ConfigList as the first argument. - -sub create_target -{ - my $config = shift; - my $target = undef; - if ($config->check_config("LabVIEW_RT")) { - require PerlACE::TestTarget_LVRT; - $target = new PerlACE::TestTarget_LVRT; - } - else { - $target = new PerlACE::TestTarget; - } - return $target; -} - -### Constructor and Destructor - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = {}; - - bless ($self, $class); - return $self; -} - -sub DESTROY -{ - my $self = shift; -} - -################################################################## - -sub LocalFile ($) -{ - my $self = shift; - my $file = shift; - my $newfile = PerlACE::LocalFile($file); - return $newfile; -} - -sub DeleteFile ($) -{ - my $self = shift; - my $file = shift; - unlink $file; -} - -sub WaitForFileTimed ($) -{ - my $self = shift; - my $file = shift; - my $timeout = shift; - return PerlACE::waitforfile_timed ($file, $timeout); -} - -sub CreateProcess ($) -{ - my $self = shift; - my $process = new PerlACE::Process (@_); - return $process; -} - -# Don't need to do anything in most cases. -sub GetStderrLog ($) -{ - my $self = shift; - return; -} - -1; diff --git a/ACE/bin/PerlACE/TestTarget_LVRT.pm b/ACE/bin/PerlACE/TestTarget_LVRT.pm deleted file mode 100644 index a00a85fd306..00000000000 --- a/ACE/bin/PerlACE/TestTarget_LVRT.pm +++ /dev/null @@ -1,161 +0,0 @@ -# $Id$ -# -# TestTarget_LVRT - how to manage the test environment on a LabVIEW RT target. -# -# We can FTP files to and from the LabVIEW target, but there's no NFS or -# SMB shares. -# Most information about the target itself is specified via environment -# variables. The current environment variables are: -# ACE_RUN_LVRT_TGTHOST - the host name/IP of the target. -# ACE_RUN_LVRT_FSROOT - the root of the filesystem on the target where -# ACE files will be created from (cwd, if you will). -# If not specified, "\ni-rt" is used as the root. - -package PerlACE::TestTarget_LVRT; -our @ISA = "PerlACE::TestTarget"; - -### Constructor and Destructor - -sub new -{ - my $proto = shift; - my $class = ref ($proto) || $proto; - my $self = {}; - - my $targethost; - if (defined $ENV{'ACE_RUN_LVRT_TGTHOST'}) { - $targethost = $ENV{'ACE_RUN_LVRT_TGTHOST'}; - } - else { - print STDERR "You must define target hostname/IP with ", - "ACE_RUN_LVRT_TGTHOST\n"; - return -1; - } - - my $fsroot = $ENV{'ACE_RUN_LVRT_FSROOT'}; - if (!defined $fsroot) { - $fsroot = '\\ni-rt'; - } - $self->{FSROOT} = $fsroot; - - $self->{FTP} = new Net::FTP ($targethost); - $self->{TGTHOST} = $targethost; - if (!defined $self->{FTP}) { - print STDERR "$@\n"; - return -1; - } - $self->{FTP}->login("",""); - $self->{TARGET} = undef; - $self->{REBOOT_TIME} = $ENV{"ACE_RUN_LVRT_REBOOT_TIME"}; - if (!defined $self->{REBOOT_TIME}) { - $self->{REBOOT_TIME} = 200; - } - - bless ($self, $class); - return $self; -} - -################################################################## - -sub LocalFile ($) -{ - my $self = shift; - my $file = shift; - my $newfile = $self->{FSROOT} . '\\' . $file; - print STDERR "LVRT LocalFile for $file is $newfile\n"; - return $newfile; -} - -sub DeleteFile ($) -{ - my $self = shift; - my $file = shift; - $self->{FTP}->login("",""); - $self->{FTP}->delete($file); -} - -sub WaitForFileTimed ($) -{ - my $self = shift; - my $file = shift; - my $timeout = shift; - my $targetport = 8888; - my $target = new Net::Telnet(Timeout => 600, Errmode => 'return'); - if (!$target->open(Host => $self->{TGTHOST}, Port => $targetport)) { - print STDERR "ERROR: target $self->{TGTHOST}:$targetport: ", - $target->errmsg(), "\n"; - return -1; - } - my $cmdline = "waitforfile $file $timeout"; - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "-> $cmdline\n"; - } - $target->print("$cmdline"); - my $reply; - $reply = $target->getline(); - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "<- $reply\n"; - } - $target->close(); - if ($reply eq "OK\n") { - return 0; - } - return -1; -} - -sub CreateProcess ($) -{ - my $self = shift; - my $process = new PerlACE::ProcessLVRT (@_); - return $process; -} - -sub GetStderrLog ($) -{ - my $self = shift; - # Tell the target to snapshot the stderr log; if there is one, copy - # it up here and put it out to our stderr. - my $targetport = 8888; - my $target = new Net::Telnet(Timeout => 600, Errmode => 'return'); - if (!$target->open(Host => $self->{TGTHOST}, Port => $targetport)) { - print STDERR "ERROR: target $self->{TGTHOST}:$targetport: ", - $target->errmsg(), "\n"; - return; - } - my $cmdline = "snaplog"; - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "-> $cmdline\n"; - } - $target->print("$cmdline"); - my $reply; - $reply = $target->getline(); - if (defined $ENV{'ACE_TEST_VERBOSE'}) { - print "<- $reply\n"; - } - $target->close(); - if ($reply eq "NONE\n") { - return; - } - chomp $reply; - $self->{FTP}->ascii(); - if ($self->{FTP}->get($reply, "stderr.txt")) { - $self->{FTP}->delete($reply); - open(LOG, "stderr.txt"); - while (<LOG>) { - print STDERR; - } - close LOG; - unlink "stderr.txt"; - } - return; -} - -# Copy a file to the target. Adjust for different types (DLL, EXE, TEXT) -# and debug/non (for DLLs). Additionally, a file can be removed when this -# object is deleted, or left in place. -sub NeedFile ($) -{ - my $self = shift; -} - -1; diff --git a/ACE/bin/PerlACE/perlace.mpc b/ACE/bin/PerlACE/perlace.mpc deleted file mode 100644 index 8139eee3a2d..00000000000 --- a/ACE/bin/PerlACE/perlace.mpc +++ /dev/null @@ -1,13 +0,0 @@ -// -*- MPC -*- -// $Id$ - -project(PerlACE) : script { - Script_Files { - ConfigList.pm - Process.pm - Process_Unix.pm - Process_Win32.pm - Run_Test.pm - } - custom_only=1 -} |