#!/usr/bin/perl # -*- Mode: Perl; tab-width: 4; indent-tabs-mode: nil; -*- # vim: set ts=4 sw=4 et tw=80: # ***** BEGIN LICENSE BLOCK ***** # Version: MPL 1.1/GPL 2.0/LGPL 2.1 # # The contents of this file are subject to the Mozilla Public License Version # 1.1 (the "License"); you may not use this file except in compliance with # the License. You may obtain a copy of the License at # http://www.mozilla.org/MPL/ # # Software distributed under the License is distributed on an "AS IS" basis, # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License # for the specific language governing rights and limitations under the # License. # # The Original Code is JavaScript Core Tests. # # The Initial Developer of the Original Code is # Netscape Communications Corporation. # Portions created by the Initial Developer are Copyright (C) 1997-1999 # the Initial Developer. All Rights Reserved. # # Contributor(s): # Robert Ginda # # Alternatively, the contents of this file may be used under the terms of # either the GNU General Public License Version 2 or later (the "GPL"), or # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), # in which case the provisions of the GPL or the LGPL are applicable instead # of those above. If you wish to allow use of your version of this file only # under the terms of either the GPL or the LGPL, and not to allow others to # use your version of this file under the terms of the MPL, indicate your # decision by deleting the provisions above and replace them with the notice # and other provisions required by the GPL or the LGPL. If you do not delete # the provisions above, a recipient may use your version of this file under # the terms of any one of the MPL, the GPL or the LGPL. # # ***** END LICENSE BLOCK ***** # Second cut at runtests.pl script originally by # Christine Begle (cbegle@netscape.com) # Branched 11/01/99 use strict; use Getopt::Mixed "nextOption"; use File::Temp qw/ tempfile tempdir /; use POSIX qw(sys_wait_h); my $os_type = &get_os_type; my $unixish = (($os_type ne "WIN") && ($os_type ne "MAC")); my $path_sep = ($os_type eq "MAC") ? ":" : "/"; my $win_sep = ($os_type eq "WIN")? &get_win_sep : ""; my $redirect_command = ($os_type ne "MAC") ? " 2>&1" : ""; # command line option defaults my $opt_suite_path; my $opt_trace = 0; my $opt_classpath = ""; my $opt_rhino_opt = 0; my $opt_rhino_ms = 0; my @opt_engine_list; my $opt_engine_type = ""; my $opt_engine_params = ""; my $opt_user_output_file = 0; my $opt_output_file = ""; my @opt_test_list_files; my @opt_neg_list_files; my $opt_shell_path = ""; my $opt_java_path = ""; my $opt_bug_url = "https://bugzilla.mozilla.org/show_bug.cgi?id="; my $opt_console_failures = 0; my $opt_console_failures_line = 0; my $opt_lxr_url = "http://lxr.mozilla.org/mozilla/source/js/tests/"; my $opt_exit_munge = ($os_type ne "MAC") ? 1 : 0; my $opt_timeout = 3600; my $opt_enable_narcissus = 0; my $opt_narcissus_path = ""; my $opt_no_quit = 0; # command line option definition my $options = "b=s bugurl>b c=s classpath>c e=s engine>e f=s file>f " . "h help>h i j=s javapath>j k confail>k K linefail>K l=s list>l " . "L=s neglist>L o=s opt>o p=s testpath>p s=s shellpath>s t trace>t " . "T=s timeout>T u=s lxrurl>u " . "x noexitmunge>x n:s narcissus>n " . "Q noquitinthandler>Q"; if ($os_type eq "MAC") { $opt_suite_path = `directory`; $opt_suite_path =~ s/[\n\r]//g; $opt_suite_path .= ":"; } else { $opt_suite_path = "./"; } &parse_args; my $user_exit = 0; my ($engine_command, $html, $failures_reported, $tests_completed, $exec_time_string); my @failed_tests; my @test_list = &get_test_list; if ($#test_list == -1) { die ("Nothing to test.\n"); } if ($unixish && $opt_no_quit == 0) { # on unix, ^C pauses the tests, and gives the user a chance to quit but # report on what has been done, to just quit, or to continue (the # interrupted test will still be skipped.) # windows doesn't handle the int handler they way we want it to, # so don't even pretend to let the user continue. $SIG{INT} = 'int_handler'; } my $current_test; my $current_test_pid; &main; #End. sub main { my $start_time; while ($opt_engine_type = pop (@opt_engine_list)) { dd ("Testing engine '$opt_engine_type'"); $engine_command = &get_engine_command; $html = ""; @failed_tests = (); $failures_reported = 0; $tests_completed = 0; $start_time = time; &execute_tests (@test_list); my $exec_time = (time - $start_time); my $exec_hours = int($exec_time / 60 / 60); $exec_time -= $exec_hours * 60 * 60; my $exec_mins = int($exec_time / 60); $exec_time -= $exec_mins * 60; my $exec_secs = ($exec_time % 60); if ($exec_hours > 0) { $exec_time_string = "$exec_hours hours, $exec_mins minutes, " . "$exec_secs seconds"; } elsif ($exec_mins > 0) { $exec_time_string = "$exec_mins minutes, $exec_secs seconds"; } else { $exec_time_string = "$exec_secs seconds"; } if (!$opt_user_output_file) { $opt_output_file = &get_tempfile_name; } &write_results; } } sub append_file_to_command { my ($command, $file) = @_; if ($opt_enable_narcissus == 1) { $command .= " -e 'evaluate(\"load(\\\"$file\\\")\")'" } else { $command .= " -f $file"; } } sub execute_tests { my (@test_list) = @_; my ($test, $shell_command, $line, @output, $path); my ($last_suite, $last_test_dir); &status ("Executing " . ($#test_list + 1) . " test(s)."); foreach $test (@test_list) { my ($suite, $test_dir, $test_file) = split($path_sep, $test); # *-n.js is a negative test, expect exit code 3 (runtime error) my $expected_exit = ($test =~ /\-n\.js$/) ? 3 : 0; my ($got_exit, $exit_signal); my $failure_lines; my $bug_number; my $status_lines; # Allow the test to declare multiple possible success exit codes. # This is useful in situations where the test fails if a # crash occurs but passes if no crash occurs even if an # out of memory error occurs. my @expected_exit_list = ($expected_exit); # user selected [Q]uit from ^C handler. if ($user_exit) { return; } $current_test = $test; # Append the shell.js files to the shell_command if they're there. # (only check for their existance if the suite or test_dir has changed # since the last time we looked.) if ($last_suite ne $suite || $last_test_dir ne $test_dir) { $shell_command = &xp_path($engine_command); $path = &xp_path($opt_suite_path . $suite . "/shell.js"); if (-f $path) { $shell_command = &append_file_to_command($shell_command, $path); } $path = &xp_path($opt_suite_path . $suite . "/" . $test_dir . "/shell.js"); if (-f $path) { $shell_command = &append_file_to_command($shell_command, $path); } $last_suite = $suite; $last_test_dir = $test_dir; } $path = &xp_path($opt_suite_path . $test); my $command = &append_file_to_command($shell_command, $path); &dd ("executing: " . $command); my $jsout; (undef, $jsout) = tempfile(); #XXX cloned from tinderbox. See sub kill_process my $pid = fork; # Fork a child process to run the test unless ($pid) { open STDOUT, ">$jsout"; open STDERR, ">&STDOUT"; select STDOUT; $| = 1; # make STDOUT unbuffered select STDERR; $| = 1; # make STDERR unbuffered exec $command; die "Could not exec $command"; } $current_test_pid = $pid; my $timed_out = 0; my $dumped_core = 0; my $loop_count = 0; my $wait_pid = -1; eval { local $SIG{ALRM} = sub { die "time out" }; alarm $opt_timeout; $wait_pid = waitpid($pid, 0); alarm 0; }; if ($@ and $@ =~ /time out/) { kill_process($pid); $timed_out = 1; } $current_test_pid = undef; if ($opt_exit_munge == 1) { # signal information in the lower 8 bits, exit code above that $got_exit = ($? >> 8); $exit_signal = ($? & 255); } else { # user says not to munge the exit code $got_exit = $?; $exit_signal = 0; } open (OUTPUT, "$jsout") or die "failed to open temporary file $jsout: $!\n"; @output = ; close (OUTPUT); unlink "$jsout"; @output = grep (!/js\>/, @output); $failure_lines = ""; $bug_number = ""; $status_lines = ""; foreach $line (@output) { # watch for testcase to proclaim what exit code it expects to # produce (0 by default) if ($line =~ /expect(ed)?\s*exit\s*code\s*\:?\s*(\d+)/i) { $expected_exit = $2; push @expected_exit_list, ($expected_exit); &dd ("Test case expects exit code $expected_exit"); } # watch for failures if ($line =~ /failed!/i) { $failure_lines .= $line; } # and watch for bugnumbers # XXX This only allows 1 bugnumber per testfile, should be # XXX modified to allow for multiple. if ($line =~ /bugnumber\s*\:?\s*(.*)/i) { my $bugline = $1; $bugline =~ /(\d+)/; $bug_number = $1; } # and watch for status if ($line =~ /status/i) { $status_lines .= $line; } } if (!@output) { @output = ("Testcase produced no output!"); } if ($timed_out) { # test was terminated due to timeout &report_failure ($test, "TIMED OUT ($opt_timeout seconds)\n"); } elsif (index(join(',', @expected_exit_list), $got_exit) == -1 || $exit_signal != 0) { # full testcase output dumped on mismatched exit codes, &report_failure ($test, "Expected exit code " . "$expected_exit, got $got_exit\n" . "Testcase terminated with signal $exit_signal\n" . "Complete testcase output was:\n" . join ("\n",@output), $bug_number); } elsif ($failure_lines) { # only offending lines if exit codes matched &report_failure ($test, "$status_lines\n". "Failure messages were:\n$failure_lines", $bug_number); } &dd ("exit code $got_exit, exit signal $exit_signal."); $tests_completed++; } } sub write_results { my ($list_name, $neglist_name); my $completion_date = localtime; my $failure_pct = int(($failures_reported / $tests_completed) * 10000) / 100; &dd ("Writing output to $opt_output_file."); if ($#opt_test_list_files == -1) { $list_name = "All tests"; } elsif ($#opt_test_list_files < 10) { $list_name = join (", ", @opt_test_list_files); } else { $list_name = "($#opt_test_list_files test files specified)"; } if ($#opt_neg_list_files == -1) { $neglist_name = "(none)"; } elsif ($#opt_test_list_files < 10) { $neglist_name = join (", ", @opt_neg_list_files); } else { $neglist_name = "($#opt_neg_list_files skip files specified)"; } open (OUTPUT, "> $opt_output_file") || die ("Could not create output file $opt_output_file"); print OUTPUT ("\n" . "Test results, $opt_engine_type\n" . "\n" . "\n" . "\n" . "

Test results, $opt_engine_type


\n" . "

\n" . "Test List: $list_name
\n" . "Skip List: $neglist_name
\n" . ($#test_list + 1) . " test(s) selected, $tests_completed test(s) " . "completed, $failures_reported failures reported " . "($failure_pct% failed)
\n" . "Engine command line: $engine_command
\n" . "OS type: $os_type
\n"); if ($opt_engine_type =~ /^rhino/) { open (JAVAOUTPUT, $opt_java_path . "java -fullversion " . $redirect_command . " |"); print OUTPUT ; print OUTPUT "
"; close (JAVAOUTPUT); } print OUTPUT ("Testcase execution time: $exec_time_string.
\n" . "Tests completed on $completion_date.

\n"); if ($failures_reported > 0) { my $output_file_failures = $opt_output_file; $output_file_failures =~ s/(.*)\.html$/$1-failures.txt/; open (OUTPUTFAILURES, "> $output_file_failures") || die ("Could not create failure output file $output_file_failures"); print OUTPUTFAILURES (join ("\n", @failed_tests)); print OUTPUTFAILURES "\n"; close OUTPUTFAILURES; &status ("Wrote failures to '$output_file_failures'."); print OUTPUT ("[ Failure Details | " . "Retest List | " . "Test Selection Page ]
\n" . "


\n" . "\n" . "

Failure Details


\n
" . $html . "
\n[ Top of Page | " . "Top of Failures ]
\n" . "
\n" . "\n" . "

Retest List


\n" . "
\n" .
           "# Retest List, $opt_engine_type, " .
           "generated $completion_date.\n" .
           "FAILURE: # Original test base was: $list_name.\n" .
           "FAILURE: # $tests_completed of " . ($#test_list + 1) .
           " test(s) were completed, " .
           "$failures_reported failures reported.\n" .
           "FAILURE: Engine command line: $engine_command
\n" . join ("\n", map { "FAILURE: $_" } @failed_tests) . "\n
\n" . "[ Top of Page | " . "Top of Retest List ]
\n"); } else { print OUTPUT ("

Whoop-de-doo, nothing failed!

\n"); } print OUTPUT ""; close (OUTPUT); &status ("Wrote results to '$opt_output_file'."); if ($opt_console_failures) { &status ("$failures_reported test(s) failed"); } } sub parse_args { my ($option, $value, $lastopt); &dd ("checking command line options."); Getopt::Mixed::init ($options); $Getopt::Mixed::order = $Getopt::Mixed::RETURN_IN_ORDER; while (($option, $value) = nextOption()) { if ($option eq "b") { &dd ("opt: setting bugurl to '$value'."); $opt_bug_url = $value; } elsif ($option eq "c") { &dd ("opt: setting classpath to '$value'."); $opt_classpath = $value; } elsif (($option eq "e") || (($option eq "") && ($lastopt eq "e"))) { &dd ("opt: adding engine $value."); push (@opt_engine_list, $value); } elsif ($option eq "f") { if (!$value) { die ("Output file cannot be null.\n"); } &dd ("opt: setting output file to '$value'."); $opt_user_output_file = 1; $opt_output_file = $value; } elsif ($option eq "h") { &usage; } elsif ($option eq "j") { if (!($value =~ /[\/\\]$/)) { $value .= "/"; } &dd ("opt: setting java path to '$value'."); $opt_java_path = $value; } elsif ($option eq "k") { &dd ("opt: displaying failures on console."); $opt_console_failures=1; } elsif ($option eq "K") { &dd ("opt: displaying failures on console as single line."); $opt_console_failures=1; $opt_console_failures_line=1; } elsif ($option eq "l" || (($option eq "") && ($lastopt eq "l"))) { $option = "l"; &dd ("opt: adding test list '$value'."); push (@opt_test_list_files, $value); } elsif ($option eq "L" || (($option eq "") && ($lastopt eq "L"))) { $option = "L"; &dd ("opt: adding negative list '$value'."); push (@opt_neg_list_files, $value); } elsif ($option eq "o") { $opt_engine_params = $value; &dd ("opt: setting engine params to '$opt_engine_params'."); } elsif ($option eq "p") { $opt_suite_path = $value; if ($os_type eq "MAC") { if (!($opt_suite_path =~ /\:$/)) { $opt_suite_path .= ":"; } } else { if (!($opt_suite_path =~ /[\/\\]$/)) { $opt_suite_path .= "/"; } } &dd ("opt: setting suite path to '$opt_suite_path'."); } elsif ($option eq "s") { $opt_shell_path = $value; &dd ("opt: setting shell path to '$opt_shell_path'."); } elsif ($option eq "t") { &dd ("opt: tracing output. (console failures at no extra charge.)"); $opt_console_failures = 1; $opt_trace = 1; } elsif ($option eq "u") { &dd ("opt: setting lxr url to '$value'."); $opt_lxr_url = $value; } elsif ($option eq "x") { &dd ("opt: turning off exit munging."); $opt_exit_munge = 0; } elsif ($option eq "T") { $opt_timeout = $value; &dd ("opt: setting timeout to $opt_timeout."); } elsif ($option eq "n") { &dd ("opt: enabling narcissus."); $opt_enable_narcissus = 1; if ($value) { $opt_narcissus_path = $value; } } elsif ($option eq "Q") { &dd ("opt: disabling interrupt handler."); $opt_no_quit = 1; } else { &dd ("opt: unknown option $option '$value'."); &usage; } $lastopt = $option; } Getopt::Mixed::cleanup(); if ($#opt_engine_list == -1) { die "You must select a shell to test in.\n"; } } # # print the arguments that this script expects # sub usage { print STDERR ("\nusage: $0 [] \n" . "(-b|--bugurl) Bugzilla URL.\n" . " (default is $opt_bug_url)\n" . "(-c|--classpath) Classpath (Rhino only.)\n" . "(-e|--engine) ... Specify the type of engine(s) to test.\n" . " is one or more of\n" . " (smopt|smdebug|lcopt|lcdebug|xpcshell|" . "rhino|rhinoi|rhinoms|rhinomsi|rhino9|rhinoms9).\n" . "(-f|--file) Redirect output to file named .\n" . " (default is " . "results--.html)\n" . "(-h|--help) Print this message.\n" . "(-j|--javapath) Location of java executable.\n" . "(-k|--confail) Log failures to console (also.)\n" . "(-K|--linefail) Log failures to console as single line (also.)\n" . "(-l|--list) ... List of tests to execute.\n" . "(-L|--neglist) ... List of tests to skip.\n" . "(-o|--opt) Options to pass to the JavaScript engine.\n" . " (Make sure to quote them!)\n" . "(-p|--testpath) Root of the test suite. (default is ./)\n" . "(-s|--shellpath) Location of JavaScript shell.\n" . "(-t|--trace) Trace script execution.\n" . "(-T|--timeout) Time in seconds before the test is terminated.\n" . " (default is 3600).\n" . "(-u|--lxrurl) Complete URL to tests subdirectory on lxr.\n" . " (default is $opt_lxr_url)\n" . "(-x|--noexitmunge) Don't do exit code munging (try this if it\n" . " seems like your exit codes are turning up\n" . " as exit signals.)\n" . "(-n|--narcissus)[=] Run the test suite through Narcissus, run\n" . " through the given shell. The optional path\n". " is the path to Narcissus' js.js file.\n". "(-Q|--noquitinthandler) Do not prompt user to Quit, Report or Continue\n". " in the event of a user interrupt.\n" ); exit (1); } # # get the shell command used to start the (either) engine # sub get_engine_command { my $retval; if ($opt_engine_type eq "rhino") { &dd ("getting rhino engine command."); $opt_rhino_opt = 0; $opt_rhino_ms = 0; $retval = &get_rhino_engine_command; } elsif ($opt_engine_type eq "rhinoi") { &dd ("getting rhinoi engine command."); $opt_rhino_opt = -1; $opt_rhino_ms = 0; $retval = &get_rhino_engine_command; } elsif ($opt_engine_type eq "rhino9") { &dd ("getting rhino engine command."); $opt_rhino_opt = 9; $opt_rhino_ms = 0; $retval = &get_rhino_engine_command; } elsif ($opt_engine_type eq "rhinoms") { &dd ("getting rhinoms engine command."); $opt_rhino_opt = 0; $opt_rhino_ms = 1; $retval = &get_rhino_engine_command; } elsif ($opt_engine_type eq "rhinomsi") { &dd ("getting rhinomsi engine command."); $opt_rhino_opt = -1; $opt_rhino_ms = 1; $retval = &get_rhino_engine_command; } elsif ($opt_engine_type eq "rhinoms9") { &dd ("getting rhinomsi engine command."); $opt_rhino_opt = 9; $opt_rhino_ms = 1; $retval = &get_rhino_engine_command; } elsif ($opt_engine_type eq "xpcshell") { &dd ("getting xpcshell engine command."); $retval = &get_xpc_engine_command; } elsif ($opt_engine_type =~ /^lc(opt|debug)$/) { &dd ("getting liveconnect engine command."); $retval = &get_lc_engine_command; } elsif ($opt_engine_type =~ /^sm(opt|debug)$/) { &dd ("getting spidermonkey engine command."); $retval = &get_sm_engine_command; } elsif ($opt_engine_type =~ /^ep(opt|debug)$/) { &dd ("getting epimetheus engine command."); $retval = &get_ep_engine_command; } else { die ("Unknown engine type selected, '$opt_engine_type'.\n"); } $retval .= " $opt_engine_params"; if ($opt_enable_narcissus == 1) { my $narcissus_path = &get_narcissus_path; $retval .= " -f $narcissus_path"; } &dd ("got '$retval'"); return $retval; } # # get the path to the Narcissus js.js file. # sub get_narcissus_path { my $retval; if ($opt_narcissus_path) { $retval = $opt_narcissus_path; } else { # For now, just assume that we're in js/tests. $retval = "../narcissus/js.js"; } if (!-e $retval) { # XXX if it didn't exist, try something more fancy? die "Unable to find Narcissus' js.js at $retval"; } return $retval; } # # get the shell command used to run rhino # sub get_rhino_engine_command { my $retval = $opt_java_path . ($opt_rhino_ms ? "jview " : "java "); if ($opt_shell_path) { $opt_classpath = ($opt_classpath) ? $opt_classpath . ":" . $opt_shell_path : $opt_shell_path; } if ($opt_classpath) { $retval .= ($opt_rhino_ms ? "/cp:p" : "-classpath") . " $opt_classpath "; } $retval .= "org.mozilla.javascript.tools.shell.Main"; if ($opt_rhino_opt) { $retval .= " -opt $opt_rhino_opt"; } return $retval; } # # get the shell command used to run xpcshell # sub get_xpc_engine_command { my $retval; my $m5_home = @ENV{"MOZILLA_FIVE_HOME"} || die ("You must set MOZILLA_FIVE_HOME to use the xpcshell" , (!$unixish) ? "." : ", also " . "setting LD_LIBRARY_PATH to the same directory may get rid of " . "any 'library not found' errors.\n"); if (($unixish) && (!@ENV{"LD_LIBRARY_PATH"})) { print STDERR "-#- WARNING: LD_LIBRARY_PATH is not set, xpcshell may " . "not be able to find the required components.\n"; } if (!($m5_home =~ /[\/\\]$/)) { $m5_home .= "/"; } $retval = $m5_home . "xpcshell"; if ($os_type eq "WIN") { $retval .= ".exe"; } $retval = &xp_path($retval); if (($os_type ne "MAC") && !(-x $retval)) { # mac doesn't seem to deal with -x correctly die ($retval . " is not a valid executable on this system.\n"); } return $retval; } # # get the shell command used to run spidermonkey # sub get_sm_engine_command { my $retval; # Look for Makefile.ref style make first. # (On Windows, spidermonkey can be made by two makefiles, each putting the # executable in a diferent directory, under a different name.) if ($opt_shell_path) { # if the user provided a path to the shell, return that. $retval = $opt_shell_path; } else { if ($os_type eq "MAC") { $retval = $opt_suite_path . ":src:macbuild:JS"; } else { $retval = $opt_suite_path . "../src/"; opendir (SRC_DIR_FILES, $retval); my @src_dir_files = readdir(SRC_DIR_FILES); closedir (SRC_DIR_FILES); my ($dir, $object_dir); my $pattern = ($opt_engine_type eq "smdebug") ? 'DBG.OBJ' : 'OPT.OBJ'; # scan for the first directory matching # the pattern expected to hold this type (debug or opt) of engine foreach $dir (@src_dir_files) { if ($dir =~ $pattern) { $object_dir = $dir; last; } } if (!$object_dir && $os_type ne "WIN") { die ("Could not locate an object directory in $retval " . "matching the pattern *$pattern. Have you built the " . "engine?\n"); } if (!(-x $retval . $object_dir . "/js.exe") && ($os_type eq "WIN")) { # On windows, you can build with js.mak as well as Makefile.ref # (Can you say WTF boys and girls? I knew you could.) # So, if the exe the would have been built by Makefile.ref isn't # here, check for the js.mak version before dying. if ($opt_shell_path) { $retval = $opt_shell_path; if (!($retval =~ /[\/\\]$/)) { $retval .= "/"; } } else { if ($opt_engine_type eq "smopt") { $retval = "../src/Release/"; } else { $retval = "../src/Debug/"; } } $retval .= "jsshell.exe"; } else { $retval .= $object_dir . "/js"; if ($os_type eq "WIN") { $retval .= ".exe"; } } } # mac/ not mac $retval = &xp_path($retval); } # (user provided a path) if (($os_type ne "MAC") && !(-x $retval)) { # mac doesn't seem to deal with -x correctly die ($retval . " is not a valid executable on this system.\n"); } return $retval; } # # get the shell command used to run epimetheus # sub get_ep_engine_command { my $retval; if ($opt_shell_path) { # if the user provided a path to the shell, return that - $retval = $opt_shell_path; } else { my $dir; my $os; my $debug; my $opt; my $exe; $dir = $opt_suite_path . "../../js2/src/"; if ($os_type eq "MAC") { # # On the Mac, the debug and opt builds lie in the same directory - # $os = "macbuild:"; $debug = ""; $opt = ""; $exe = "JS2"; } elsif ($os_type eq "WIN") { $os = "winbuild/Epimetheus/"; $debug = "Debug/"; $opt = "Release/"; $exe = "Epimetheus.exe"; } else { $os = ""; $debug = ""; $opt = ""; # <<<----- XXX THIS IS NOT RIGHT! CHANGE IT! $exe = "epimetheus"; } if ($opt_engine_type eq "epdebug") { $retval = $dir . $os . $debug . $exe; } else { $retval = $dir . $os . $opt . $exe; } $retval = &xp_path($retval); }# (user provided a path) if (($os_type ne "MAC") && !(-x $retval)) { # mac doesn't seem to deal with -x correctly die ($retval . " is not a valid executable on this system.\n"); } return $retval; } # # get the shell command used to run the liveconnect shell # sub get_lc_engine_command { my $retval; if ($opt_shell_path) { $retval = $opt_shell_path; } else { if ($os_type eq "MAC") { die "Don't know how to run the lc shell on the mac yet.\n"; } else { $retval = $opt_suite_path . "../src/liveconnect/"; opendir (SRC_DIR_FILES, $retval); my @src_dir_files = readdir(SRC_DIR_FILES); closedir (SRC_DIR_FILES); my ($dir, $object_dir); my $pattern = ($opt_engine_type eq "lcdebug") ? 'DBG.OBJ' : 'OPT.OBJ'; foreach $dir (@src_dir_files) { if ($dir =~ $pattern) { $object_dir = $dir; last; } } if (!$object_dir) { die ("Could not locate an object directory in $retval " . "matching the pattern *$pattern. Have you built the " . "engine?\n"); } $retval .= $object_dir . "/"; if ($os_type eq "WIN") { $retval .= "lcshell.exe"; } else { $retval .= "lcshell"; } } # mac/ not mac $retval = &xp_path($retval); } # (user provided a path) if (($os_type ne "MAC") && !(-x $retval)) { # mac doesn't seem to deal with -x correctly die ("$retval is not a valid executable on this system.\n"); } return $retval; } sub get_os_type { if ("\n" eq "\015") { return "MAC"; } my $uname = `uname -a`; if ($uname =~ /WIN/) { $uname = "WIN"; } else { chop $uname; } &dd ("get_os_type returning '$uname'."); return $uname; } sub get_test_list { my @test_list; my @neg_list; if ($#opt_test_list_files > -1) { my $list_file; &dd ("getting test list from user specified source."); foreach $list_file (@opt_test_list_files) { push (@test_list, &expand_user_test_list($list_file)); } } else { &dd ("no list file, groveling in '$opt_suite_path'."); @test_list = &get_default_test_list($opt_suite_path); } if ($#opt_neg_list_files > -1) { my $list_file; my $orig_size = $#test_list + 1; my $actually_skipped; &dd ("getting negative list from user specified source."); foreach $list_file (@opt_neg_list_files) { push (@neg_list, &expand_user_test_list($list_file)); } @test_list = &subtract_arrays (\@test_list, \@neg_list); $actually_skipped = $orig_size - ($#test_list + 1); &dd ($actually_skipped . " of " . $orig_size . " tests will be skipped."); &dd ((($#neg_list + 1) - $actually_skipped) . " skip tests were " . "not actually part of the test list."); } # Don't run any shell.js files as tests; they are only utility files @test_list = grep (!/shell\.js$/, @test_list); # Don't run any browser.js files as tests; they are only utility files @test_list = grep (!/browser\.js$/, @test_list); # Don't run any jsref.js files as tests; they are only utility files @test_list = grep (!/jsref\.js$/, @test_list); return @test_list; } # # reads $list_file, storing non-comment lines into an array. # lines in the form suite_dir/[*] or suite_dir/test_dir/[*] are expanded # to include all test files under the specified directory # sub expand_user_test_list { my ($list_file) = @_; my @retval = (); # # Trim off the leading path separator that begins relative paths on the Mac. # Each path will get concatenated with $opt_suite_path, which ends in one. # # Also note: # # We will call expand_test_list_entry(), which does pattern-matching on $list_file. # This will make the pattern-matching the same as it would be on Linux/Windows - # if ($os_type eq "MAC") { $list_file =~ s/^$path_sep//; } if ($list_file =~ /\.js$/ || -d $opt_suite_path . $list_file) { push (@retval, &expand_test_list_entry($list_file)); } else { open (TESTLIST, $list_file) || die("Error opening test list file '$list_file': $!\n"); while () { s/\r*\n*$//; if (!(/\s*\#/)) { # It's not a comment, so process it push (@retval, &expand_test_list_entry($_)); } } close (TESTLIST); } return @retval; } # # Currently expect all paths to be RELATIVE to the top-level tests directory. # One day, this should be improved to allow absolute paths as well - # sub expand_test_list_entry { my ($entry) = @_; my @retval; if ($entry =~ /\.js$/) { # it's a regular entry, add it to the list if (-f $opt_suite_path . $entry) { push (@retval, $entry); } else { status ("testcase '$entry' not found."); } } elsif ($entry =~ /(.*$path_sep[^\*][^$path_sep]*)$path_sep?\*?$/) { # Entry is in the form suite_dir/test_dir[/*] # so iterate all tests under it my $suite_and_test_dir = $1; my @test_files = &get_js_files ($opt_suite_path . $suite_and_test_dir); my $i; foreach $i (0 .. $#test_files) { $test_files[$i] = $suite_and_test_dir . $path_sep . $test_files[$i]; } splice (@retval, $#retval + 1, 0, @test_files); } elsif ($entry =~ /([^\*][^$path_sep]*)$path_sep?\*?$/) { # Entry is in the form suite_dir[/*] # so iterate all test dirs and tests under it my $suite = $1; my @test_dirs = &get_subdirs ($opt_suite_path . $suite); my $test_dir; foreach $test_dir (@test_dirs) { my @test_files = &get_js_files ($opt_suite_path . $suite . $path_sep . $test_dir); my $i; foreach $i (0 .. $#test_files) { $test_files[$i] = $suite . $path_sep . $test_dir . $path_sep . $test_files[$i]; } splice (@retval, $#retval + 1, 0, @test_files); } } else { die ("Don't know what to do with list entry '$entry'.\n"); } return @retval; } # # Grovels through $suite_path, searching for *all* test files. Used when the # user doesn't supply a test list. # sub get_default_test_list { my ($suite_path) = @_; my @suite_list = &get_subdirs($suite_path); my $suite; my @retval; foreach $suite (@suite_list) { my @test_dir_list = get_subdirs ($suite_path . $suite); my $test_dir; foreach $test_dir (@test_dir_list) { my @test_list = get_js_files ($suite_path . $suite . $path_sep . $test_dir); my $test; foreach $test (@test_list) { $retval[$#retval + 1] = $suite . $path_sep . $test_dir . $path_sep . $test; } } } return @retval; } # # generate an output file name based on the date # sub get_tempfile_name { my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = &get_padded_time (localtime); my $rv; if ($os_type ne "MAC") { $rv = "results-" . $year . "-" . $mon . "-" . $mday . "-" . $hour . $min . $sec . "-" . $opt_engine_type; } else { $rv = "res-" . $year . $mon . $mday . $hour . $min . $sec . "-" . $opt_engine_type } return $rv . ".html"; } sub get_padded_time { my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = @_; $mon++; $mon = &zero_pad($mon); $year += 1900; $mday= &zero_pad($mday); $sec = &zero_pad($sec); $min = &zero_pad($min); $hour = &zero_pad($hour); return ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst); } sub zero_pad { my ($string) = @_; $string = ($string < 10) ? "0" . $string : $string; return $string; } sub subtract_arrays { my ($whole_ref, $part_ref) = @_; my @whole = @$whole_ref; my @part = @$part_ref; my $line; foreach $line (@part) { @whole = grep (!/$line/, @whole); } return @whole; } # # Convert unix path to mac style. # sub unix_to_mac { my ($path) = @_; my @path_elements = split ("/", $path); my $rv = ""; my $i; foreach $i (0 .. $#path_elements) { if ($path_elements[$i] eq ".") { if (!($rv =~ /\:$/)) { $rv .= ":"; } } elsif ($path_elements[$i] eq "..") { if (!($rv =~ /\:$/)) { $rv .= "::"; } else { $rv .= ":"; } } elsif ($path_elements[$i] ne "") { $rv .= $path_elements[$i] . ":"; } } $rv =~ s/\:$//; return $rv; } # # Convert unix path to win style. # sub unix_to_win { my ($path) = @_; if ($path_sep ne $win_sep) { $path =~ s/$path_sep/$win_sep/g; } return $path; } # # Windows shells require "/" or "\" as path separator. # Find out the one used in the current Windows shell. # sub get_win_sep { my $path = $ENV{"PATH"} || $ENV{"Path"} || $ENV{"path"}; $path =~ /\\|\//; return $&; } # # Convert unix path to correct style based on platform. # sub xp_path { my ($path) = @_; if ($os_type eq "MAC") { return &unix_to_mac($path); } elsif($os_type eq "WIN") { return &unix_to_win($path); } else { return $path; } } # # given a directory, return an array of all subdirectories # sub get_subdirs { my ($dir) = @_; my @subdirs; if ($os_type ne "MAC") { if (!($dir =~ /\/$/)) { $dir = $dir . "/"; } } else { if (!($dir =~ /\:$/)) { $dir = $dir . ":"; } } opendir (DIR, $dir) || die ("couldn't open directory $dir: $!"); my @testdir_contents = readdir(DIR); closedir(DIR); foreach (@testdir_contents) { if ((-d ($dir . $_)) && ($_ ne 'CVS') && ($_ ne '.') && ($_ ne '..')) { @subdirs[$#subdirs + 1] = $_; } } return @subdirs; } # # given a directory, return an array of all the js files that are in it. # sub get_js_files { my ($test_subdir) = @_; my (@js_file_array, @subdir_files); opendir (TEST_SUBDIR, $test_subdir) || die ("couldn't open directory " . "$test_subdir: $!"); @subdir_files = readdir(TEST_SUBDIR); closedir( TEST_SUBDIR ); foreach (@subdir_files) { if ($_ =~ /\.js$/) { $js_file_array[$#js_file_array+1] = $_; } } return @js_file_array; } sub report_failure { my ($test, $message, $bug_number) = @_; my $bug_line = ""; $failures_reported++; $message =~ s/\n+/\n/g; $test =~ s/\:/\//g; if ($opt_console_failures) { if ($opt_console_failures_line) { my $linemessage = $message; $linemessage =~ s/[\n\r]+/ /mg; $bug_number = "none" unless $bug_number; print STDERR ("test: $test bug: $bug_number result: FAILED " . "type: shell " . " description: $linemessage\n"); } elsif($bug_number) { print STDERR ("*-* Testcase $test failed:\nBug Number $bug_number". "\n$message\n"); } else { print STDERR ("*-* Testcase $test failed:\n$message\n"); } } $message =~ s/&/&/g; $message =~ s//>/g; $message =~ s/\n/
\n/g; if ($bug_number) { my $bug_url = ($bug_number =~ /^\d+$/) ? "$opt_bug_url$bug_number" : $bug_number; $bug_line = "". "Bug Number $bug_number"; } if ($opt_lxr_url) { $test =~ /\/?([^\/]+\/[^\/]+\/[^\/]+)$/; $test = $1; $html .= "
". "Testcase $1 " . "failed $bug_line
\n"; } else { $html .= "
". "Testcase $test failed $bug_line
\n"; } $html .= " [ "; $html .= "Top of Page ]
\n" . "$message
\n"; @failed_tests[$#failed_tests + 1] = $test; } sub dd { if ($opt_trace) { print ("-*- ", @_ , "\n"); } } sub status { print ("-#- ", @_ , "\n"); } sub int_handler { my $resp; if ($current_test_pid) { print "User Interrupt: killing process $current_test_pid\n"; kill_process($current_test_pid); } do { print STDERR ("\n*** User Break: Just [Q]uit, Quit and [R]eport, [C]ontinue ?"); $resp = ; } until ($resp =~ /[QqRrCc]/); if ($resp =~ /[Qq]/) { print ("User Exit. No results were generated.\n"); exit; } elsif ($resp =~ /[Rr]/) { $user_exit = 1; } } # XXX: These functions were pulled from # lxr.mozilla.org/mozilla/source/tools/tinderbox/build-seamonkey-util.pl # need a general reusable library of routines for use in all test programs. sub kill_process { my ($target_pid) = @_; my $start_time = time; # Try to kill and wait 10 seconds, then try a kill -9 my $sig; for $sig ('TERM', 'KILL') { print "kill $sig $target_pid\n"; kill $sig => $target_pid; my $interval_start = time; while (time - $interval_start < 10) { # the following will work with 'cygwin' perl on win32, but not # with 'MSWin32' (ActiveState) perl my $pid = waitpid($target_pid, POSIX::WNOHANG()); if (($pid == $target_pid and POSIX::WIFEXITED($?)) or $pid == -1) { my $secs = time - $start_time; $secs = $secs == 1 ? '1 second' : "$secs seconds"; return; } sleep 1; } } die "Unable to kill process: $target_pid"; }