js/tests/jsDriver.pl

   1 #!/usr/bin/perl
   2 # -*- Mode: Perl; tab-width: 4; indent-tabs-mode: nil; -*-
   3 # vim: set ts=4 sw=4 et tw=80:
   4 # ***** BEGIN LICENSE BLOCK *****
   5 # Version: MPL 1.1/GPL 2.0/LGPL 2.1
   6 #
   7 # The contents of this file are subject to the Mozilla Public License Version
   8 # 1.1 (the "License"); you may not use this file except in compliance with
   9 # the License. You may obtain a copy of the License at
  10 # http://www.mozilla.org/MPL/
  11 #
  12 # Software distributed under the License is distributed on an "AS IS" basis,
  13 # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  14 # for the specific language governing rights and limitations under the
  15 # License.
  16 #
  17 # The Original Code is JavaScript Core Tests.
  18 #
  19 # The Initial Developer of the Original Code is
  20 # Netscape Communications Corporation.
  21 # Portions created by the Initial Developer are Copyright (C) 1997-1999
  22 # the Initial Developer. All Rights Reserved.
  23 #
  24 # Contributor(s):
  25 #   Robert Ginda <rginda@netscape.com>
  26 #
  27 # Alternatively, the contents of this file may be used under the terms of
  28 # either the GNU General Public License Version 2 or later (the "GPL"), or
  29 # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  30 # in which case the provisions of the GPL or the LGPL are applicable instead
  31 # of those above. If you wish to allow use of your version of this file only
  32 # under the terms of either the GPL or the LGPL, and not to allow others to
  33 # use your version of this file under the terms of the MPL, indicate your
  34 # decision by deleting the provisions above and replace them with the notice
  35 # and other provisions required by the GPL or the LGPL. If you do not delete
  36 # the provisions above, a recipient may use your version of this file under
  37 # the terms of any one of the MPL, the GPL or the LGPL.
  38 #
  39 # ***** END LICENSE BLOCK *****
  40
  41 # Second cut at runtests.pl script originally by
  42 # Christine Begle (cbegle@netscape.com)
  43 # Branched 11/01/99
  44
  45 use strict;
  46 use File::Temp qw/ tempfile tempdir /;
  47 use POSIX qw(sys_wait_h);
  48
  49 my $os_type = &get_os_type;
  50 my $unixish = (($os_type ne "WIN") && ($os_type ne "MAC"));
  51 my $path_sep = ($os_type eq "MAC") ? ":" : "/";
  52 my $win_sep  = ($os_type eq "WIN")? &get_win_sep : "";
  53 my $redirect_command = ($os_type ne "MAC") ? " 2>&1" : "";
  54
  55 # command line option defaults
  56 my $opt_suite_path;
  57 my $opt_trace = 0;
  58 my $opt_classpath = "";
  59 my $opt_rhino_opt = 0;
  60 my $opt_rhino_ms = 0;
  61 my @opt_engine_list;
  62 my $opt_engine_type = "";
  63 my $opt_engine_params = "";
  64 my $opt_user_output_file = 0;
  65 my $opt_output_file = "";
  66 my @opt_test_list_files;
  67 my @opt_neg_list_files;
  68 my $opt_shell_path = "";
  69 my $opt_java_path = "";
  70 my $opt_bug_url = "https://bugzilla.mozilla.org/show_bug.cgi?id=";
  71 my $opt_console_failures = 0;
  72 my $opt_console_failures_line = 0;
  73 my $opt_lxr_url = "http://lxr.mozilla.org/mozilla/source/js/tests/";
  74 my $opt_exit_munge = ($os_type ne "MAC") ? 1 : 0;
  75 my $opt_timeout = 3600;
  76 my $opt_enable_narcissus = 0;
  77 my $opt_narcissus_path = "";
  78 my $opt_no_quit = 0;
  79 my $opt_report_summarized_results = 0;
  80
  81 # command line option definition
  82 my $options = "b=s bugurl>b c=s classpath>c e=s engine>e f=s file>f " .
  83   "h help>h i j=s javapath>j k confail>k K linefail>K R report>R l=s list>l " .
  84   "L=s neglist>L o=s opt>o p=s testpath>p s=s shellpath>s t trace>t " .
  85   "T=s timeout>T u=s lxrurl>u " .
  86   "x noexitmunge>x n=s narcissus>n " .
  87   "Q noquitinthandler>Q";
  88
  89 my $last_option;
  90
  91 if ($os_type eq "MAC") {
  92     $opt_suite_path = `directory`;
  93     $opt_suite_path =~ s/[\n\r]//g;
  94     $opt_suite_path .= ":";
  95 } else {
  96     $opt_suite_path = "./";
  97 }
  98
  99 &parse_args;
 100
 101 my $user_exit = 0;
 102 my ($engine_command, $html, $failures_reported, $tests_completed,
 103     $exec_time_string);
 104 my @failed_tests;
 105 my @test_list = &get_test_list;
 106
 107 if ($#test_list == -1) {
 108     die ("Nothing to test.\n");
 109 }
 110
 111 if ($unixish && $opt_no_quit == 0) {
 112     # on unix, ^C pauses the tests, and gives the user a chance to quit but
 113     # report on what has been done, to just quit, or to continue (the
 114     # interrupted test will still be skipped.)
 115     # windows doesn't handle the int handler they way we want it to,
 116     # so don't even pretend to let the user continue.
 117     $SIG{INT} = 'int_handler';
 118 }
 119
 120 my $current_test;
 121 my $current_test_pid;
 122
 123 &main;
 124
 125 #End.
 126
 127 sub main {
 128     my $start_time;
 129
 130     while ($opt_engine_type = pop (@opt_engine_list)) {
 131         dd ("Testing engine '$opt_engine_type'");
 132
 133         $engine_command = &get_engine_command;
 134         $html = "";
 135         @failed_tests = ();
 136         $failures_reported = 0;
 137         $tests_completed = 0;
 138         $start_time = time;
 139
 140
 141         &execute_tests (@test_list);
 142
 143         my $exec_time = (time - $start_time);
 144         my $exec_hours = int($exec_time / 60 / 60);
 145         $exec_time -= $exec_hours * 60 * 60;
 146         my $exec_mins = int($exec_time / 60);
 147         $exec_time -= $exec_mins * 60;
 148         my $exec_secs = ($exec_time % 60);
 149
 150         if ($exec_hours > 0) {
 151             $exec_time_string = "$exec_hours hours, $exec_mins minutes, " .
 152               "$exec_secs seconds";
 153         } elsif ($exec_mins > 0) {
 154             $exec_time_string = "$exec_mins minutes, $exec_secs seconds";
 155         } else {
 156             $exec_time_string = "$exec_secs seconds";
 157         }
 158
 159         if (!$opt_user_output_file) {
 160             $opt_output_file = &get_tempfile_name;
 161         }
 162
 163         &write_results;
 164
 165     }
 166 }
 167
 168 sub append_file_to_command {
 169     my ($command, $file) = @_;
 170
 171     if ($opt_enable_narcissus == 1) {
 172         $command .= " -e 'evaluate(\"load(\\\"$file\\\")\")'"
 173     } else {
 174         $command .= " -f $file";
 175     }
 176 }
 177
 178 sub execute_tests {
 179     my (@test_list) = @_;
 180     my ($test, $shell_command, $line, @output, $path);
 181     my ($last_suite, $last_test_dir);
 182
 183     &status ("Executing " . ($#test_list + 1) . " test(s).");
 184
 185     foreach $test (@test_list) {
 186         my ($suite, $test_dir, $test_file) = split($path_sep, $test);
 187         # *-n.js is a negative test, expect exit code 3 (runtime error)
 188         my $expected_exit = ($test =~ /\-n\.js$/) ? 3 : 0;
 189         my ($got_exit, $exit_signal);
 190         my $failure_lines;
 191         my $bug_number;
 192         my $status_lines;
 193         my $result_lines;
 194
 195         # Allow the test to declare multiple possible success exit codes.
 196         # This is useful in situations where the test fails if a
 197         # crash occurs but passes if no crash occurs even if an
 198         # out of memory error occurs.
 199         my @expected_exit_list = ($expected_exit);
 200
 201         # user selected [Q]uit from ^C handler.
 202         if ($user_exit) {
 203             return;
 204         }
 205
 206         $current_test = $test;
 207
 208         # Append the shell.js files to the shell_command if they're there.
 209         # (only check for their existance if the suite or test_dir has changed
 210         # since the last time we looked.)
 211         if ($last_suite ne $suite || $last_test_dir ne $test_dir) {
 212             $shell_command = &xp_path($engine_command);
 213
 214             $path = &xp_path($opt_suite_path ."shell.js");
 215             if (-f $path) {
 216                 $shell_command = &append_file_to_command($shell_command,
 217                                                          $path);
 218             }
 219
 220             $path = &xp_path($opt_suite_path . $suite . "/shell.js");
 221             if (-f $path) {
 222                 $shell_command = &append_file_to_command($shell_command,
 223                                                          $path);
 224             }
 225
 226             $path = &xp_path($opt_suite_path . $suite . "/" .
 227                              $test_dir . "/shell.js");
 228             if (-f $path) {
 229                 $shell_command = &append_file_to_command($shell_command,
 230                                                          $path);
 231             }
 232
 233             $last_suite = $suite;
 234             $last_test_dir = $test_dir;
 235         }
 236
 237         $path = &xp_path($opt_suite_path . $test);
 238         my $command = &append_file_to_command($shell_command, $path);
 239
 240         $path = &xp_path($opt_suite_path ."js-test-driver-end.js");
 241         if (-f $path) {
 242             $command = &append_file_to_command($command,
 243                                                $path);
 244         }
 245
 246         &dd ("executing: " . $command);
 247
 248         my $jsout;
 249         (undef, $jsout) = tempfile();
 250
 251         #XXX cloned from tinderbox. See sub kill_process
 252         my $pid = fork; # Fork a child process to run the test
 253         unless ($pid) {
 254             open STDOUT, ">$jsout";
 255             open STDERR, ">&STDOUT";
 256             select STDOUT; $| = 1; # make STDOUT unbuffered
 257             select STDERR; $| = 1; # make STDERR unbuffered
 258             exec $command;
 259             die "Could not exec $command";
 260         }
 261
 262         $current_test_pid = $pid;
 263
 264         my $timed_out = 0;
 265         my $dumped_core = 0;
 266         my $loop_count = 0;
 267         my $wait_pid = -1;
 268
 269         eval
 270         {
 271             local $SIG{ALRM} = sub { die "time out" };
 272             alarm $opt_timeout;
 273             $wait_pid = waitpid($pid, 0);
 274             alarm 0;
 275         };
 276
 277         if ($@ and $@ =~ /time out/)
 278         {
 279             kill_process($pid);
 280             $timed_out = 1;
 281         }
 282
 283         $current_test_pid = undef;
 284
 285         if ($opt_exit_munge == 1) {
 286             # signal information in the lower 8 bits, exit code above that
 287             $got_exit = ($? >> 8);
 288             $exit_signal = ($? & 255);
 289         } else {
 290             # user says not to munge the exit code
 291             $got_exit = $?;
 292             $exit_signal = 0;
 293         }
 294
 295         open (OUTPUT, "$jsout") or
 296            die "failed to open temporary file $jsout: $!\n";
 297         @output = <OUTPUT>;
 298         close (OUTPUT);
 299         unlink "$jsout";
 300         @output = grep (!/js\>/, @output);
 301
 302         $failure_lines = "";
 303         $bug_number = "";
 304         $status_lines = "";
 305         $result_lines = "";
 306
 307         foreach $line (@output) {
 308
 309             # watch for testcase to proclaim what exit code it expects to
 310             # produce (0 by default)
 311             if ($line =~ /expect(ed)?\s*exit\s*code\s*\:?\s*(\d+)/i) {
 312                 $expected_exit = $2;
 313                 push @expected_exit_list, ($expected_exit);
 314                 &dd ("Test case expects exit code $expected_exit");
 315             }
 316
 317             # watch for failures
 318             if ($line =~ /^\s*FAILED!/) {
 319                 $failure_lines .= $line;
 320             }
 321
 322             # and watch for bugnumbers
 323             # XXX This only allows 1 bugnumber per testfile, should be
 324             # XXX modified to allow for multiple.
 325             if ($line =~ /bugnumber\s*\:?\s*(.*)/i) {
 326                 my $bugline = $1;
 327                 $bugline =~ /(\d+)/;
 328                 $bug_number = $1;
 329             }
 330
 331             # and watch for status
 332             if ($line =~ /status/i) {
 333                 $status_lines .= $line;
 334             }
 335
 336             # collect result summary lines
 337             if ($line =~ /^jstest:/)
 338             {
 339                 $result_lines .= $line;
 340             }
 341         }
 342
 343         if (!@output) {
 344             @output = ("Testcase produced no output!");
 345         }
 346
 347         if ($opt_report_summarized_results) {
 348             print STDERR $result_lines;
 349             if ($timed_out)
 350             {
 351                 &report_summary_result($test, $bug_number, "FAILED TIMED OUT",
 352                                        "", "", "",
 353                                        join("\n",@output));
 354             }
 355             elsif (index(join(',', @expected_exit_list), $got_exit) == -1 ||
 356                    $exit_signal != 0) {
 357                 &report_summary_result($test, $bug_number, "FAILED",
 358                                        "",
 359                                        "Expected exit $expected_exit",
 360                                        "Actual exit $got_exit, signal $exit_signal",
 361                                        join("\n",@output));
 362             }
 363             elsif ($got_exit != 0) {
 364                 # abnormal termination but the test passed, so output a summary line
 365                 &report_summary_result($test, $bug_number, "PASSED",
 366                                        "",
 367                                        "Expected exit $expected_exit",
 368                                        "Actual exit $got_exit, signal $exit_signal",
 369                                        join("\n",@output));
 370             }
 371         }
 372         elsif ($timed_out) {
 373             # test was terminated due to timeout
 374             &report_failure ($test, "TIMED OUT ($opt_timeout seconds) " .
 375                              "Complete testcase output was:\n" .
 376                              join ("\n",@output), $bug_number);
 377         }
 378         elsif (index(join(',', @expected_exit_list), $got_exit) == -1 ||
 379                $exit_signal != 0) {
 380             # full testcase output dumped on mismatched exit codes,
 381             &report_failure ($test, "Expected exit code " .
 382                              "$expected_exit, got $got_exit\n" .
 383                              "Testcase terminated with signal $exit_signal\n" .
 384                              "Complete testcase output was:\n" .
 385                              join ("\n",@output), $bug_number);
 386         } elsif ($failure_lines) {
 387             # only offending lines if exit codes matched
 388             &report_failure ($test, "$status_lines\n".
 389                              "Failure messages were:\n$failure_lines",
 390                              $bug_number);
 391         }
 392
 393         &dd ("exit code $got_exit, exit signal $exit_signal.");
 394
 395         $tests_completed++;
 396     }
 397 }
 398
 399 sub write_results {
 400     my ($list_name, $neglist_name);
 401     my $completion_date = localtime;
 402     my $failure_pct = int(($failures_reported / $tests_completed) * 10000) /
 403       100;
 404     &dd ("Writing output to $opt_output_file.");
 405
 406     if ($#opt_test_list_files == -1) {
 407         $list_name = "All tests";
 408     } elsif ($#opt_test_list_files < 10) {
 409         $list_name = join (", ", @opt_test_list_files);
 410     } else {
 411         $list_name = "($#opt_test_list_files test files specified)";
 412     }
 413
 414     if ($#opt_neg_list_files == -1) {
 415         $neglist_name = "(none)";
 416     } elsif ($#opt_test_list_files < 10) {
 417         $neglist_name = join (", ", @opt_neg_list_files);
 418     } else {
 419         $neglist_name = "($#opt_neg_list_files skip files specified)";
 420     }
 421
 422     open (OUTPUT, "> $opt_output_file") ||
 423       die ("Could not create output file $opt_output_file");
 424
 425     print OUTPUT
 426       ("<html><head>\n" .
 427        "<title>Test results, $opt_engine_type</title>\n" .
 428        "</head>\n" .
 429        "<body bgcolor='white'>\n" .
 430        "<a name='tippy_top'></a>\n" .
 431        "<h2>Test results, $opt_engine_type</h2><br>\n" .
 432        "<p class='results_summary'>\n" .
 433        "Test List: $list_name<br>\n" .
 434        "Skip List: $neglist_name<br>\n" .
 435        ($#test_list + 1) . " test(s) selected, $tests_completed test(s) " .
 436        "completed, $failures_reported failures reported " .
 437        "($failure_pct% failed)<br>\n" .
 438        "Engine command line: $engine_command<br>\n" .
 439        "OS type: $os_type<br>\n");
 440
 441     if ($opt_engine_type =~ /^rhino/) {
 442         open (JAVAOUTPUT, $opt_java_path . "java -fullversion " .
 443               $redirect_command . " |");
 444         print OUTPUT <JAVAOUTPUT>;
 445         print OUTPUT "<BR>";
 446         close (JAVAOUTPUT);
 447     }
 448
 449     print OUTPUT
 450       ("Testcase execution time: $exec_time_string.<br>\n" .
 451        "Tests completed on $completion_date.<br><br>\n");
 452
 453     if ($failures_reported > 0) {
 454         my $output_file_failures = $opt_output_file;
 455         $output_file_failures =~ s/(.*)\.html$/$1-failures.txt/;
 456         open (OUTPUTFAILURES, "> $output_file_failures") ||
 457             die ("Could not create failure output file $output_file_failures");
 458         print OUTPUTFAILURES (join ("\n", @failed_tests));
 459         print OUTPUTFAILURES "\n";
 460         close OUTPUTFAILURES;
 461
 462         &status ("Wrote failures to '$output_file_failures'.");
 463
 464         print OUTPUT
 465           ("[ <a href='#fail_detail'>Failure Details</a> | " .
 466            "<a href='#retest_list'>Retest List</a> | " .
 467            "<a href='$opt_lxr_url" . "menu.html'>Test Selection Page</a> ]<br>\n" .
 468            "<hr>\n" .
 469            "<a name='fail_detail'></a>\n" .
 470            "<h2>Failure Details</h2><br>\n<dl>" .
 471            $html .
 472            "</dl>\n[ <a href='#tippy_top'>Top of Page</a> | " .
 473            "<a href='#fail_detail'>Top of Failures</a> ]<br>\n" .
 474            "<hr>\n" .
 475            "<a name='retest_list'></a>\n" .
 476            "<h2>Retest List</h2><br>\n" .
 477            "<pre>\n" .
 478            "# Retest List, $opt_engine_type, " .
 479            "generated $completion_date.\n" .
 480            "FAILURE: # Original test base was: $list_name.\n" .
 481            "FAILURE: # $tests_completed of " . ($#test_list + 1) .
 482            " test(s) were completed, " .
 483            "$failures_reported failures reported.\n" .
 484            "FAILURE: Engine command line: $engine_command<br>\n" .
 485            join ("\n", map { "FAILURE: $_" } @failed_tests) .
 486            "\n</pre>\n" .
 487            "[ <a href='#tippy_top'>Top of Page</a> | " .
 488            "<a href='#retest_list'>Top of Retest List</a> ]<br>\n");
 489     } else {
 490         print OUTPUT
 491           ("<h1>Whoop-de-doo, nothing failed!</h1>\n");
 492     }
 493
 494     print OUTPUT "</body>";
 495
 496     close (OUTPUT);
 497
 498     &status ("Wrote results to '$opt_output_file'.");
 499
 500     if ($opt_console_failures) {
 501         &status ("$failures_reported test(s) failed");
 502     }
 503
 504 }
 505
 506 sub next_option {
 507     my ($key, $val, $implied);
 508
 509     return if @ARGV == 0;
 510
 511     &dd ("ARGV is now: @ARGV\n");
 512
 513     $key = shift @ARGV;
 514     if ($key =~ s/^--?(.*)/$1/) {
 515         $implied = 0;
 516     } else {
 517         $implied = 1;
 518         $val = $key;
 519         $key = $last_option;
 520     }
 521
 522     if ($key =~ /\w+/ and $options =~ /\b$key>(\w+)/) {
 523         $key = $1;
 524     }
 525
 526     if ($options =~ /\b$key=s\b/) {
 527         if (!$implied) {
 528             die "option '$key' requires an argument" if @ARGV == 0;
 529             $val = shift @ARGV;
 530         }
 531     } elsif ($options =~ /(^|\s)$key(\s|$)/) {
 532         die "option '$key' doesn't take an argument" if $implied;
 533         $val = 1;
 534     } else {
 535         die "can't figure out option '$key'";
 536     }
 537     $last_option = $key;
 538     return ($key, $val);
 539 }
 540
 541 sub parse_args {
 542     my ($option, $value, $lastopt);
 543
 544     &dd ("checking command line options.");
 545
 546     while (($option, $value) = next_option()) {
 547
 548         if ($option eq "b") {
 549             &dd ("opt: setting bugurl to '$value'.");
 550             $opt_bug_url = $value;
 551
 552         } elsif ($option eq "c") {
 553             &dd ("opt: setting classpath to '$value'.");
 554             $opt_classpath = $value;
 555
 556         } elsif (($option eq "e") || (($option eq "") && ($lastopt eq "e"))) {
 557             &dd ("opt: adding engine $value.");
 558             push (@opt_engine_list, $value);
 559
 560         } elsif ($option eq "f") {
 561             if (!$value) {
 562                 die ("Output file cannot be null.\n");
 563             }
 564             &dd ("opt: setting output file to '$value'.");
 565             $opt_user_output_file = 1;
 566             $opt_output_file = $value;
 567
 568         } elsif ($option eq "h") {
 569             &usage;
 570
 571         } elsif ($option eq "j") {
 572             if (!($value =~ /[\/\\]$/)) {
 573                 $value .= "/";
 574             }
 575             &dd ("opt: setting java path to '$value'.");
 576             $opt_java_path = $value;
 577
 578         } elsif ($option eq "k") {
 579             &dd ("opt: displaying failures on console.");
 580             $opt_console_failures=1;
 581
 582         } elsif ($option eq "K") {
 583             &dd ("opt: displaying failures on console as single line.");
 584             $opt_console_failures=1;
 585             $opt_console_failures_line=1;
 586
 587         } elsif ($option eq "R") {
 588             &dd ("opt: Report summarized test results.");
 589             $opt_report_summarized_results=1;
 590
 591         } elsif ($option eq "l" || (($option eq "") && ($lastopt eq "l"))) {
 592             $option = "l";
 593             &dd ("opt: adding test list '$value'.");
 594             push (@opt_test_list_files, $value);
 595
 596         } elsif ($option eq "L" || (($option eq "") && ($lastopt eq "L"))) {
 597             $option = "L";
 598             &dd ("opt: adding negative list '$value'.");
 599             push (@opt_neg_list_files, $value);
 600
 601         } elsif ($option eq "o") {
 602             $opt_engine_params = $value;
 603             &dd ("opt: setting engine params to '$opt_engine_params'.");
 604
 605         } elsif ($option eq "p") {
 606             $opt_suite_path = $value;
 607
 608             if ($os_type eq "MAC") {
 609                 if (!($opt_suite_path =~ /\:$/)) {
 610                     $opt_suite_path .= ":";
 611                 }
 612             } else {
 613                 if (!($opt_suite_path =~ /[\/\\]$/)) {
 614                     $opt_suite_path .= "/";
 615                 }
 616             }
 617
 618             &dd ("opt: setting suite path to '$opt_suite_path'.");
 619
 620         } elsif ($option eq "s") {
 621             $opt_shell_path = $value;
 622             &dd ("opt: setting shell path to '$opt_shell_path'.");
 623
 624         } elsif ($option eq "t") {
 625             &dd ("opt: tracing output.  (console failures at no extra charge.)");
 626             $opt_console_failures = 1;
 627             $opt_trace = 1;
 628
 629         } elsif ($option eq "u") {
 630             &dd ("opt: setting lxr url to '$value'.");
 631             $opt_lxr_url = $value;
 632
 633         } elsif ($option eq "x") {
 634             &dd ("opt: turning off exit munging.");
 635             $opt_exit_munge = 0;
 636
 637         } elsif ($option eq "T") {
 638             $opt_timeout = $value;
 639             &dd ("opt: setting timeout to $opt_timeout.");
 640
 641         } elsif ($option eq "n") {
 642             &dd ("opt: enabling narcissus.");
 643             $opt_enable_narcissus = 1;
 644             if ($value) {
 645                 $opt_narcissus_path = $value;
 646             }
 647
 648         } elsif ($option eq "Q") {
 649             &dd ("opt: disabling interrupt handler.");
 650             $opt_no_quit = 1;
 651
 652         } else {
 653             &dd ("opt: unknown option $option '$value'.");
 654             &usage;
 655         }
 656
 657         $lastopt = $option;
 658
 659     }
 660
 661     if ($#opt_engine_list == -1) {
 662         die "You must select a shell to test in.\n";
 663     }
 664
 665 }
 666
 667 #
 668 # print the arguments that this script expects
 669 #
 670 sub usage {
 671     print STDERR
 672       ("\nusage: $0 [<options>] \n" .
 673        "(-b|--bugurl)             Bugzilla URL.\n" .
 674        "                          (default is $opt_bug_url)\n" .
 675        "(-c|--classpath)          Classpath (Rhino only.)\n" .
 676        "(-e|--engine) <type> ...  Specify the type of engine(s) to test.\n" .
 677        "                          <type> is one or more of\n" .
 678        "                          (smopt|smdebug|lcopt|lcdebug|xpcshell|" .
 679        "rhino|rhinoi|rhinoms|rhinomsi|rhino9|rhinoms9).\n" .
 680        "(-f|--file) <file>        Redirect output to file named <file>.\n" .
 681        "                          (default is " .
 682        "results-<engine-type>-<date-stamp>.html)\n" .
 683        "(-h|--help)               Print this message.\n" .
 684        "(-j|--javapath)           Location of java executable.\n" .
 685        "(-k|--confail)            Log failures to console (also.)\n" .
 686        "(-K|--linefail)           Log failures to console as single line (also.)\n" .
 687        "(-R|--report)             Report summarized test results.\n" .
 688        "(-l|--list) <file> ...    List of tests to execute.\n" .
 689        "(-L|--neglist) <file> ... List of tests to skip.\n" .
 690        "(-o|--opt) <options>      Options to pass to the JavaScript engine.\n" .
 691        "                          (Make sure to quote them!)\n" .
 692        "(-p|--testpath) <path>    Root of the test suite. (default is ./)\n" .
 693        "(-s|--shellpath) <path>   Location of JavaScript shell.\n" .
 694        "(-t|--trace)              Trace script execution.\n" .
 695        "(-T|--timeout) <seconds>  Time in seconds before the test is terminated.\n" .
 696        "                          (default is 3600).\n" .
 697        "(-u|--lxrurl) <url>       Complete URL to tests subdirectory on lxr.\n" .
 698        "                          (default is $opt_lxr_url)\n" .
 699        "(-x|--noexitmunge)        Don't do exit code munging (try this if it\n" .
 700        "                          seems like your exit codes are turning up\n" .
 701        "                          as exit signals.)\n" .
 702        "(-n|--narcissus)[=<path>] Run the test suite through Narcissus, run\n" .
 703        "                          through the given shell. The optional path\n".
 704        "                          is the path to Narcissus' js.js file.\n".
 705        "(-Q|--noquitinthandler)   Do not prompt user to Quit, Report or Continue\n".
 706        "                          in the event of a user interrupt.\n"
 707        );
 708     exit (1);
 709
 710 }
 711
 712 #
 713 # get the shell command used to start the (either) engine
 714 #
 715 sub get_engine_command {
 716
 717     my $retval;
 718
 719     if ($opt_engine_type eq "rhino") {
 720         &dd ("getting rhino engine command.");
 721         $opt_rhino_opt = 0;
 722         $opt_rhino_ms = 0;
 723         $retval = &get_rhino_engine_command;
 724     } elsif ($opt_engine_type eq "rhinoi") {
 725         &dd ("getting rhinoi engine command.");
 726         $opt_rhino_opt = -1;
 727         $opt_rhino_ms = 0;
 728         $retval = &get_rhino_engine_command;
 729     } elsif ($opt_engine_type eq "rhino9") {
 730         &dd ("getting rhino engine command.");
 731         $opt_rhino_opt = 9;
 732         $opt_rhino_ms = 0;
 733         $retval = &get_rhino_engine_command;
 734     } elsif ($opt_engine_type eq "rhinoms") {
 735         &dd ("getting rhinoms engine command.");
 736         $opt_rhino_opt = 0;
 737         $opt_rhino_ms = 1;
 738         $retval = &get_rhino_engine_command;
 739     } elsif ($opt_engine_type eq "rhinomsi") {
 740         &dd ("getting rhinomsi engine command.");
 741         $opt_rhino_opt = -1;
 742         $opt_rhino_ms = 1;
 743         $retval = &get_rhino_engine_command;
 744     } elsif ($opt_engine_type eq "rhinoms9") {
 745         &dd ("getting rhinomsi engine command.");
 746         $opt_rhino_opt = 9;
 747         $opt_rhino_ms = 1;
 748         $retval = &get_rhino_engine_command;
 749     } elsif ($opt_engine_type eq "xpcshell") {
 750         &dd ("getting xpcshell engine command.");
 751         $retval = &get_xpc_engine_command;
 752     } elsif ($opt_engine_type =~ /^lc(opt|debug)$/) {
 753         &dd ("getting liveconnect engine command.");
 754         $retval = &get_lc_engine_command;
 755     } elsif ($opt_engine_type =~ /^sm(opt|debug)$/) {
 756         &dd ("getting spidermonkey engine command.");
 757         $retval = &get_sm_engine_command;
 758     } elsif ($opt_engine_type =~ /^ep(opt|debug)$/) {
 759         &dd ("getting epimetheus engine command.");
 760         $retval = &get_ep_engine_command;
 761     } else {
 762         die ("Unknown engine type selected, '$opt_engine_type'.\n");
 763     }
 764
 765     $retval .= " $opt_engine_params";
 766
 767     if ($opt_enable_narcissus == 1) {
 768         my $narcissus_path = &get_narcissus_path;
 769         $retval .= " -f $narcissus_path";
 770     }
 771
 772     &dd ("got '$retval'");
 773
 774     return $retval;
 775 }
 776
 777 #
 778 # get the path to the Narcissus js.js file.
 779 #
 780 sub get_narcissus_path {
 781     my $retval;
 782
 783     if ($opt_narcissus_path) {
 784         $retval = $opt_narcissus_path;
 785     } else {
 786         # For now, just assume that we're in js/tests.
 787         $retval = "../narcissus/js.js";
 788     }
 789
 790     if (!-e $retval) {
 791         # XXX if it didn't exist, try something more fancy?
 792         die "Unable to find Narcissus' js.js at $retval";
 793     }
 794
 795     return $retval;
 796 }
 797
 798 #
 799 # get the shell command used to run rhino
 800 #
 801 sub get_rhino_engine_command {
 802     my $retval = $opt_java_path . ($opt_rhino_ms ? "jview " : "java ");
 803
 804     if ($opt_shell_path) {
 805         $opt_classpath = ($opt_classpath) ?
 806           $opt_classpath . ":" . $opt_shell_path :
 807             $opt_shell_path;
 808     }
 809
 810     if ($opt_classpath) {
 811         $retval .= ($opt_rhino_ms ? "/cp:p" : "-classpath") . " $opt_classpath ";
 812     }
 813
 814     $retval .= "org.mozilla.javascript.tools.shell.Main";
 815
 816     if ($opt_rhino_opt) {
 817         $retval .= " -opt $opt_rhino_opt";
 818     }
 819
 820     return $retval;
 821
 822 }
 823
 824 #
 825 # get the shell command used to run xpcshell
 826 #
 827 sub get_xpc_engine_command {
 828     my $retval;
 829     my $m5_home = @ENV{"MOZILLA_FIVE_HOME"} ||
 830       die ("You must set MOZILLA_FIVE_HOME to use the xpcshell" ,
 831            (!$unixish) ? "." : ", also " .
 832            "setting LD_LIBRARY_PATH to the same directory may get rid of " .
 833            "any 'library not found' errors.\n");
 834
 835     if (($unixish) && (!@ENV{"LD_LIBRARY_PATH"})) {
 836         print STDERR "-#- WARNING: LD_LIBRARY_PATH is not set, xpcshell may " .
 837           "not be able to find the required components.\n";
 838     }
 839
 840     if (!($m5_home =~ /[\/\\]$/)) {
 841         $m5_home .= "/";
 842     }
 843
 844     $retval = $m5_home . "xpcshell";
 845
 846     if ($os_type eq "WIN") {
 847         $retval .= ".exe";
 848     }
 849
 850     $retval = &xp_path($retval);
 851
 852     if (($os_type ne "MAC") && !(-x $retval)) {
 853         # mac doesn't seem to deal with -x correctly
 854         die ($retval . " is not a valid executable on this system.\n");
 855     }
 856
 857     return $retval;
 858
 859 }
 860
 861 #
 862 # get the shell command used to run spidermonkey
 863 #
 864 sub get_sm_engine_command {
 865     my $retval;
 866
 867     # Look for Makefile.ref style make first.
 868     # (On Windows, spidermonkey can be made by two makefiles, each putting the
 869     # executable in a diferent directory, under a different name.)
 870
 871     if ($opt_shell_path) {
 872         # if the user provided a path to the shell, return that.
 873         $retval = $opt_shell_path;
 874
 875     } else {
 876
 877         if ($os_type eq "MAC") {
 878             $retval = $opt_suite_path . ":src:macbuild:JS";
 879         } else {
 880             $retval = $opt_suite_path . "../src/";
 881             opendir (SRC_DIR_FILES, $retval);
 882             my @src_dir_files = readdir(SRC_DIR_FILES);
 883             closedir (SRC_DIR_FILES);
 884
 885             my ($dir, $object_dir);
 886             my $pattern = ($opt_engine_type eq "smdebug") ?
 887               'DBG.OBJ' : 'OPT.OBJ';
 888
 889             # scan for the first directory matching
 890             # the pattern expected to hold this type (debug or opt) of engine
 891             foreach $dir (@src_dir_files) {
 892                 if ($dir =~ $pattern) {
 893                     $object_dir = $dir;
 894                     last;
 895                 }
 896             }
 897
 898             if (!$object_dir && $os_type ne "WIN") {
 899                 die ("Could not locate an object directory in $retval " .
 900                      "matching the pattern *$pattern.  Have you built the " .
 901                      "engine?\n");
 902             }
 903
 904             if (!(-x $retval . $object_dir . "/js.exe") && ($os_type eq "WIN")) {
 905                 # On windows, you can build with js.mak as well as Makefile.ref
 906                 # (Can you say WTF boys and girls?  I knew you could.)
 907                 # So, if the exe the would have been built by Makefile.ref isn't
 908                 # here, check for the js.mak version before dying.
 909                 if ($opt_shell_path) {
 910                     $retval = $opt_shell_path;
 911                     if (!($retval =~ /[\/\\]$/)) {
 912                         $retval .= "/";
 913                     }
 914                 } else {
 915                     if ($opt_engine_type eq "smopt") {
 916                         $retval = "../src/Release/";
 917                     } else {
 918                         $retval = "../src/Debug/";
 919                     }
 920                 }
 921
 922                 $retval .= "jsshell.exe";
 923
 924             } else {
 925                 $retval .= $object_dir . "/js";
 926                 if ($os_type eq "WIN") {
 927                     $retval .= ".exe";
 928                 }
 929             }
 930         } # mac/ not mac
 931
 932         $retval = &xp_path($retval);
 933
 934     } # (user provided a path)
 935
 936
 937     if (($os_type ne "MAC") && !(-x $retval)) {
 938         # mac doesn't seem to deal with -x correctly
 939         die ($retval . " is not a valid executable on this system.\n");
 940     }
 941
 942     return $retval;
 943
 944 }
 945
 946 #
 947 # get the shell command used to run epimetheus
 948 #
 949 sub get_ep_engine_command {
 950     my $retval;
 951
 952     if ($opt_shell_path) {
 953         # if the user provided a path to the shell, return that -
 954         $retval = $opt_shell_path;
 955
 956     } else {
 957         my $dir;
 958         my $os;
 959         my $debug;
 960         my $opt;
 961         my $exe;
 962
 963         $dir = $opt_suite_path . "../../js2/src/";
 964
 965         if ($os_type eq "MAC") {
 966             #
 967             # On the Mac, the debug and opt builds lie in the same directory -
 968             #
 969             $os = "macbuild:";
 970             $debug = "";
 971             $opt = "";
 972             $exe = "JS2";
 973         } elsif ($os_type eq "WIN") {
 974             $os = "winbuild/Epimetheus/";
 975             $debug = "Debug/";
 976             $opt = "Release/";
 977             $exe = "Epimetheus.exe";
 978         } else {
 979             $os = "";
 980             $debug = "";
 981             $opt = "";    # <<<----- XXX THIS IS NOT RIGHT! CHANGE IT!
 982             $exe = "epimetheus";
 983         }
 984
 985
 986         if ($opt_engine_type eq "epdebug") {
 987             $retval = $dir . $os . $debug . $exe;
 988         } else {
 989             $retval = $dir . $os . $opt . $exe;
 990         }
 991
 992         $retval = &xp_path($retval);
 993
 994     }# (user provided a path)
 995
 996
 997     if (($os_type ne "MAC") && !(-x $retval)) {
 998         # mac doesn't seem to deal with -x correctly
 999         die ($retval . " is not a valid executable on this system.\n");
1000     }
1001
1002     return $retval;
1003 }
1004
1005 #
1006 # get the shell command used to run the liveconnect shell
1007 #
1008 sub get_lc_engine_command {
1009     my $retval;
1010
1011     if ($opt_shell_path) {
1012         $retval = $opt_shell_path;
1013     } else {
1014         if ($os_type eq "MAC") {
1015             die "Don't know how to run the lc shell on the mac yet.\n";
1016         } else {
1017             $retval = $opt_suite_path . "../src/liveconnect/";
1018             opendir (SRC_DIR_FILES, $retval);
1019             my @src_dir_files = readdir(SRC_DIR_FILES);
1020             closedir (SRC_DIR_FILES);
1021
1022             my ($dir, $object_dir);
1023             my $pattern = ($opt_engine_type eq "lcdebug") ?
1024               'DBG.OBJ' : 'OPT.OBJ';
1025
1026             foreach $dir (@src_dir_files) {
1027                 if ($dir =~ $pattern) {
1028                     $object_dir = $dir;
1029                     last;
1030                 }
1031             }
1032
1033             if (!$object_dir) {
1034                 die ("Could not locate an object directory in $retval " .
1035                      "matching the pattern *$pattern.  Have you built the " .
1036                      "engine?\n");
1037             }
1038
1039             $retval .= $object_dir . "/";
1040
1041             if ($os_type eq "WIN") {
1042                 $retval .= "lcshell.exe";
1043             } else {
1044                 $retval .= "lcshell";
1045             }
1046         } # mac/ not mac
1047
1048         $retval = &xp_path($retval);
1049
1050     } # (user provided a path)
1051
1052
1053     if (($os_type ne "MAC") && !(-x $retval)) {
1054         # mac doesn't seem to deal with -x correctly
1055         die ("$retval is not a valid executable on this system.\n");
1056     }
1057
1058     return $retval;
1059
1060 }
1061
1062 sub get_os_type {
1063
1064     if ("\n" eq "\015") {
1065         return "MAC";
1066     }
1067
1068     my $uname = `uname -a`;
1069
1070     if ($uname =~ /WIN/) {
1071         $uname = "WIN";
1072     } else {
1073         chop $uname;
1074     }
1075
1076     &dd ("get_os_type returning '$uname'.");
1077     return $uname;
1078
1079 }
1080
1081 sub get_test_list {
1082     my @test_list;
1083     my @neg_list;
1084
1085     if ($#opt_test_list_files > -1) {
1086         my $list_file;
1087
1088         &dd ("getting test list from user specified source.");
1089
1090         foreach $list_file (@opt_test_list_files) {
1091             push (@test_list, &expand_user_test_list($list_file));
1092         }
1093     } else {
1094         &dd ("no list file, groveling in '$opt_suite_path'.");
1095
1096         @test_list = &get_default_test_list($opt_suite_path);
1097     }
1098
1099     if ($#opt_neg_list_files > -1) {
1100         my $list_file;
1101         my $orig_size = $#test_list + 1;
1102         my $actually_skipped;
1103
1104         &dd ("getting negative list from user specified source.");
1105
1106         foreach $list_file (@opt_neg_list_files) {
1107             push (@neg_list, &expand_user_test_list($list_file));
1108         }
1109
1110         @test_list = &subtract_arrays (\@test_list, \@neg_list);
1111
1112         $actually_skipped = $orig_size - ($#test_list + 1);
1113
1114         &dd ($actually_skipped . " of " . $orig_size .
1115              " tests will be skipped.");
1116         &dd ((($#neg_list + 1) - $actually_skipped) . " skip tests were " .
1117              "not actually part of the test list.");
1118
1119     }
1120
1121
1122     # Don't run any shell.js files as tests; they are only utility files
1123     @test_list = grep (!/shell\.js$/, @test_list);
1124
1125     # Don't run any browser.js files as tests; they are only utility files
1126     @test_list = grep (!/browser\.js$/, @test_list);
1127
1128     # Don't run any jsref.js files as tests; they are only utility files
1129     @test_list = grep (!/jsref\.js$/, @test_list);
1130
1131     return @test_list;
1132
1133 }
1134
1135 #
1136 # reads $list_file, storing non-comment lines into an array.
1137 # lines in the form suite_dir/[*] or suite_dir/test_dir/[*] are expanded
1138 # to include all test files under the specified directory
1139 #
1140 sub expand_user_test_list {
1141     my ($list_file) = @_;
1142     my @retval = ();
1143
1144     #
1145     # Trim off the leading path separator that begins relative paths on the Mac.
1146     # Each path will get concatenated with $opt_suite_path, which ends in one.
1147     #
1148     # Also note:
1149     #
1150     # We will call expand_test_list_entry(), which does pattern-matching on $list_file.
1151     # This will make the pattern-matching the same as it would be on Linux/Windows -
1152     #
1153     if ($os_type eq "MAC") {
1154         $list_file =~ s/^$path_sep//;
1155     }
1156
1157     if ($list_file =~ /\.js$/ || -d $opt_suite_path . $list_file) {
1158
1159         push (@retval, &expand_test_list_entry($list_file));
1160
1161     } else {
1162
1163         open (TESTLIST, $list_file) ||
1164           die("Error opening test list file '$list_file': $!\n");
1165
1166         while (<TESTLIST>) {
1167             s/\r*\n*$//;
1168             if (!(/\s*\#/)) {
1169                 # It's not a comment, so process it
1170                 push (@retval, &expand_test_list_entry($_));
1171             }
1172         }
1173
1174         close (TESTLIST);
1175
1176     }
1177
1178     return @retval;
1179
1180 }
1181
1182
1183 #
1184 # Currently expect all paths to be RELATIVE to the top-level tests directory.
1185 # One day, this should be improved to allow absolute paths as well -
1186 #
1187 sub expand_test_list_entry {
1188     my ($entry) = @_;
1189     my @retval;
1190
1191     if ($entry =~ /\.js$/) {
1192         # it's a regular entry, add it to the list
1193         if (-f $opt_suite_path . $entry) {
1194             push (@retval, $entry);
1195         } else {
1196             status ("testcase '$entry' not found.");
1197         }
1198     } elsif ($entry =~ /(.*$path_sep[^\*][^$path_sep]*)$path_sep?\*?$/) {
1199         # Entry is in the form suite_dir/test_dir[/*]
1200         # so iterate all tests under it
1201         my $suite_and_test_dir = $1;
1202         my @test_files = &get_js_files ($opt_suite_path .
1203                                         $suite_and_test_dir);
1204         my $i;
1205
1206         foreach $i (0 .. $#test_files) {
1207             $test_files[$i] = $suite_and_test_dir . $path_sep .
1208               $test_files[$i];
1209         }
1210
1211         splice (@retval, $#retval + 1, 0, @test_files);
1212
1213     } elsif ($entry =~ /([^\*][^$path_sep]*)$path_sep?\*?$/) {
1214         # Entry is in the form suite_dir[/*]
1215         # so iterate all test dirs and tests under it
1216         my $suite = $1;
1217         my @test_dirs = &get_subdirs ($opt_suite_path . $suite);
1218         my $test_dir;
1219
1220         foreach $test_dir (@test_dirs) {
1221             my @test_files = &get_js_files ($opt_suite_path . $suite .
1222                                             $path_sep . $test_dir);
1223             my $i;
1224
1225             foreach $i (0 .. $#test_files) {
1226                 $test_files[$i] = $suite . $path_sep . $test_dir . $path_sep .
1227                   $test_files[$i];
1228             }
1229
1230             splice (@retval, $#retval + 1, 0, @test_files);
1231         }
1232
1233     } else {
1234         die ("Don't know what to do with list entry '$entry'.\n");
1235     }
1236
1237     return @retval;
1238
1239 }
1240
1241 #
1242 # Grovels through $suite_path, searching for *all* test files.  Used when the
1243 # user doesn't supply a test list.
1244 #
1245 sub get_default_test_list {
1246     my ($suite_path) = @_;
1247     my @suite_list = &get_subdirs($suite_path);
1248     my $suite;
1249     my @retval;
1250
1251     foreach $suite (@suite_list) {
1252         my @test_dir_list = get_subdirs ($suite_path . $suite);
1253         my $test_dir;
1254
1255         foreach $test_dir (@test_dir_list) {
1256             my @test_list = get_js_files ($suite_path . $suite . $path_sep .
1257                                           $test_dir);
1258             my $test;
1259
1260             foreach $test (@test_list) {
1261                 $retval[$#retval + 1] = $suite . $path_sep . $test_dir .
1262                   $path_sep . $test;
1263             }
1264         }
1265     }
1266
1267     return @retval;
1268
1269 }
1270
1271 #
1272 # generate an output file name based on the date
1273 #
1274 sub get_tempfile_name {
1275     my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
1276       &get_padded_time (localtime);
1277     my $rv;
1278
1279     if ($os_type ne "MAC") {
1280         $rv = "results-" . $year . "-" . $mon . "-" . $mday . "-" . $hour .
1281           $min . $sec . "-" . $opt_engine_type;
1282     } else {
1283         $rv = "res-" . $year . $mon . $mday . $hour . $min . $sec . "-" .
1284           $opt_engine_type
1285     }
1286
1287     return $rv . ".html";
1288 }
1289
1290 sub get_padded_time {
1291     my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = @_;
1292
1293     $mon++;
1294     $mon = &zero_pad($mon);
1295     $year += 1900;
1296     $mday= &zero_pad($mday);
1297     $sec = &zero_pad($sec);
1298     $min = &zero_pad($min);
1299     $hour = &zero_pad($hour);
1300
1301     return ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
1302
1303 }
1304
1305 sub zero_pad {
1306     my ($string) = @_;
1307
1308     $string = ($string < 10) ? "0" . $string : $string;
1309     return $string;
1310 }
1311
1312 sub subtract_arrays {
1313     my ($whole_ref, $part_ref) = @_;
1314     my @whole = @$whole_ref;
1315     my @part = @$part_ref;
1316     my $line;
1317
1318     foreach $line (@part) {
1319         @whole = grep (!/$line/, @whole);
1320     }
1321
1322     return @whole;
1323
1324 }
1325
1326 #
1327 # Convert unix path to mac style.
1328 #
1329 sub unix_to_mac {
1330     my ($path) = @_;
1331     my @path_elements = split ("/", $path);
1332     my $rv = "";
1333     my $i;
1334
1335     foreach $i (0 .. $#path_elements) {
1336         if ($path_elements[$i] eq ".") {
1337             if (!($rv =~ /\:$/)) {
1338                 $rv .= ":";
1339             }
1340         } elsif ($path_elements[$i] eq "..") {
1341             if (!($rv =~ /\:$/)) {
1342                 $rv .= "::";
1343             } else {
1344                 $rv .= ":";
1345             }
1346         } elsif ($path_elements[$i] ne "") {
1347             $rv .= $path_elements[$i] . ":";
1348         }
1349
1350     }
1351
1352     $rv =~ s/\:$//;
1353
1354     return $rv;
1355 }
1356
1357 #
1358 # Convert unix path to win style.
1359 #
1360 sub unix_to_win {
1361   my ($path) = @_;
1362
1363   if ($path_sep ne $win_sep) {
1364       $path =~ s/$path_sep/$win_sep/g;
1365   }
1366
1367   return $path;
1368 }
1369
1370 #
1371 # Windows shells require "/" or "\" as path separator.
1372 # Find out the one used in the current Windows shell.
1373 #
1374 sub get_win_sep {
1375   my $path = $ENV{"PATH"} || $ENV{"Path"} || $ENV{"path"};
1376   $path =~ /\\|\//;
1377   return $&;
1378 }
1379
1380 #
1381 # Convert unix path to correct style based on platform.
1382 #
1383 sub xp_path {
1384     my ($path) = @_;
1385
1386     if ($os_type eq "MAC") {
1387         return &unix_to_mac($path);
1388     } elsif($os_type eq "WIN") {
1389         return &unix_to_win($path);
1390     } else {
1391         return $path;
1392     }
1393 }
1394
1395 #
1396 # given a directory, return an array of all subdirectories
1397 #
1398 sub get_subdirs {
1399     my ($dir)  = @_;
1400     my @subdirs;
1401
1402     if ($os_type ne "MAC") {
1403         if (!($dir =~ /\/$/)) {
1404             $dir = $dir . "/";
1405         }
1406     } else {
1407         if (!($dir =~ /\:$/)) {
1408             $dir = $dir . ":";
1409         }
1410     }
1411     opendir (DIR, $dir) || die ("couldn't open directory $dir: $!");
1412     my @testdir_contents = readdir(DIR);
1413     closedir(DIR);
1414
1415     foreach (@testdir_contents) {
1416         if ((-d ($dir . $_)) && ($_ ne 'CVS') && ($_ ne '.') && ($_ ne '..')) {
1417             @subdirs[$#subdirs + 1] = $_;
1418         }
1419     }
1420
1421     return @subdirs;
1422 }
1423
1424 #
1425 # given a directory, return an array of all the js files that are in it.
1426 #
1427 sub get_js_files {
1428     my ($test_subdir) = @_;
1429     my (@js_file_array, @subdir_files);
1430
1431     opendir (TEST_SUBDIR, $test_subdir) || die ("couldn't open directory " .
1432                                                 "$test_subdir: $!");
1433     @subdir_files = readdir(TEST_SUBDIR);
1434     closedir( TEST_SUBDIR );
1435
1436     foreach (@subdir_files) {
1437         if ($_ =~ /\.js$/) {
1438             $js_file_array[$#js_file_array+1] = $_;
1439         }
1440     }
1441
1442     return @js_file_array;
1443 }
1444
1445 sub report_failure {
1446     my ($test, $message, $bug_number) = @_;
1447     my $bug_line = "";
1448
1449     $failures_reported++;
1450
1451     $message =~ s/\n+/\n/g;
1452     $test =~ s/\:/\//g;
1453
1454     if ($opt_console_failures) {
1455         if ($opt_console_failures_line) {
1456             # report_summary_result increments $failures_reported
1457             # decrement here to prevent overcounting of failures
1458             $failures_reported--;
1459             my $linemessage = $message;
1460             $linemessage =~ s/[\n\r]+/ /mg;
1461             $bug_number = "none" unless $bug_number;
1462             &report_summary_result($test, $bug_number, "FAILED",
1463                                    "",
1464                                    "",
1465                                    "",
1466                                    $linemessage);
1467         } elsif($bug_number) {
1468             print STDERR ("*-* Testcase $test failed:\nBug Number $bug_number".
1469                           "\n$message\n");
1470         } else {
1471             print STDERR ("*-* Testcase $test failed:\n$message\n");
1472         }
1473     }
1474
1475     $message =~ s/&/&amp;/g;
1476     $message =~ s/</&lt;/g;
1477     $message =~ s/>/&gt;/g;
1478     $message =~ s/\n/<br>\n/g;
1479
1480     if ($bug_number) {
1481         my $bug_url = ($bug_number =~ /^\d+$/) ? "$opt_bug_url$bug_number" : $bug_number;
1482         $bug_line = "<a href='$bug_url' target='other_window'>".
1483                     "Bug Number $bug_number</a>";
1484     }
1485
1486     if ($opt_lxr_url) {
1487         $test =~ /\/?([^\/]+\/[^\/]+\/[^\/]+)$/;
1488         $test = $1;
1489         $html .= "<dd><b>".
1490           "Testcase <a target='other_window' href='$opt_lxr_url$test'>$1</a> " .
1491             "failed</b> $bug_line<br>\n";
1492     } else {
1493         $html .= "<dd><b>".
1494           "Testcase $test failed</b> $bug_line<br>\n";
1495     }
1496
1497     $html .= " [ ";
1498
1499     $html .= "<a href='#tippy_top'>Top of Page</a> ]<br>\n" .
1500           "<tt>$message</tt><br>\n";
1501
1502     @failed_tests[$#failed_tests + 1] = $test;
1503
1504 }
1505
1506 sub dd {
1507
1508     if ($opt_trace) {
1509         print ("-*- ", @_ , "\n");
1510     }
1511
1512 }
1513
1514 sub status {
1515
1516     print ("-#- ", @_ , "\n");
1517
1518 }
1519
1520 sub int_handler {
1521     my $resp;
1522
1523     if ($current_test_pid)
1524     {
1525         print "User Interrupt: killing process $current_test_pid\n";
1526         kill_process($current_test_pid);
1527     }
1528
1529     do {
1530         print STDERR ("\n*** User Break: Just [Q]uit, Quit and [R]eport, [C]ontinue ?");
1531         $resp = <STDIN>;
1532     } until ($resp =~ /[QqRrCc]/);
1533
1534     if ($resp =~ /[Qq]/) {
1535         print ("User Exit.  No results were generated.\n");
1536         exit;
1537     } elsif ($resp =~ /[Rr]/) {
1538         $user_exit = 1;
1539     }
1540
1541 }
1542
1543 # XXX: These functions were pulled from
1544 # lxr.mozilla.org/mozilla/source/tools/tinderbox/build-seamonkey-util.pl
1545 # need a general reusable library of routines for use in all test programs.
1546
1547 sub kill_process {
1548     my ($target_pid) = @_;
1549     my $start_time = time;
1550
1551     # Try to kill and wait 10 seconds, then try a kill -9
1552     my $sig;
1553     for $sig ('TERM', 'KILL') {
1554         print "kill $sig $target_pid\n";
1555         kill $sig => $target_pid;
1556         my $interval_start = time;
1557         while (time - $interval_start < 10) {
1558             # the following will work with 'cygwin' perl on win32, but not
1559             # with 'MSWin32' (ActiveState) perl
1560             my $pid = waitpid($target_pid, POSIX::WNOHANG());
1561             if (($pid == $target_pid and POSIX::WIFEXITED($?)) or $pid == -1) {
1562                 my $secs = time - $start_time;
1563                 $secs = $secs == 1 ? '1 second' : "$secs seconds";
1564                 return;
1565             }
1566             sleep 1;
1567         }
1568     }
1569     die "Unable to kill process: $target_pid";
1570 }
1571
1572 sub report_summary_result
1573 {
1574     my ($test, $bug_number, $result, $description,
1575         $expected, $actual, $reason) = @_;
1576
1577     $description =~ s/[\n\r]+/ /mg;
1578     $expected    =~ s/[\n\r]+/ /mg;
1579     $actual      =~ s/[\n\r]+/ /mg;
1580     $reason      =~ s/[\n\r]+/ /mg;
1581
1582     if ($result !~ /PASSED/)
1583     {
1584         $failures_reported++;
1585     }
1586
1587     print STDERR ("jstest: $test " .
1588                   "bug: $bug_number " .
1589                   "result: $result " .
1590                   "type: shell " .
1591                   "description: $description " .
1592                   "expected: $expected " .
1593                   "actual: $actual " .
1594                   "reason: $reason" .
1595                   "\n");
1596
1597 }