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 if ($retval eq 'timeout') {
405 my ($msg) = "Timed out after $args{TIMEOUT} seconds";
406 my ($load_avg) = `uptime` =~ /(load average:.*)$/i;
407 $msg .= " - $load_avg" if defined $load_avg;
410 return 'Error running Bochs' if $retval eq 'error';
417 my ($outfile) = "output/$test/run.out";
418 die "$outfile: missing test output file (make failed?)" if ! -e $outfile;
419 my (@output) = snarf ($outfile);
421 # If there's a function "grade_$test", use it to evaluate the output.
422 # If there's a file "$GRADES_DIR/$test.exp", compare its contents
423 # against the output.
424 # (If both exist, prefer the function.)
426 # If the test was successful, it returns normally.
427 # If it failed, it invokes `die' with an error message terminated
428 # by a new-line. The message will be given as an explanation in
429 # the output file tests.out.
430 # (Internal errors will invoke `die' without a terminating
431 # new-line, in which case we detect it and propagate the `die'
433 my ($grade_func) = "grade_$test";
434 $grade_func =~ s/-/_/g;
435 if (-e "$GRADES_DIR/$test.exp" && !defined (&$grade_func)) {
437 verify_common (@output);
438 compare_output ("$GRADES_DIR/$test.exp", @output);
441 eval "$grade_func (\@output)";
444 die $@ if $@ =~ /at \S+ line \d+$/;
451 # Combines grade.txt, tests.out, review.txt, and details.out,
452 # producing grade.out.
453 sub assemble_final_grade {
454 open (OUT, ">grade.out") or die "grade.out: create: $!\n";
456 open (GRADE, "<grade.txt") or die "grade.txt: open: $!\n";
463 my (@tests) = snarf ("tests.out");
464 my ($p_got, $p_pos) = $tests[0] =~ m%\((\d+)/(\d+)\)% or die;
466 my (@review) = snarf ("review.txt");
467 my ($part_lost) = (0, 0);
468 for (my ($i) = $#review; $i >= 0; $i--) {
469 local ($_) = $review[$i];
470 if (my ($loss) = /^\s*([-+]\d+)/) {
472 } elsif (my ($out_of) = m%\[\[/(\d+)\]\]%) {
473 my ($got) = $out_of + $part_lost;
474 $got = 0 if $got < 0;
475 $review[$i] =~ s%\[\[/\d+\]\]%($got/$out_of)% or die;
482 die "Lost points outside a section\n" if $part_lost;
484 for (my ($i) = 1; $i <= $#review; $i++) {
485 if ($review[$i] =~ /^-{3,}\s*$/ && $review[$i - 1] !~ /^\s*$/) {
486 $review[$i] = '-' x (length ($review[$i - 1]));
490 print OUT "\nOVERALL SCORE\n";
491 print OUT "-------------\n";
492 print OUT "$p_got points out of $p_pos total\n\n";
494 print OUT map ("$_\n", @tests), "\n";
495 print OUT map ("$_\n", @review), "\n";
497 print OUT "DETAILS\n";
498 print OUT "-------\n\n";
499 print OUT map ("$_\n", snarf ("details.out"));
502 # Clean up our generated files.
504 # Verify that we're roughly in the correct directory
505 # before we go blasting away files.
508 # Blow away everything.
509 xsystem ("rm -rf output pintos", VERBOSE => 1);
510 xsystem ("rm -f details.out tests.out", VERBOSE => 1);
513 # Provided a test's output as an array, verifies that it, in general,
514 # looks sensible; that is, that there are no PANIC or FAIL messages,
515 # that Pintos started up and shut down normally, and so on.
516 # Die if something odd found.
520 die "No output at all\n" if @output == 0;
522 look_for_panic (@output);
523 look_for_fail (@output);
524 look_for_triple_fault (@output);
526 die "Didn't start up properly: no \"Pintos booting\" startup message\n"
527 if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
528 die "Didn't start up properly: no \"Boot complete\" startup message\n"
529 if !grep (/Boot complete/, @output);
530 die "Didn't shut down properly: no \"Timer: # ticks\" shutdown message\n"
531 if !grep (/Timer: \d+ ticks/, @output);
532 die "Didn't shut down properly: no \"Powering off\" shutdown message\n"
533 if !grep (/Powering off/, @output);
539 my ($panic) = grep (/PANIC/, @output);
540 return unless defined $panic;
542 my ($details) = "Kernel panic:\n $panic\n";
544 my (@stack_line) = grep (/Call stack:/, @output);
545 if (@stack_line != 0) {
546 $details .= " $stack_line[0]\n\n";
547 $details .= "Translation of backtrace:\n";
548 my (@addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
552 =~ /i.86|pentium.*|[pk][56]|nexgen|viac3|6x86|athlon.*/) {
555 $A2L = "i386-elf-addr2line";
558 if ($hw eq 'threads') {
559 $kernel_o = "output/$test/kernel.o";
561 $kernel_o = "pintos/src/$hw/build/kernel.o";
563 open (A2L, "$A2L -fe $kernel_o @addrs|");
565 my ($function, $line);
566 last unless defined ($function = <A2L>);
570 $details .= " $function ($line)\n";
574 if ($panic =~ /sec_no < d->capacity/) {
576 \nThis assertion commonly fails when accessing a file via an inode that
577 has been closed and freed. Freeing an inode clears all its sector
578 indexes to 0xcccccccc, which is not a valid sector number for disks
579 smaller than about 1.6 TB.
583 $extra{$test} = $details;
584 die "Kernel panic. Details at end of file.\n";
590 my ($failure) = grep (/FAIL/, @output);
591 return unless defined $failure;
593 # Eliminate uninteresting header and trailer info if possible.
594 # The `eval' catches the `die' from get_core_output() in the "not
597 my (@core) = get_core_output (@output);
598 $details{$test} = "Program output:\n\n" . join ('', map ("$_\n", @core));
601 # Most output lines are prefixed by (test-name). Eliminate this
602 # from our `die' message for brevity.
603 $failure =~ s/^\([^\)]+\)\s+//;
604 die "$failure. Details at end of file.\n";
607 sub look_for_triple_fault {
610 return unless grep (/Pintos booting/, @output) > 1;
612 my ($details) = <<EOF;
613 Pintos spontaneously rebooted during this test. This is most often
614 due to unhandled page faults. Output from initial boot through the
615 first reboot is shown below:
623 last if /Pintos booting/ && ++$i > 1;
625 $details{$test} = $details;
626 die "Triple-fault caused spontaneous reboot(s). "
627 . "Details at end of file.\n";
630 # Get @output without header or trailer.
631 # Die if not possible.
632 sub get_core_output {
636 for ($first = 0; $first <= $#output; $first++) {
637 my ($line) = $output[$first];
639 if ($hw ne 'threads' && $line =~ /^Executing '$test.*':$/)
641 && grep (/^Boot complete.$/, @output[0...$first - 1])
642 && $line =~ /^\s*$/);
646 for ($last = $#output; $last >= 0; $last--) {
647 $last--, last if $output[$last] =~ /^Timer: \d+ ticks$/;
650 if ($last < $first) {
651 my ($no_first) = $first > $#output;
652 my ($no_last) = $last < $#output;
653 die "Couldn't locate output.\n";
656 return @output[$first ... $last];
659 sub canonicalize_exit_codes {
662 # Exit codes are supposed to be printed in the form "process: exit(code)"
663 # but people get unfortunately creative with it.
664 for my $i (0...$#output) {
665 local ($_) = $output[$i];
667 my ($process, $code);
668 if ((($process, $code) = /^([-a-z0-9 ]+):.*[ \(](-?\d+)\b\)?$/)
669 || (($process, $code) = /^([-a-z0-9 ]+) exit\((-?\d+)\)$/)
670 || (($process, $code)
671 = /^([-a-z0-9 ]+) \(.*\): exit\((-?\d+)\)$/)
672 || (($process, $code) = /^([-a-z0-9 ]+):\( (-?\d+) \) $/)
673 || (($code, $process) = /^shell: exit\((-?\d+)\) \| ([-a-z0-9]+)/))
675 # We additionally truncate to 15 character and strip all
676 # but the first word.
677 $process = substr ($process, 0, 15);
678 $process =~ s/\s.*//;
679 $output[$i] = "$process: exit($code)\n";
686 sub strip_exit_codes {
687 return grep (!/^[-a-z0-9]+: exit\(-?\d+\)/, canonicalize_exit_codes (@_));
691 my ($exp, @actual) = @_;
693 # Canonicalize output for comparison.
694 @actual = get_core_output (map ("$_\n", @actual));
695 if ($hw eq 'userprog') {
696 @actual = canonicalize_exit_codes (@actual);
697 } elsif ($hw eq 'vm' || $hw eq 'filesys') {
698 @actual = strip_exit_codes (@actual);
701 # There *was* some output, right?
702 die "Program produced no output.\n" if !@actual;
704 # Read expected output.
705 my (@exp) = map ("$_\n", snarf ($exp));
707 # Pessimistically, start preparation of detailed failure message.
709 $details .= "$test actual output:\n";
710 $details .= join ('', map (" $_", @actual));
712 # Set true when we find expected output that matches our actual
713 # output except for some extra actual output (that doesn't seem to
714 # be an error message etc.).
715 my ($fuzzy_match) = 0;
717 # Compare actual output against each allowed output.
719 # Grab one set of allowed output from @exp into @expected.
722 my ($s) = shift (@exp);
723 last if $s eq "--OR--\n";
724 push (@expected, $s);
727 $details .= "\n$test acceptable output:\n";
728 $details .= join ('', map (" $_", @expected));
730 # Check whether actual and expected match.
731 # If it's a perfect match, return.
732 if ($#actual == $#expected) {
734 for (my ($i) = 0; $i <= $#expected; $i++) {
735 $eq = 0 if $actual[$i] ne $expected[$i];
740 # They differ. Output a diff.
742 my ($d) = Algorithm::Diff->new (\@expected, \@actual);
743 my ($not_fuzzy_match) = 0;
744 while ($d->Next ()) {
745 my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
747 push (@diff, map (" $_", $d->Items (1)));
749 push (@diff, map ("- $_", $d->Items (1))) if $d->Items (1);
750 push (@diff, map ("+ $_", $d->Items (2))) if $d->Items (2);
752 || grep (/\($test\)|exit\(-?\d+\)|dying due to|Page fault/,
754 $not_fuzzy_match = 1;
759 # If we didn't find anything that means it's not,
760 # it's a fuzzy match.
761 $fuzzy_match = 1 if !$not_fuzzy_match;
763 $details .= "Differences in `diff -u' format:\n";
764 $details .= join ('', @diff);
765 $details .= "(This is considered a `fuzzy match'.)\n"
766 if !$not_fuzzy_match;
769 # Failed to match. Report failure.
772 "This test passed, but with extra, unexpected output.\n"
773 . "Please inspect your code to make sure that it does not\n"
774 . "produce output other than as specified in the project\n"
779 "This test failed because its output did not match any\n"
780 . "of the acceptable form(s).\n\n"
784 $details{$test} = $details;
785 die "Output differs from expected. Details at end of file.\n"
789 # Reads and returns the contents of the specified file.
790 # In an array context, returns the file's contents as an array of
791 # lines, omitting new-lines.
792 # In a scalar context, returns the file's contents as a single string.
795 open (OUTPUT, $file) or die "$file: open: $!\n";
796 my (@lines) = <OUTPUT>;
799 return wantarray ? @lines : join ('', map ("$_\n", @lines));
802 # Returns true if the two specified files are byte-for-byte identical,
807 open (A, "<$a") or die "$a: open: $!\n";
808 open (B, "<$b") or die "$b: open: $!\n";
814 sysread (A, $sa, 1024);
815 sysread (B, $sb, 1024);
816 $equal = 0, last if $sa ne $sb;
817 $equal = 1, last if $sa eq '';
825 # Returns true if the specified file is byte-for-byte identical with
826 # the specified string.
828 my ($file, $expected) = @_;
829 open (FILE, "<$file") or die "$file: open: $!\n";
831 sysread (FILE, $actual, -s FILE);
832 my ($equal) = $actual eq $expected;
838 for my $test (@TESTS) {
839 return 1 if !defined ($result{$test}) || $result{$test} ne 'ok';