<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#! /usr/bin/perl
# $Id: TestTarget.pm 97724 2014-04-18 06:55:25Z mcorino $
#
# 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);
use File::Copy;
use File::Spec;
use File::Basename;
use PerlACE::Run_Test;
use Socket;
use Sys::Hostname;
use Cwd;

###############################################################################

# Create the proper kind of TestTarget based on specified test component.
# Pass the component number as the first argument. If there's no
# DOC_TEST_&lt;component-number&gt; environment variable, use the local machine.

sub create_target
{
    my $component = shift;
    if ($component == 0) {
        print STDERR "Warning: components should be numbers, not names\n";
    }
    my $target = undef;
    my $envname = "DOC_TEST_\U$component";
    if (!exists $ENV{$envname}) {
        $envname = "DOC_TEST_DEFAULT";
        if (!exists $ENV{$envname}) {
          $target = new PerlACE::TestTarget("default");
          return $target;
        }
    }
    my $config_name = $ENV{$envname};
    # There's a configuration name; use it to look up the platform.
    $config_name = uc $config_name;
    $envname = $config_name.'_OS';
    if (!exists $ENV{$envname}) {
        print STDERR "$config_name requires an OS type in $envname\n";
        return undef;
    }
    my $config_os = $ENV{$envname};
    SWITCH: {
      if ($config_os =~ m/local|remote/i) {
        $target = new PerlACE::TestTarget ($config_name);
        last SWITCH;
      }
      if ($config_os =~ m/LabVIEW_RT/i) {
        require PerlACE::TestTarget_LVRT;
        $target = new PerlACE::TestTarget_LVRT ($config_name);
        last SWITCH;
      }
      if ($config_os =~ /VxWorks/i) {
        require PerlACE::TestTarget_VxWorks;
        $target = new PerlACE::TestTarget_VxWorks ($config_name);
        last SWITCH;
      }
      if ($config_os =~ /WinCE/i) {
        require PerlACE::TestTarget_WinCE;
        $target = new PerlACE::TestTarget_WinCE ($config_name);
        last SWITCH;
      }
      if ($config_os =~ /ANDROID/i) {
        require PerlACE::TestTarget_Android;
        $target = new PerlACE::TestTarget_Android ($config_name, $component);
        last SWITCH;
      }
      print STDERR "$config_os is an unknown OS type!\n";
    }
    return $target;
}

### Constructor and Destructor

sub new
{
    my $proto = shift;
    my $class = ref ($proto) || $proto;
    my $self = {};

    my $config_name = shift;
    bless ($self, $class);
    $self-&gt;GetConfigSettings($config_name);

    return $self;
}

sub DESTROY
{
    my $self = shift;
}

# If there was a config name specified, use it to look up the configure
# info. Else, use the traditional defaults.
sub GetConfigSettings ($)
{
    my $self = shift;
    my $config_name = shift;
    my $env_prefix = '';
    my $fs_root;
    my $tgt_fs_root;

    if (defined $config_name) {
        $env_prefix = $config_name."_";
    }

    my $env_name = $env_prefix.'ACE_ROOT';
    if (exists $ENV{$env_name}) {
        $self-&gt;{ace_root} = $ENV{$env_name};
    }
    else {
        # Fall back to naked ACE_ROOT if no config-specific one.
        $self-&gt;{ace_root} = $ENV{'ACE_ROOT'};
    }
    $tgt_fs_root = dirname($self-&gt;{ace_root});
    if (exists $ENV{'ACE_ROOT'}) {
        $fs_root = dirname($ENV{'ACE_ROOT'});
    } else {
        $fs_root = $tgt_fs_root;
    }
    $env_name = $env_prefix.'TAO_ROOT';
    if (exists $ENV{$env_name})
    {
      $self-&gt;{tao_root} = $ENV{$env_name};
    } elsif ($fs_root ne $tgt_fs_root &amp;&amp; -d "$fs_root/TAO") {
        # flat directory structure
        $self-&gt;{tao_root} = "$tgt_fs_root/TAO";
    } elsif ($fs_root ne $tgt_fs_root &amp;&amp; -d "$fs_root/ACE/TAO") {
        # hierarchical struture
        $self-&gt;{tao_root} = "$self-&gt;{ace_root}/TAO";
    } elsif (exists $ENV{'TAO_ROOT'}) {
        if ($fs_root ne $tgt_fs_root) {
            $self-&gt;{tao_root} =
                PerlACE::rebase_path ($ENV{'TAO_ROOT'}, $fs_root, $tgt_fs_root);
        } else {
            $self-&gt;{tao_root} = $ENV{'TAO_ROOT'};
        }
    } else {
        # fall back to assuming classic hierarchical struture
        $self-&gt;{tao_root} = "$self-&gt;{ace_root}/TAO";
    }
    $env_name = $env_prefix.'CIAO_ROOT';
    if (exists $ENV{$env_name}) {
        $self-&gt;{ciao_root} = $ENV{$env_name};
    } elsif ($fs_root ne $tgt_fs_root &amp;&amp; -d "$fs_root/CIAO") {
        # flat directory structure
        $self-&gt;{ciao_root} = "$tgt_fs_root/CIAO";
    } elsif ($fs_root ne $tgt_fs_root &amp;&amp; -d "$fs_root/ACE/TAO/CIAO") {
        # hierarchical struture
        $self-&gt;{ciao_root} = "$self-&gt;{tao_root}/CIAO";
    } elsif (exists $ENV{'CIAO_ROOT'}) {
        if ($fs_root ne $tgt_fs_root) {
            $self-&gt;{ciao_root} =
                PerlACE::rebase_path ($ENV{'CIAO_ROOT'}, $fs_root, $tgt_fs_root);
        } else {
            $self-&gt;{ciao_root} = $ENV{'CIAO_ROOT'};
        }
    } else {
        # fall back to assuming classic hierarchical struture
        $self-&gt;{ciao_root} = "$self-&gt;{tao_root}/CIAO";
    }

    $env_name = $env_prefix.'DANCE_ROOT';
    if (exists $ENV{$env_name}) {
        $self-&gt;{dance_root} = $ENV{$env_name};
    } elsif ($fs_root ne $tgt_fs_root &amp;&amp; -d "$fs_root/DAnCE") {
        # flat directory structure
        $self-&gt;{dance_root} = "$tgt_fs_root/DAnCE";
    } elsif ($fs_root ne $tgt_fs_root &amp;&amp; -d "$fs_root/ACE/TAO/DAnCE") {
        # hierarchical struture
        $self-&gt;{dance_root} = "$self-&gt;{tao_root}/DAnCE";
    } elsif (exists $ENV{'DANCE_ROOT'}) {
        if ($fs_root ne $tgt_fs_root) {
            $self-&gt;{dance_root} =
                PerlACE::rebase_path ($ENV{'DANCE_ROOT'}, $fs_root, $tgt_fs_root);
        } else {
            $self-&gt;{dance_root} = $ENV{'DANCE_ROOT'};
        }
    } else {
        # fall back to assuming classic hierarchical struture
        $self-&gt;{dance_root} = "$self-&gt;{tao_root}/DAnCE";
    }

    if ($fs_root ne $tgt_fs_root) {
      $self-&gt;{HOST_FSROOT} = dirname ($fs_root);
      $self-&gt;{TARGET_FSROOT} = dirname ($tgt_fs_root);
    }

    $env_name = $env_prefix.'EXE_SUBDIR';
    if (exists $ENV{$env_name}) {
        $self-&gt;{EXE_SUBDIR} = $ENV{$env_name}.'/';
    } else {
        # If no ExeSubDir given via env variable, and this is an unnamed
        # config, allow use of the subdir specified on the command line.
        # This preserves historical behavior.
        if (defined $config_name &amp;&amp; $config_name ne 'default') {
            $self-&gt;{EXE_SUBDIR} = './';
        }
        else {
            $self-&gt;{EXE_SUBDIR} = $PerlACE::Process::ExeSubDir;
        }
    }
    $env_name = $env_prefix.'ARCH';
    if (exists $ENV{$env_name}) {
        $self-&gt;{ARCH} = $ENV{$env_name};
    } elsif ($config_name eq 'default'
             &amp;&amp; grep(($_ eq 'ARCH'), @PerlACE::ConfigList::Configs)) {
        $self-&gt;{ARCH} = 1;
    }
    $env_name = $env_prefix.'PROCESS_START_WAIT_INTERVAL';
    if (exists $ENV{$env_name}) {
        $self-&gt;{PROCESS_START_WAIT_INTERVAL} = $ENV{$env_name};
    } else {
        $self-&gt;{PROCESS_START_WAIT_INTERVAL} = 15;
    }
    $env_name = $env_prefix.'PROCESS_STOP_WAIT_INTERVAL';
    if (exists $ENV{$env_name}) {
        $self-&gt;{PROCESS_STOP_WAIT_INTERVAL} = $ENV{$env_name};
    } else {
        $self-&gt;{PROCESS_STOP_WAIT_INTERVAL} = 10;
    }
    $env_name = $env_prefix.'ADB_WAIT_FOR_DEVICE_TIMEOUT';
    if (exists $ENV{$env_name}) {
        $self-&gt;{ADB_WAIT_FOR_DEVICE_TIMEOUT} = $ENV{$env_name};
    } else {
        $self-&gt;{ADB_WAIT_FOR_DEVICE_TIMEOUT} = 120;
    }
    $env_name = $env_prefix.'HOSTNAME';
    if (exists $ENV{$env_name}) {
        $self-&gt;{HOSTNAME} = $ENV{$env_name};
    } else {
        $self-&gt;{HOSTNAME} = hostname();
    }
    $env_name = $env_prefix.'IP_ADDRESS';
    if (exists $ENV{$env_name}) {
        $self-&gt;{IP_ADDRESS} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'IBOOT';
    if (exists $ENV{$env_name}) {
        $self-&gt;{IBOOT} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'IBOOT_PASSWD';
    if (exists $ENV{$env_name}) {
        $self-&gt;{IBOOT_PASSWD} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'IBOOT_OUTLET';
    if (exists $ENV{$env_name}) {
        $self-&gt;{IBOOT_OUTLET} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'IBOOT_USER';
    if (exists $ENV{$env_name}) {
        $self-&gt;{IBOOT_USER} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'IBOOT_PASSWD';
    if (exists $ENV{$env_name}) {
        $self-&gt;{IBOOT_PASSWD} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'REBOOT_TIME';
    if (exists $ENV{$env_name}) {
        $self-&gt;{REBOOT_TIME} = $ENV{$env_name};
    } else {
        $self-&gt;{REBOOT_TIME} = 0;
    }
    $env_name = $env_prefix.'REBOOT';
    if (exists $ENV{$env_name}) {
        $self-&gt;{REBOOT} = $ENV{$env_name};
    } else {
        $self-&gt;{REBOOT} = 0;
    }
    $env_name = $env_prefix.'STARTUP_COMMAND';
    if (exists $ENV{$env_name}) {
        $self-&gt;{STARTUP_COMMAND} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'TELNET_HOST';
    if (exists $ENV{$env_name}) {
        $self-&gt;{TELNET_HOST} = $ENV{$env_name};
    } else {
        $self-&gt;{TELNET_HOST} = $self-&gt;{HOSTNAME};
    }
    $env_name = $env_prefix.'TELNET_PORT';
    if (exists $ENV{$env_name}) {
        $self-&gt;{TELNET_PORT} = $ENV{$env_name};
    } else {
        $self-&gt;{TELNET_PORT} = 23;
    }
    $env_name = $env_prefix.'HOST_ROOT';
    if (exists $ENV{$env_name}) {
        $self-&gt;{HOST_ROOT} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'SYSTEM_LIBS';
    if (exists $ENV{$env_name}) {
        $self-&gt;{SYSTEM_LIBS} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'REMOTE_SHELL';
    if (exists $ENV{$env_name}) {
        $self-&gt;{REMOTE_SHELL} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'LIBPATH';
    if (exists $ENV{$env_name}) {
        $self-&gt;{LIBPATH} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'REMOTE_FILETEST';
    if (exists $ENV{$env_name}) {
        $self-&gt;{REMOTE_FILETEST} = $ENV{$env_name};
    }
    $env_name = $env_prefix.'PS_CMD';
    if (exists $ENV{$env_name}) {
        $self-&gt;{PS_CMD} = $ENV{$env_name};
    }
    $self-&gt;{EXTRA_ENV} = {};
    $env_name = $env_prefix.'EXTRA_ENV';
    if (exists $ENV{$env_name}) {
        my @x_env = split (' ', $ENV{$env_name});
        foreach my $x_env_s (@x_env) {
            if ($x_env_s =~ /(\w+)=(.*)/) {
                $self-&gt;{EXTRA_ENV}-&gt;{$1} = $2;
            } elsif (exists $ENV{$env_prefix.$x_env_s}) {
                $self-&gt;{EXTRA_ENV}-&gt;{$x_env_s} = $ENV{$env_prefix.$x_env_s};
            }
        }
    }
    $self-&gt;{RUNTIME_LIBDEP} = ();
}

##################################################################

sub ACE_ROOT ($)
{
    my $self = shift;
    return $self-&gt;{ace_root};
}

sub TAO_ROOT ($)
{
    my $self = shift;
    return $self-&gt;{tao_root};
}

sub CIAO_ROOT ($)
{
    my $self = shift;
    return $self-&gt;{ciao_root};
}

sub DANCE_ROOT ($)
{
    my $self = shift;
    return $self-&gt;{dance_root};
}

sub HostName ($)
{
    my $self = shift;
    return $self-&gt;{HOSTNAME};
}

sub IP_Address ($)
{
    my $self = shift;
    if (!defined $self-&gt;{IP_ADDRESS}) {
      my @host = gethostbyname($self-&gt;{HOSTNAME});
      if (scalar(@host) == 0) {
          $self-&gt;{IP_ADDRESS} = "not found";
      } else {
          $self-&gt;{IP_ADDRESS} = inet_ntoa($host[4]);
      }
      if (defined $ENV{'ACE_TEST_VERBOSE'}) {
          print STDERR "Target host [" . $self-&gt;{HOSTNAME} . "] has ipaddres : " . $self-&gt;{IP_ADDRESS};
      }
    }
    return $self-&gt;{IP_ADDRESS};
}

sub ExeSubDir ($)
{
    my $self = shift;
    my $new_val = shift;
    if (defined $new_val) {
        $self-&gt;{EXE_SUBDIR} = $new_val;
    }
    return $self-&gt;{EXE_SUBDIR};
}

sub GetArchDir
{
    my $self = shift;
    my $dir = shift;
    if (exists $self-&gt;{ARCH}) {
        return $dir . $self-&gt;{EXE_SUBDIR};
    }
    return $dir;
}


sub SystemLibs ($)
{
    my $self = shift;
    return $self-&gt;{SYSTEM_LIBS};
}

sub RandomPort ($)
{
    my $self = shift;
    return (int(rand($$)) % 22766) + 10002;
}

sub ProcessStartWaitInterval ($)
{
    my $self = shift;
    return $self-&gt;{PROCESS_START_WAIT_INTERVAL};
}

sub ProcessStopWaitInterval ($)
{
    my $self = shift;
    return $self-&gt;{PROCESS_STOP_WAIT_INTERVAL};
}

sub AdbWaitForDeviceTimeout ($)
{
    my $self = shift;
    return $self-&gt;{ADB_WAIT_FOR_DEVICE_TIMEOUT};
}

sub LocalEnvDir ($)
{
    my $self = shift;
    my $dir = shift;
    my $newdir = $dir;
    if (defined $self-&gt;{TARGET_FSROOT}) {
      $newdir = PerlACE::rebase_path ($dir,
                                      $self-&gt;{HOST_FSROOT},
                                      $self-&gt;{TARGET_FSROOT});

    }
    if (defined $ENV{'ACE_TEST_VERBOSE'}) {
        print STDERR "LocalEnvDir for $dir is $newdir\n";
    }
    return $newdir;
}

sub LocalFile ($)
{
    my $self = shift;
    my $file = shift;
    my $newfile = PerlACE::LocalFile($file);
    if (defined $self-&gt;{TARGET_FSROOT}) {
      $newfile = PerlACE::rebase_path ($newfile,
                                       $self-&gt;{HOST_FSROOT},
                                       $self-&gt;{TARGET_FSROOT});
    }
    if (defined $ENV{'ACE_TEST_VERBOSE'}) {
        print STDERR "LocalFile for $file is $newfile\n";
    }
    return $newfile;
}

sub AddLibPath ($)
{
    my $self = shift;
    my $dir = shift;
    my $noarch = shift;

    # If we have -Config ARCH, use the -ExeSubDir setting as a sub-directory
    # of the lib path.  This is in addition to the regular LibPath.
    if (!$noarch &amp;&amp; defined $self-&gt;{ARCH}) {
        $self-&gt;AddLibPath($dir, 1);
        $dir .= '/' . $self-&gt;{EXE_SUBDIR};
    }

    if ($self-&gt;ACE_ROOT () eq $ENV{'ACE_ROOT'}) {
        # add (relative) path without rebasing
        if (defined $ENV{'ACE_TEST_VERBOSE'}) {
            print STDERR "Adding libpath $dir\n";
        }
        $self-&gt;{LIBPATH} = PerlACE::concat_path ($self-&gt;{LIBPATH}, $dir);
    } else {
        # add rebased path
        $dir = PerlACE::rebase_path ($dir, $self-&gt;{HOST_FSROOT}, $self-&gt;{TARGET_FSROOT});
        if (defined $ENV{'ACE_TEST_VERBOSE'}) {
            print STDERR "Adding libpath $dir\n";
        }
        $self-&gt;{LIBPATH} = PerlACE::concat_path ($self-&gt;{LIBPATH}, $dir);
    }
}

sub AddRuntimeLibrary ($)
{
    my $self = shift;
    my $lib = shift;
    push(@{$self-&gt;{RUNTIME_LIBDEP}}, $lib);
}

sub SetEnv ($)
{
    my $self = shift;
    my $env_name = shift;
    my $env_value = shift;
    $self-&gt;{EXTRA_ENV}-&gt;{$env_name} = $env_value;
}

sub GetEnv ($)
{
    my $self = shift;
    my $env_name = shift;
    return $self-&gt;{EXTRA_ENV}-&gt;{$env_name};
}

sub DeleteFile ($)
{
    my $self = shift;
    my $file = shift;
    my $newfile = PerlACE::LocalFile($file);
    unlink ($newfile);
}

sub GetFile ($)
{
    # On local host, the file is already there.
    my $self = shift;
    my $remote_file = shift;
    my $local_file = shift;
    return 0;
}

# Put file from a to b
sub PutFile ($)
{
    my $self = shift;
    my $src = shift;
    my $dest = $self-&gt;LocalFile ($src);
    if (($src ne $dest) &amp;&amp;
        (File::Spec-&gt;rel2abs($src) ne File::Spec-&gt;rel2abs($dest))) {
        copy ($src, $dest);
    }
    return 0;
}

sub WaitForFileTimed ($)
{
    my $self = shift;
    my $file = shift;
    my $timeout = shift;
    # expand path and possibly map to remote target root
    my $newfile = $self-&gt;LocalFile($file);
    if (defined $self-&gt;{REMOTE_SHELL} &amp;&amp; defined $self-&gt;{REMOTE_FILETEST}) {
        if (defined $ENV{'ACE_TEST_VERBOSE'}) {
            print STDERR "Waiting for remote $file using path $newfile\n";
        }

        $timeout *= $PerlACE::Process::WAIT_DELAY_FACTOR;
        my $cmd = $self-&gt;{REMOTE_SHELL};
        if ($self-&gt;{REMOTE_FILETEST} =~ /^\d*$/) {
            $cmd .= " 'test -e $newfile &amp;&amp; test -s $newfile ; echo \$?'";
        } else {
            $cmd .= $self-&gt;{REMOTE_FILETEST} . ' ' . $file;
        }
        my $rc = 1;
        my $mark_tm = time (); # start time
        while ($timeout &gt; 0) {
            $rc = int(`$cmd`);
            if ($rc == 0) {
                return 0;
            }
            select(undef, undef, undef, 0.1);
            $timeout -= (time () - $mark_tm);
            $mark_tm = time ();
        }
        return -1;
    } else {
        if (defined $ENV{'ACE_TEST_VERBOSE'}) {
            print STDERR "Waiting for local $file using path $newfile\n";
        }
        return PerlACE::waitforfile_timed ($newfile, $timeout);
    }
}

sub CreateProcess ($)
{
    my $self = shift;
    my $process = new PerlACE::Process (@_);
    $process-&gt;Target($self);
    return $process;
}

# Don't need to do anything in most cases.
sub GetStderrLog ($)
{
    my $self = shift;
    return;
}

sub KillAll ($)
{
    my $self = shift;
    my $procmask = shift;
    PerlACE::Process::kill_all ($procmask, $self);
}

1;
</pre></body></html>