TAO/tests/IOR_Endpoint_Hostnames/run_test.pl

   1 eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}'
   2      & eval 'exec perl -S $0 $argv:q'
   3      if 0;
   4
   5 # -*- perl -*-
   6
   7 #
   8 # This run_test.pl does not use the standard harness as used by other
   9 # run_test.pl.  Since it is testing a behavior of TAO which is
  10 # affected by environmental influences, it uses perl features as well
  11 # as separate executables to obtain information about the environment
  12 # so that it can inspect the information inside IORs and decide if
  13 # that information is "correct" given the environment.
  14 #
  15 # At the end, it prints out a matrix of each permutation of the test
  16 # and indicates whether or not that permutation FAILed.
  17 #
  18
  19 use lib "$ENV{ACE_ROOT}/bin";
  20 use PerlACE::TestTarget;
  21 use Socket;
  22
  23 $status = 0;
  24 $debug_level = '0';
  25
  26 foreach $i (@ARGV) {
  27     if ($i eq '-debug') {
  28         $debug_level = '10';
  29     }
  30 }
  31
  32 my $server = PerlACE::TestTarget::create_target (1) || die "Create target 1 failed\n";
  33
  34 $server->AddLibPath ($server->ExeSubDir ());
  35
  36 my $iorbase = "server.ior";
  37 my $server_iorfile = $server->LocalFile ($iorbase);
  38 my $database = "intf_run.data";
  39 my $server_datafile = $server->LocalFile ($database);
  40 $server->DeleteFile($iorbase);
  41 $server->DeleteFile($database);
  42
  43 $LI = $server->CreateProcess ("list_interfaces");
  44 $GI = $server->CreateProcess ("generate_ior");
  45 $CI = $server->CreateProcess ("$ENV{TAO_ROOT}/utils/catior/tao_catior",
  46                               "-f $server_iorfile");
  47
  48 open (OLDOUT, ">&STDOUT");
  49 open (STDOUT, ">$server_datafile") or die "can't redirect stdout: $!";
  50 open (OLDERR, ">&STDERR");
  51 open (STDERR, ">&STDOUT") or die "can't redirect stderror: $!";
  52
  53 $server_status = $LI->SpawnWaitKill ($server->ProcessStartWaitInterval());
  54
  55 open (STDOUT, ">&OLDOUT");
  56 open (STDERR, ">&OLDERR");
  57
  58 open (INTERFACES, "<$server_datafile") || die "Unable to open $server_datafile: $!\n";
  59 chomp(@IPADDRS = <INTERFACES>);
  60 close (INTERFACES);
  61
  62 if ($server_status != 0) {
  63     print STDERR "ERROR: server returned $server_status\n";
  64     exit 1;
  65 }
  66
  67 # Fill up the array of hostnames; can't use the hostname() from
  68 # Sys :: Hostname because it's too good at figuring out that IP
  69 # addresses that aren't in a host table actually DO match to a host
  70 # name.  So, we use gethostbyaddr().
  71 @HOSTNAMES = map { (gethostbyaddr(inet_aton($_),AF_INET))[0] || $_ } @IPADDRS;
  72
  73 $HN = hostname();  # Shorthand so we do not have to use 'hostname' all over.
  74
  75 @PERL_IPADDRS = map { inet_ntoa($_) || $_ } (gethostbyname($HN))[4];
  76
  77 #
  78 # $TEST_DATA is a reference to an anonymous hash that has
  79 #   key:  string representation/description of a test
  80 #   value: ref to anonymous array consisting of
  81 #          [0] = -ORBDottedDecimalAddresses value (must be 0 or 1)
  82 #          [1] = -ORBendpoint hosname spec (undef if not provided)
  83 #          [2] = -ORBendpoint "hostname_in_ior" value (undef if not provided)
  84 #          [3] = ref to array containing profiles expected in IOR
  85 #
  86
  87 $TEST_DATA = {
  88
  89 #
  90 # This is kind of like a "truth table" for what should happen when
  91 # -ORBDottedDecimalAddresses (DDA) and the "hostname_in_ior" (HIOR)
  92 # option for -ORBListenEndpoints (nee -ORBEndpoint) interact.  Note
  93 # that DDA's default value is "0", so there is no way to have an
  94 # unspecified value for DDA.
  95 #
  96 #
  97 #
  98 #        | -ORBendpoint  |
  99 #  DDA   |    hostspec   |   HIOR    | Profile(s) in IOR
 100 # --------------------------------------------------------------
 101 #   0    |    unspec     |  unspec   | One profile for each interface
 102 #                                      discovered in
 103 #                                      TAO_IIOP_Acceptor::probe_interfaces(),
 104 #                                      where the host's name is that
 105 #                                      returned from a reverse lookup of
 106 #                                      the interface's address from
 107 #                                      whatever facility is doing
 108 #                                      name<->address translations for
 109 #                                      that host.
 110
 111     "0:unspec:unspec" => [ 0, undef, undef, \@HOSTNAMES ],
 112
 113 #   1    |    unspec     |  unspec   | One profile for each interface
 114 #                                      discovered in
 115 #                                      TAO_IIOP_Acceptor::probe_interfaces(),
 116 #                                      where the host's name is the IP
 117 #                                      address associated with the
 118 #                                      interface.
 119
 120     "1:unspec:unspec" => [ 1, undef, undef, \@IPADDRS ],
 121
 122 #   0    |    "foo"      |  unspec   | Exactly one profile where the
 123 #                                      host's name is "foo".
 124
 125     "0:$HN:unspec" => [ 0, $HN, undef, [$HN] ],
 126
 127 #   1    |    "foo"      |  unspec   | Exactly one profile where the
 128 #                                      host's name is the IP address
 129 #                                      from the name<->address
 130 #                                      translation for the host.
 131
 132     "1:$HN:unspec" => [ 1, $HN, undef, \@PERL_IPADDRS ],
 133
 134 #   X    |    unspec     |  "bar"    | Exactly one profile where the
 135 #                                      host's name is "bar".
 136 #"d/c:unspec:".$HN."_blech" => [ undef, undef, $HN."_blech", [$HN."_blech"] ],
 137 #"d/c:unspec:blech" => [ undef, undef, "blech", ["blech"] ],
 138     "0:unspec:blech" => [ 0, undef, "blech", ["blech"] ],
 139     "1:unspec:blech" => [ 1, undef, "blech", ["blech"] ],
 140 #
 141 #   X    |    "foo"      |  "bar"    | Exactly one profile where the
 142 #                                      host's name is "bar".
 143 #"d/c:$HN:".$HN."_blech" => [ undef, $HN, $HN."_blech", [$HN."_blech"] ],
 144 #"d/c:$HN:blech" => [ undef, $HN, "blech", ["blech"] ],
 145     "0:$HN:blech" => [ 0, $HN, "blech", ["blech"] ],
 146     "1:$HN:blech" => [ 1, $HN, "blech", ["blech"] ],
 147 };
 148
 149
 150 sub do_test {
 151     # pass in undef for 'unspec' in the table
 152     my ($dda, $endpointhost, $hior) = @_;
 153
 154     $dda = 0 if (!defined($dda));
 155     $endpointhost = '' if (!defined($endpointhost));
 156     $hior_opt = ($hior ne '') ? "/hostname_in_ior=$hior" : '';
 157
 158     $server->DeleteFile($database);
 159
 160     $GI->Arguments ("-ORBListenEndpoints iiop://$endpointhost".$hior_opt." ".
 161                     "-ORBDottedDecimalAddresses $dda ".
 162                     "-o $server_iorfile");
 163
 164     $server_status = $GI->SpawnWaitKill ($server->ProcessStartWaitInterval());
 165
 166     if ($server_status != 0) {
 167         print STDERR "ERROR: server returned $server_status\n";
 168         exit 1;
 169     }
 170
 171     open (OLDOUT, ">&STDOUT");
 172     open (STDOUT, ">$server_datafile") or die "can't redirect stdout: $!";
 173     open (OLDERR, ">&STDERR");
 174     open (STDERR, ">&STDOUT") or die "can't redirect stderror: $!";
 175
 176     $server_status = $CI->SpawnWaitKill ($server->ProcessStartWaitInterval());
 177
 178     open (STDOUT, ">&OLDOUT");
 179     open (STDERR, ">&OLDERR");
 180
 181     if ($server_status != 0) {
 182         print STDERR "ERROR: server returned $server_status\n";
 183         exit 1;
 184     }
 185
 186     my @profiles;
 187     my $line;
 188 #    print $GI->Executable()." ".$GI->Arguments()."\n";
 189 #    print $CI->Executable()." ".$CI->Arguments()."\n";
 190     open (PIOR, "<$server_datafile") || die "Unable to exec generate_ior: $!\n";
 191 #    print "XXX: $_" while (<PIOR>);
 192     while ($line = <PIOR>) {
 193         # Need to look for the following lines:
 194         #   Host Name: <ipaddr_or_host>
 195         # and
 196         #   endpoint: <ipaddr_or_host>:<portnum>
 197         chomp $line;
 198         my $x;
 199 #        print "Looking at $line\n";
 200         if ($line =~ /.*Host Name:\s+(.+)$/) {
 201             chomp($x = $1);
 202 #            print "HN pushing $x\n";
 203             push @profiles, $x;
 204         } elsif ($line =~ /.*endpoint: ([^:]+):.*/) {
 205             chomp($x = $1);
 206 #            print "EP pushing $x\n";
 207             push @profiles, $x;
 208         }
 209     }
 210     close (PIOR);
 211
 212     $server->DeleteFile($database);
 213
 214     return @profiles;
 215 }
 216
 217 # Usage:
 218 #   $are_equal = compare_arrays(\@frogs, \@toads);
 219 sub compare_arrays {
 220     my ($first, $second) = @_;
 221     no warnings;                  # silence spurious -w undef complaints
 222     return 0 unless @$first == @$second;
 223
 224     @sorted_first = sort @$first;
 225     @sorted_second = sort @$second;
 226
 227     $first = \@sorted_first;
 228     $second = \@sorted_second;
 229     for (my $i = 0; $i < @$first; $i++) {
 230         return 0 if $first->[$i] ne $second->[$i];
 231     }
 232
 233     return 1;
 234 }
 235
 236 sub print_profiles {
 237     my ($test_info, $profiles_a) = @_;
 238
 239     print "$test_info: ", join(' ', @$profiles_a), "\n";
 240 }
 241
 242 sub check_profiles {
 243     my ($test_info, $found_profiles, $expected_profiles) = @_;
 244 #    &print_profiles($test_info, $profiles);
 245
 246     my $failinfo = [];
 247     # Do number of found profiles match expected?
 248     if ($#$found_profiles != $#$expected_profiles) {
 249         push @$failinfo, "(num IOR profiles[$#$found_profiles] != expected[$#$expected_profiles]";
 250     }
 251
 252     # Really need to compare these as hashes to avoid ordering issues.
 253     if (compare_arrays ($found_profiles, $expected_profiles) == 0) {
 254         push @$failinfo, "(profiles in IOR != profiles expected)";
 255         push @$failinfo, "Found profiles (".join(',', @$found_profiles).")";
 256     }
 257
 258     return $failinfo;
 259 }
 260
 261 # Brute force implementation of each of the lines in the table above
 262
 263 format STDOUT_TOP =
 264       |     |    -ORBendpoint     |                      |       Expected
 265 FAIL? | DDA |      hostspec       |    hostname_in_ior   |   Profile(s) in IOR
 266 *=============================================================================*
 267 .
 268 format STDOUT =
 269 @<<<  | @|| | @<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<< | ^<<<<<<<<<<<<<<<<<<<
 270 $pf,    $dda, $endpointhost,        $hior,                 $expected_prof_in_ior
 271 ~~    |     |                     |                      | ^<<<<<<<<<<<<<<<<<<<
 272                                                            $expected_prof_in_ior
 273 ~     | Details: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 274                     $detail
 275 ~~    |     |    ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 276                     $detail
 277 ------+-----+---------------------+----------------------+---------------------
 278 .
 279
 280 $: = ', ';
 281 for $test (sort keys %$TEST_DATA) {
 282     my $testargs = $TEST_DATA->{$test};
 283     my @p = &do_test ($testargs->[0], $testargs->[1], $testargs->[2]);
 284     my $failinfo = &check_profiles ($test, \@p, $TEST_DATA->{$test}[3]);
 285
 286     # Set up all the global vars so we can write our output
 287     ($dda, $endpointhost, $hior) = split(':', $test);
 288     $expected_prof_in_ior = join(',', @{$TEST_DATA->{$test}[3]});
 289     if ($#$failinfo != -1) {
 290         $pf = 'FAIL';
 291         $detail = join("\r", @$failinfo);
 292     } else {
 293         $pf = 'OK';
 294         $detail = '';
 295     }
 296
 297     write;
 298 }
 299
 300 $server->DeleteFile($iorbase);
 301 $server->DeleteFile($database);
 302
 303 exit $status;
 304
 305 # @p = &do_test(0, undef, undef);
 306 # &check_profiles("0 unspec unspec", \@p, \@HOSTNAMES);
 307
 308 # @p = &do_test(1, undef, undef);
 309 # &check_profiles("1 unspec unspec", \@p, \@IPADDRS);
 310
 311 # @p = &do_test(0, hostname, undef);
 312 # &check_profiles("0 ".hostname." undef", \@p, [hostname]);
 313
 314 # @p = &do_test(1, hostname, undef);
 315 # &check_profiles("1 ".hostname." undef", \@p, [ inet_ntoa((gethostbyname(hostname))[4]) ] );
 316
 317 # @p = &do_test(undef, undef, hostname . "_blech");
 318 # &check_profiles("undef undef ".hostname."_blech", \@p, [hostname."_blech"]);
 319
 320 # @p = &do_test(undef, hostname, hostname."_blech");
 321 # &check_profiles("undef ".hostname." ".hostname."_blech", \@p, [hostname."_blech"]);