1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
#!/usr/bin/perl -w
# $Id: //info.ravenbrook.com/project/mps/master/test/test/qa#4 $
#
# First, we'll set up @INC so we can find the other
# perl scripts we require. This program will be in the
# test directory, and all the other scripts will be
# in the script subdirectory.
#
# $0 contains the name of this program, as it was run
# this means it may not be the full path, but should be
# enough of the path for us to use it to locate other
# perl scripts.
# We assume the separator is / and the program name is
# made only of A-Za-z0-9 and _.

if ($] < 5) {
 die "The QA harness requires perl 5 or greater (this is version $]).\n";
}

$test_dir = $0;

$0 = "mmqa harness"; # this will show up in ps

$test_dir =~ s/\\/\//g; # i.e. convert to unix-style separators

unless ($test_dir =~ m/\//) {
 $test_dir = "./".$test_dir;
} # ensure it has at least one / in it

$test_dir =~ s/\/\w+$//; # remove leaf name and preceding separator

$script_dir = $test_dir."/script";

foreach (@INC) {
 if ($_ ne '.') { push(@newINC, $_) }
}
push(@newINC, $script_dir);
@INC = @newINC;

# other directories will be set when needed by requiring
# the 'dirs' file. This must be done after reading command-line
# options, so we don't try it now


$| = 1;


# what we do is
# (1) load in the harness, via require
# (2) init, inc reading command line options
# (3) run command
#
# Policy on options is: which options are meaningful and which are
# required may be command dependent, _but_ what options exist
# and what switches correspond to them is not.
#

require "require";

&harness_init;

# n.b. the above will alter @ARGV as it reads command-line options
#

$qa_command = shift(@ARGV);

unless ($qa_command)  {
 die "You must specify a command -- try 'qa help' for details.\n";
}
unless (-e "$script_dir/commands/".$qa_command) {
 die "Unknown command '".$qa_command."' -- 'qa help' for info.\n";
}

$exitstatus = 0;
do "commands/".$qa_command;
if ($@) {print $@};
exit $exitstatus;