16 use Getopt::Long qw(:config no_ignore_case);
19 # We execute lots of subprocesses.
20 # Without this, our stdout output can get flushed multiple times,
21 # which is harmless but looks bizarre.
25 my ($do_regex, $no_regex);
26 GetOptions ("v|verbose+" => \$verbose,
27 "h|help" => sub { usage (0) },
28 "d|do-tests=s" => \$do_regex,
29 "n|no-tests=s" => \$no_regex,
30 "c|clean" => sub { set_action ('clean'); },
31 "x|extract" => sub { set_action ('extract'); },
32 "b|build" => sub { set_action ('build'); },
33 "t|test" => sub { set_action ('test'); },
34 "a|assemble" => sub { set_action ('assemble'); })
35 or die "Malformed command line; use --help for help.\n";
36 die "Non-option arguments not supported; use --help for help.\n"
38 @TESTS = split(/,/, join (',', @TESTS)) if defined @TESTS;
40 if (!defined $action) {
41 $action = -e 'review.txt' ? 'assemble' : 'test';
44 my (@default_tests) = @_;
45 @TESTS = @default_tests;
46 @TESTS = grep (/$do_regex/, @TESTS) if defined $do_regex;
47 @TESTS = grep (!/$no_regex/, @TESTS) if defined $no_regex;
51 my ($new_action) = @_;
52 die "actions `$action' and `$new_action' conflict\n"
53 if defined ($action) && $action ne $new_action;
54 $action = $new_action;
60 run-tests, for grading Pintos $hw projects.
62 Invoke from a directory containing a student tarball named by
63 the submit script, e.g. username.MMM.DD.YY.hh.mm.ss.tar.gz.
67 1. Extracts the source tree into pintos/src and applies patches.
69 2. Builds the source tree. (The threads project modifies and rebuilds
70 the source tree for every test.)
72 3. Runs the tests on the source tree and grades them. Writes
73 "tests.out" with a summary of the test results, and "details.out"
74 with test failure and warning details.
76 4. By hand, copy "review.txt" from the tests directory and use it as a
77 template for grading design documents.
79 5. Assembles "grade.txt", "tests.out", "review.txt", and "tests.out"
80 into "grade.out". This is primarily simple concatenation, but
81 point totals are tallied up as well.
84 -c, --clean Delete test results and temporary files, then exit.
85 -d, --do-tests=RE Run only tests that match the given regular expression.
86 -n, --no-tests=RE Do not run tests that match the given regular expression.
87 -x, --extract Stop after step 1.
88 -b, --build Stop after step 2.
89 -t, --test Stop after step 3 (default if "review.txt" not present).
90 -a, --assemble Stop after step 5 (default if "review.txt" exists).
91 -v, --verbose Print command lines of subcommands before executing them.
92 -h, --help Print this help message.
99 # Extracts the group's source files into pintos/src,
100 # applies any patches providing in the grading directory,
101 # and installs a default pintos/src/constants.h
102 sub extract_sources {
103 # Make sure the output dir exists.
104 -d ("output") || mkdir ("output") or die "output: mkdir: $!\n";
106 # Nothing else to do if we already have a source tree.
107 return if -d "pintos";
109 my ($tarball) = choose_tarball ();
112 print "Creating pintos/src...\n";
113 mkdir "pintos" or die "pintos: mkdir: $!\n";
114 mkdir "pintos/src" or die "pintos/src: mkdir: $!\n";
116 print "Extracting $tarball into pintos/src...\n";
117 xsystem ("cd pintos/src && tar xzf ../../$tarball",
118 DIE => "extraction failed\n");
120 # Run custom script for this submission, if provided.
122 print "Running fixme.sh...\n";
123 xsystem ("sh -e fixme.sh", DIE => "fix script failed\n");
125 print "No fixme.sh, assuming no custom changes needed.\n";
128 # Apply patches from grading directory.
129 # Patches are applied in lexicographic order, so they should
130 # probably be named 00debug.patch, 01bitmap.patch, etc.
131 # Filenames in patches should be in the format pintos/src/...
132 print "Patching...\n";
133 for my $patch (glob ("$GRADES_DIR/patches/*.patch")) {
135 ($stem = $patch) =~ s%^$GRADES_DIR/patches/%% or die;
136 print "Applying $patch...\n";
137 xsystem ("patch -fs -p0 < $patch",
138 LOG => $stem, DIE => "applying patch $stem failed\n");
141 # Install default pintos/src/constants.h.
142 open (CONSTANTS, ">pintos/src/constants.h")
143 or die "constants.h: create: $!\n";
144 print CONSTANTS "#define THREAD_JOIN_IMPLEMENTED 1\n";
148 # Returns the name of the tarball to extract.
151 = grep (/^[a-z0-9]+\.[A-Za-z]+\.\d+\.\d+\.\d+\.\d+.\d+\.tar\.gz$/,
153 die "no pintos dir, no files matching username.MMM.DD.YY.hh.mm.ss.tar.gz\n"
154 if scalar (@tarballs) == 0;
157 # Sort tarballs in order by time.
158 @tarballs = sort { ext_mdyHMS ($a) cmp ext_mdyHMS ($b) } @tarballs;
160 print "Multiple tarballs:\n";
161 print "\t$_ submitted ", ext_mdyHMS ($_), "\n" foreach @tarballs;
162 print "Choosing $tarballs[$#tarballs]\n";
164 return $tarballs[$#tarballs];
167 # Extract the date within a tarball name into a string that compares
168 # lexicographically in chronological order.
171 my ($ms, $d, $y, $H, $M, $S) =
172 $s =~ /.([A-Za-z]+)\.(\d+)\.(\d+)\.(\d+)\.(\d+).(\d+)\.tar\.gz$/
174 my ($m) = index ("janfebmaraprmayjunjulaugsepoctnovdec", lc $ms) / 3
176 return sprintf "%02d-%02d-%02d %02d:%02d:%02d", $y, $m, $d, $H, $M, $S;
182 print "Compiling...\n";
183 xsystem ("cd pintos/src/$hw && make", LOG => "make") eq 'ok'
184 or return "Build error";
187 # Run and grade the tests.
188 sub run_and_grade_tests {
191 my ($result) = get_test_result ();
194 my ($grade) = grade_test ($test);
197 my ($msg) = $result eq 'ok' ? $grade : "$result - $grade";
198 $msg .= " - with warnings"
199 if $grade eq 'ok' && defined $details{$test};
202 $result{$test} = $grade;
206 # Write test grades to tests.out.
208 my (@summary) = snarf ("$GRADES_DIR/tests.txt");
214 for (my ($i) = 0; $i <= $#summary; $i++) {
215 local ($_) = $summary[$i];
216 if (my ($loss, $test) = /^ -(\d+) ([-a-zA-Z0-9]+):/) {
217 my ($result) = $result{$test} || "Not tested.";
219 if ($result eq 'ok') {
220 if (!defined $details{$test}) {
221 # Test successful and no warnings.
222 splice (@summary, $i, 1);
225 # Test successful with warnings.
228 splice (@summary, $i + 1, 0,
229 " Test passed with warnings. "
230 . "Details at end of file.");
236 splice (@summary, $i + 1, 0,
237 map (" $_", split ("\n", $result)));
239 } elsif (my ($ptotal) = /^Score: \/(\d+)$/) {
241 $summary[$i] = "Score: " . ($ptotal - $ploss) . "/$ptotal";
242 splice (@summary, $i, 0, " All tests passed.")
243 if $ploss == 0 && !$warnings;
249 my ($ts) = "(" . ($total - $tloss) . "/" . $total . ")";
250 $summary[0] =~ s/\[\[total\]\]/$ts/;
252 open (SUMMARY, ">tests.out");
253 print SUMMARY map ("$_\n", @summary);
257 # Write failure and warning details to details.out.
259 open (DETAILS, ">details.out");
262 next if $result{$test} eq 'ok' && !defined $details{$test};
264 my ($details) = $details{$test};
265 next if !defined ($details) && ! -e "output/$test/run.out";
268 if ($result{$test} ne 'ok') {
269 $banner = "$test failure details";
271 $banner = "$test warnings";
274 print DETAILS "\n" if $n++;
275 print DETAILS "--- $banner ", '-' x (50 - length ($banner));
276 print DETAILS "\n\n";
278 if (!defined $details) {
279 my (@output) = snarf ("output/$test/run.out");
281 # Print only the first in a series of recursing panics.
283 for my $i (0...$#output) {
284 local ($_) = $output[$i];
285 if (/PANIC/ && $panic++ > 0) {
286 @output = @output[0...$i];
288 "[...details of recursive panic(s) omitted...]");
292 $details = "Output:\n\n" . join ('', map ("$_\n", @output));
294 print DETAILS $details;
296 print DETAILS "\n", "-" x 10, "\n\n$extra{$test}"
297 if defined $extra{$test};
303 my ($command, %options) = @_;
304 print "$command\n" if $verbose || $options{VERBOSE};
306 my ($log) = $options{LOG};
310 local $SIG{ALRM} = sub { die "alarm\n" };
311 alarm $options{TIMEOUT} if defined $options{TIMEOUT};
313 die "fork: $!\n" if !defined $pid;
316 open (STDOUT, ">output/$log.out");
317 open (STDERR, ">output/$log.err");
329 die unless $@ eq "alarm\n"; # propagate unexpected errors
331 for ($i = 0; $i < 10; $i++) {
332 kill ('SIGTERM', $pid);
334 my ($retval) = waitpid ($pid, WNOHANG);
335 last if $retval == $pid || $retval == -1;
336 print "Timed out - Waiting for $pid to die" if $i == 0;
342 if (WIFSIGNALED ($status)) {
343 my ($signal) = WTERMSIG ($status);
344 die "Interrupted\n" if $signal == SIGINT;
345 print "Child terminated with signal $signal\n";
348 $result = $status == 0 ? "ok" : "error";
351 if ($result eq 'error' && defined $options{DIE}) {
352 my ($msg) = $options{DIE};
353 if (defined ($log)) {
355 $msg .= "; see output/$log.err and output/$log.out for details\n";
358 } elsif ($result ne 'error' && defined ($log)) {
359 unlink ("output/$log.err");
365 sub get_test_result {
366 my ($cache_file) = "output/$test/run.result";
367 # Reuse older results if any.
368 if (open (RESULT, "<$cache_file")) {
376 # If there's residue from an earlier test, move it to .old.
377 # If there's already a .old, delete it.
378 xsystem ("rm -rf output/$test.old", VERBOSE => 1) if -d "output/$test.old";
379 rename "output/$test", "output/$test.old" or die "rename: $!\n"
380 if -d "output/$test";
382 # Make output directory.
383 mkdir "output/$test";
386 my ($result) = run_test ($test);
388 # Delete any disks in the output directory because they take up
390 unlink (glob ("output/$test/*.dsk"));
392 # Save the results for later.
393 open (DONE, ">$cache_file") or die "$cache_file: create: $!\n";
394 print DONE "$result\n";
401 my ($cmd_line, %args) = @_;
402 my ($retval) = xsystem ($cmd_line, %args);
403 return 'ok' if $retval eq 'ok';
404 return "Timed out after $args{TIMEOUT} seconds" if $retval eq 'timeout';
405 return 'Error running Bochs' if $retval eq 'error';
412 my ($outfile) = "output/$test/run.out";
413 die "$outfile: missing test output file (make failed?)" if ! -e $outfile;
414 my (@output) = snarf ($outfile);
416 # If there's a function "grade_$test", use it to evaluate the output.
417 # If there's a file "$GRADES_DIR/$test.exp", compare its contents
418 # against the output.
419 # (If both exist, prefer the function.)
421 # If the test was successful, it returns normally.
422 # If it failed, it invokes `die' with an error message terminated
423 # by a new-line. The message will be given as an explanation in
424 # the output file tests.out.
425 # (Internal errors will invoke `die' without a terminating
426 # new-line, in which case we detect it and propagate the `die'
428 my ($grade_func) = "grade_$test";
429 $grade_func =~ s/-/_/g;
430 if (-e "$GRADES_DIR/$test.exp" && !defined (&$grade_func)) {
432 verify_common (@output);
433 compare_output ("$GRADES_DIR/$test.exp", @output);
436 eval "$grade_func (\@output)";
439 die $@ if $@ =~ /at \S+ line \d+$/;
446 # Combines grade.txt, tests.out, review.txt, and details.out,
447 # producing grade.out.
448 sub assemble_final_grade {
449 open (OUT, ">grade.out") or die "grade.out: create: $!\n";
451 open (GRADE, "<grade.txt") or die "grade.txt: open: $!\n";
458 my (@tests) = snarf ("tests.out");
459 my ($p_got, $p_pos) = $tests[0] =~ m%\((\d+)/(\d+)\)% or die;
461 my (@review) = snarf ("review.txt");
462 my ($part_lost) = (0, 0);
463 for (my ($i) = $#review; $i >= 0; $i--) {
464 local ($_) = $review[$i];
465 if (my ($loss) = /^\s*([-+]\d+)/) {
467 } elsif (my ($out_of) = m%\[\[/(\d+)\]\]%) {
468 my ($got) = $out_of + $part_lost;
469 $got = 0 if $got < 0;
470 $review[$i] =~ s%\[\[/\d+\]\]%($got/$out_of)% or die;
477 die "Lost points outside a section\n" if $part_lost;
479 for (my ($i) = 1; $i <= $#review; $i++) {
480 if ($review[$i] =~ /^-{3,}\s*$/ && $review[$i - 1] !~ /^\s*$/) {
481 $review[$i] = '-' x (length ($review[$i - 1]));
485 print OUT "\nOVERALL SCORE\n";
486 print OUT "-------------\n";
487 print OUT "$p_got points out of $p_pos total\n\n";
489 print OUT map ("$_\n", @tests), "\n";
490 print OUT map ("$_\n", @review), "\n";
492 print OUT "DETAILS\n";
493 print OUT "-------\n\n";
494 print OUT map ("$_\n", snarf ("details.out"));
497 # Clean up our generated files.
499 # Verify that we're roughly in the correct directory
500 # before we go blasting away files.
503 # Blow away everything.
504 xsystem ("rm -rf output pintos", VERBOSE => 1);
505 xsystem ("rm -f details.out tests.out", VERBOSE => 1);
508 # Provided a test's output as an array, verifies that it, in general,
509 # looks sensible; that is, that there are no PANIC or FAIL messages,
510 # that Pintos started up and shut down normally, and so on.
511 # Die if something odd found.
515 die "No output at all\n" if @output == 0;
517 look_for_panic (@output);
518 look_for_fail (@output);
519 look_for_triple_fault (@output);
521 die "Didn't start up properly: no \"Pintos booting\" startup message\n"
522 if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
523 die "Didn't start up properly: no \"Boot complete\" startup message\n"
524 if !grep (/Boot complete/, @output);
525 die "Didn't shut down properly: no \"Timer: # ticks\" shutdown message\n"
526 if !grep (/Timer: \d+ ticks/, @output);
527 die "Didn't shut down properly: no \"Powering off\" shutdown message\n"
528 if !grep (/Powering off/, @output);
534 my ($panic) = grep (/PANIC/, @output);
535 return unless defined $panic;
537 my ($details) = "Kernel panic:\n $panic\n";
539 my (@stack_line) = grep (/Call stack:/, @output);
540 if (@stack_line != 0) {
541 $details .= " $stack_line[0]\n\n";
542 $details .= "Translation of backtrace:\n";
543 my (@addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
547 =~ /i.86|pentium.*|[pk][56]|nexgen|viac3|6x86|athlon.*/) {
550 $A2L = "i386-elf-addr2line";
553 if ($hw eq 'threads') {
554 $kernel_o = "output/$test/kernel.o";
556 $kernel_o = "pintos/src/$hw/build/kernel.o";
558 open (A2L, "$A2L -fe $kernel_o @addrs|");
560 my ($function, $line);
561 last unless defined ($function = <A2L>);
565 $details .= " $function ($line)\n";
569 if ($panic =~ /sec_no < d->capacity/) {
571 \nThis assertion commonly fails when accessing a file via an inode that
572 has been closed and freed. Freeing an inode clears all its sector
573 indexes to 0xcccccccc, which is not a valid sector number for disks
574 smaller than about 1.6 TB.
578 $extra{$test} = $details;
579 die "Kernel panic. Details at end of file.\n";
585 my ($failure) = grep (/FAIL/, @output);
586 return unless defined $failure;
588 # Eliminate uninteresting header and trailer info if possible.
589 # The `eval' catches the `die' from get_core_output() in the "not
592 my (@core) = get_core_output (@output);
593 $details{$test} = "Program output:\n\n" . join ('', map ("$_\n", @core));
596 # Most output lines are prefixed by (test-name). Eliminate this
597 # from our `die' message for brevity.
598 $failure =~ s/^\([^\)]+\)\s+//;
599 die "$failure. Details at end of file.\n";
602 sub look_for_triple_fault {
605 return unless grep (/Pintos booting/, @output) > 1;
607 my ($details) = <<EOF;
608 Pintos spontaneously rebooted during this test. This is most often
609 due to unhandled page faults. Output from initial boot through the
610 first reboot is shown below:
618 last if /Pintos booting/ && ++$i > 1;
620 $details{$test} = $details;
621 die "Triple-fault caused spontaneous reboot(s). "
622 . "Details at end of file.\n";
625 # Get @output without header or trailer.
626 # Die if not possible.
627 sub get_core_output {
631 for ($first = 0; $first <= $#output; $first++) {
632 my ($line) = $output[$first];
634 if ($hw ne 'threads' && $line =~ /^Executing '$test.*':$/)
636 && grep (/^Boot complete.$/, @output[0...$first - 1])
637 && $line =~ /^\s*$/);
641 for ($last = $#output; $last >= 0; $last--) {
642 $last--, last if $output[$last] =~ /^Timer: \d+ ticks$/;
645 if ($last < $first) {
646 my ($no_first) = $first > $#output;
647 my ($no_last) = $last < $#output;
648 die "Couldn't locate output.\n";
651 return @output[$first ... $last];
654 sub canonicalize_exit_codes {
657 # Exit codes are supposed to be printed in the form "process: exit(code)"
658 # but people get unfortunately creative with it.
659 for my $i (0...$#output) {
660 local ($_) = $output[$i];
662 my ($process, $code);
663 if ((($process, $code) = /^([-a-z0-9 ]+):.*[ \(](-?\d+)\b\)?$/)
664 || (($process, $code) = /^([-a-z0-9 ]+) exit\((-?\d+)\)$/)
665 || (($process, $code)
666 = /^([-a-z0-9 ]+) \(.*\): exit\((-?\d+)\)$/)
667 || (($process, $code) = /^([-a-z0-9 ]+):\( (-?\d+) \) $/)
668 || (($code, $process) = /^shell: exit\((-?\d+)\) \| ([-a-z0-9]+)/))
670 # We additionally truncate to 15 character and strip all
671 # but the first word.
672 $process = substr ($process, 0, 15);
673 $process =~ s/\s.*//;
674 $output[$i] = "$process: exit($code)\n";
681 sub strip_exit_codes {
682 return grep (!/^[-a-z0-9]+: exit\(-?\d+\)/, canonicalize_exit_codes (@_));
686 my ($exp, @actual) = @_;
688 # Canonicalize output for comparison.
689 @actual = get_core_output (map ("$_\n", @actual));
690 if ($hw eq 'userprog') {
691 @actual = canonicalize_exit_codes (@actual);
692 } elsif ($hw eq 'vm' || $hw eq 'filesys') {
693 @actual = strip_exit_codes (@actual);
696 # There *was* some output, right?
697 die "Program produced no output.\n" if !@actual;
699 # Read expected output.
700 my (@exp) = map ("$_\n", snarf ($exp));
702 # Pessimistically, start preparation of detailed failure message.
704 $details .= "$test actual output:\n";
705 $details .= join ('', map (" $_", @actual));
707 # Set true when we find expected output that matches our actual
708 # output except for some extra actual output (that doesn't seem to
709 # be an error message etc.).
710 my ($fuzzy_match) = 0;
712 # Compare actual output against each allowed output.
714 # Grab one set of allowed output from @exp into @expected.
717 my ($s) = shift (@exp);
718 last if $s eq "--OR--\n";
719 push (@expected, $s);
722 $details .= "\n$test acceptable output:\n";
723 $details .= join ('', map (" $_", @expected));
725 # Check whether actual and expected match.
726 # If it's a perfect match, return.
727 if ($#actual == $#expected) {
729 for (my ($i) = 0; $i <= $#expected; $i++) {
730 $eq = 0 if $actual[$i] ne $expected[$i];
735 # They differ. Output a diff.
737 my ($d) = Algorithm::Diff->new (\@expected, \@actual);
738 my ($not_fuzzy_match) = 0;
739 while ($d->Next ()) {
740 my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
742 push (@diff, map (" $_", $d->Items (1)));
744 push (@diff, map ("- $_", $d->Items (1))) if $d->Items (1);
745 push (@diff, map ("+ $_", $d->Items (2))) if $d->Items (2);
747 || grep (/\($test\)|exit\(-?\d+\)|dying due to|Page fault/,
749 $not_fuzzy_match = 1;
754 # If we didn't find anything that means it's not,
755 # it's a fuzzy match.
756 $fuzzy_match = 1 if !$not_fuzzy_match;
758 $details .= "Differences in `diff -u' format:\n";
759 $details .= join ('', @diff);
760 $details .= "(This is considered a `fuzzy match'.)\n"
761 if !$not_fuzzy_match;
764 # Failed to match. Report failure.
767 "This test passed, but with extra, unexpected output.\n"
768 . "Please inspect your code to make sure that it does not\n"
769 . "produce output other than as specified in the project\n"
774 "This test failed because its output did not match any\n"
775 . "of the acceptable form(s).\n\n"
779 $details{$test} = $details;
780 die "Output differs from expected. Details at end of file.\n"
784 # Reads and returns the contents of the specified file.
785 # In an array context, returns the file's contents as an array of
786 # lines, omitting new-lines.
787 # In a scalar context, returns the file's contents as a single string.
790 open (OUTPUT, $file) or die "$file: open: $!\n";
791 my (@lines) = <OUTPUT>;
794 return wantarray ? @lines : join ('', map ("$_\n", @lines));
797 # Returns true if the two specified files are byte-for-byte identical,
802 open (A, "<$a") or die "$a: open: $!\n";
803 open (B, "<$b") or die "$b: open: $!\n";
809 sysread (A, $sa, 1024);
810 sysread (B, $sb, 1024);
811 $equal = 0, last if $sa ne $sb;
812 $equal = 1, last if $sa eq '';
820 # Returns true if the specified file is byte-for-byte identical with
821 # the specified string.
823 my ($file, $expected) = @_;
824 open (FILE, "<$file") or die "$file: open: $!\n";
826 sysread (FILE, $actual, -s FILE);
827 my ($equal) = $actual eq $expected;
833 for my $test (@TESTS) {
834 return 1 if !defined ($result{$test}) || $result{$test} ne 'ok';