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 (which is empty).
142 open (CONSTANTS, ">pintos/src/constants.h")
143 or die "constants.h: create: $!\n";
147 # Returns the name of the tarball to extract.
150 = grep (/^[a-z0-9]+\.[A-Za-z]+\.\d+\.\d+\.\d+\.\d+.\d+\.tar\.gz$/,
152 die "no pintos dir, no files matching username.MMM.DD.YY.hh.mm.ss.tar.gz\n"
153 if scalar (@tarballs) == 0;
156 # Sort tarballs in order by time.
157 @tarballs = sort { ext_mdyHMS ($a) cmp ext_mdyHMS ($b) } @tarballs;
159 print "Multiple tarballs:\n";
160 print "\t$_ submitted ", ext_mdyHMS ($_), "\n" foreach @tarballs;
161 print "Choosing $tarballs[$#tarballs]\n";
163 return $tarballs[$#tarballs];
166 # Extract the date within a tarball name into a string that compares
167 # lexicographically in chronological order.
170 my ($ms, $d, $y, $H, $M, $S) =
171 $s =~ /.([A-Za-z]+)\.(\d+)\.(\d+)\.(\d+)\.(\d+).(\d+)\.tar\.gz$/
173 my ($m) = index ("janfebmaraprmayjunjulaugsepoctnovdec", lc $ms) / 3
175 return sprintf "%02d-%02d-%02d %02d:%02d:%02d", $y, $m, $d, $H, $M, $S;
181 print "Compiling...\n";
182 xsystem ("cd pintos/src/$hw && make", LOG => "make") eq 'ok'
183 or return "Build error";
186 # Run and grade the tests.
187 sub run_and_grade_tests {
190 my ($result) = get_test_result ();
193 my ($grade) = grade_test ($test);
196 my ($msg) = $result eq 'ok' ? $grade : "$result - $grade";
197 $msg .= " - with warnings"
198 if $grade eq 'ok' && defined $details{$test};
201 $result{$test} = $grade;
205 # Write test grades to tests.out.
207 my (@summary) = snarf ("$GRADES_DIR/tests.txt");
213 for (my ($i) = 0; $i <= $#summary; $i++) {
214 local ($_) = $summary[$i];
215 if (my ($loss, $test) = /^ -(\d+) ([-a-zA-Z0-9]+):/) {
216 my ($result) = $result{$test} || "Not tested.";
218 if ($result eq 'ok') {
219 if (!defined $details{$test}) {
220 # Test successful and no warnings.
221 splice (@summary, $i, 1);
224 # Test successful with warnings.
227 splice (@summary, $i + 1, 0,
228 " Test passed with warnings. "
229 . "Details at end of file.");
235 splice (@summary, $i + 1, 0,
236 map (" $_", split ("\n", $result)));
238 } elsif (my ($ptotal) = /^Score: \/(\d+)$/) {
240 $summary[$i] = "Score: " . ($ptotal - $ploss) . "/$ptotal";
241 splice (@summary, $i, 0, " All tests passed.")
242 if $ploss == 0 && !$warnings;
248 my ($ts) = "(" . ($total - $tloss) . "/" . $total . ")";
249 $summary[0] =~ s/\[\[total\]\]/$ts/;
251 open (SUMMARY, ">tests.out");
252 print SUMMARY map ("$_\n", @summary);
256 # Write failure and warning details to details.out.
258 open (DETAILS, ">details.out");
261 next if $result{$test} eq 'ok' && !defined $details{$test};
263 my ($details) = $details{$test};
264 next if !defined ($details) && ! -e "output/$test/run.out";
267 if ($result{$test} ne 'ok') {
268 $banner = "$test failure details";
270 $banner = "$test warnings";
273 print DETAILS "\n" if $n++;
274 print DETAILS "--- $banner ", '-' x (50 - length ($banner));
275 print DETAILS "\n\n";
277 if (!defined $details) {
278 my (@output) = snarf ("output/$test/run.out");
280 # Print only the first in a series of recursing panics.
282 for my $i (0...$#output) {
283 local ($_) = $output[$i];
284 if (/PANIC/ && $panic++ > 0) {
285 @output = @output[0...$i];
287 "[...details of recursive panic(s) omitted...]");
291 $details = "Output:\n\n" . join ('', map ("$_\n", @output));
293 print DETAILS $details;
295 print DETAILS "\n", "-" x 10, "\n\n$extra{$test}"
296 if defined $extra{$test};
302 my ($command, %options) = @_;
303 print "$command\n" if $verbose || $options{VERBOSE};
305 my ($log) = $options{LOG};
309 local $SIG{ALRM} = sub { die "alarm\n" };
310 alarm $options{TIMEOUT} if defined $options{TIMEOUT};
312 die "fork: $!\n" if !defined $pid;
315 open (STDOUT, ">output/$log.out");
316 open (STDERR, ">output/$log.err");
318 chdir $options{CHDIR} or die "$options{CHDIR}: chdir: $!\n"
319 if defined ($options{CHDIR});
320 if (!defined ($options{EXEC})) {
323 exec (@{$options{EXEC}});
334 die unless $@ eq "alarm\n"; # propagate unexpected errors
336 for ($i = 0; $i < 10; $i++) {
337 kill ('SIGTERM', $pid);
339 my ($retval) = waitpid ($pid, WNOHANG);
340 last if $retval == $pid || $retval == -1;
341 print "Timed out - Waiting for $pid to die" if $i == 0;
347 if (WIFSIGNALED ($status)) {
348 my ($signal) = WTERMSIG ($status);
349 die "Interrupted\n" if $signal == SIGINT;
350 print "Child terminated with signal $signal\n";
353 $result = $status == 0 ? "ok" : "error";
356 if ($result eq 'error' && defined $options{DIE}) {
357 my ($msg) = $options{DIE};
358 if (defined ($log)) {
360 $msg .= "; see output/$log.err and output/$log.out for details\n";
363 } elsif ($result ne 'error' && defined ($log)) {
364 unlink ("output/$log.err");
370 sub get_test_result {
371 my ($cache_file) = "output/$test/run.result";
372 # Reuse older results if any.
373 if (open (RESULT, "<$cache_file")) {
381 # If there's residue from an earlier test, move it to .old.
382 # If there's already a .old, delete it.
383 xsystem ("rm -rf output/$test.old", VERBOSE => 1) if -d "output/$test.old";
384 rename "output/$test", "output/$test.old" or die "rename: $!\n"
385 if -d "output/$test";
387 # Make output directory.
388 mkdir "output/$test";
391 my ($result) = run_test ($test);
393 # Delete any disks in the output directory because they take up
395 unlink (glob ("output/$test/*.dsk"));
397 # Save the results for later.
398 open (DONE, ">$cache_file") or die "$cache_file: create: $!\n";
399 print DONE "$result\n";
406 my ($cmd_line, %args) = @_;
407 unshift (@$cmd_line, 'pintos');
408 my ($retval) = xsystem (join (' ', @$cmd_line), %args, EXEC => $cmd_line);
409 return 'ok' if $retval eq 'ok';
410 if ($retval eq 'timeout') {
411 my ($msg) = "Timed out after $args{TIMEOUT} seconds";
412 my ($load_avg) = `uptime` =~ /(load average:.*)$/i;
413 $msg .= " - $load_avg" if defined $load_avg;
416 return 'Error running Bochs' if $retval eq 'error';
423 my ($outfile) = "output/$test/run.out";
425 if (-s "output/$test/make.err") {
427 $details{$test} = snarf ("output/$test/make.err");
428 return "make failed. Error messages at end of file.";
430 return "preparation for test failed";
432 my (@output) = snarf ($outfile);
434 # If there's a function "grade_$test", use it to evaluate the output.
435 # If there's a file "$GRADES_DIR/$test.exp", compare its contents
436 # against the output.
437 # (If both exist, prefer the function.)
439 # If the test was successful, it returns normally.
440 # If it failed, it invokes `die' with an error message terminated
441 # by a new-line. The message will be given as an explanation in
442 # the output file tests.out.
443 # (Internal errors will invoke `die' without a terminating
444 # new-line, in which case we detect it and propagate the `die'
446 my ($grade_func) = "grade_$test";
447 $grade_func =~ s/-/_/g;
448 if (-e "$GRADES_DIR/$test.exp" && !defined (&$grade_func)) {
450 verify_common (@output);
451 compare_output ("$GRADES_DIR/$test.exp", @output);
454 eval "$grade_func (\@output)";
457 die $@ if $@ =~ /at \S+ line \d+$/;
464 # Combines grade.txt, tests.out, review.txt, and details.out,
465 # producing grade.out.
466 sub assemble_final_grade {
467 open (OUT, ">grade.out") or die "grade.out: create: $!\n";
469 open (GRADE, "<grade.txt") or die "grade.txt: open: $!\n";
476 my (@tests) = snarf ("tests.out");
477 my ($p_got, $p_pos) = $tests[0] =~ m%\((\d+)/(\d+)\)% or die;
479 my (@review) = snarf ("review.txt");
480 my ($part_lost) = (0, 0);
481 for (my ($i) = $#review; $i >= 0; $i--) {
482 local ($_) = $review[$i];
483 if (my ($loss) = /^\s*([-+]\d+)/) {
485 } elsif (my ($out_of) = m%\[\[/(\d+)\]\]%) {
486 my ($got) = $out_of + $part_lost;
487 $got = 0 if $got < 0;
488 $review[$i] =~ s%\[\[/\d+\]\]%($got/$out_of)% or die;
495 die "Lost points outside a section\n" if $part_lost;
497 for (my ($i) = 1; $i <= $#review; $i++) {
498 if ($review[$i] =~ /^-{3,}\s*$/ && $review[$i - 1] !~ /^\s*$/) {
499 $review[$i] = '-' x (length ($review[$i - 1]));
503 print OUT "\nOVERALL SCORE\n";
504 print OUT "-------------\n";
505 print OUT "$p_got points out of $p_pos total\n\n";
507 print OUT map ("$_\n", @tests), "\n";
508 print OUT map ("$_\n", @review), "\n";
510 print OUT "DETAILS\n";
511 print OUT "-------\n\n";
512 print OUT map ("$_\n", snarf ("details.out"));
515 # Clean up our generated files.
517 # Verify that we're roughly in the correct directory
518 # before we go blasting away files.
521 # Blow away everything.
522 xsystem ("rm -rf output pintos", VERBOSE => 1);
523 xsystem ("rm -f details.out tests.out", VERBOSE => 1);
526 # Provided a test's output as an array, verifies that it, in general,
527 # looks sensible; that is, that there are no PANIC or FAIL messages,
528 # that Pintos started up and shut down normally, and so on.
529 # Die if something odd found.
533 die "No output at all\n" if @output == 0;
535 look_for_panic (@output);
536 look_for_fail (@output);
537 look_for_triple_fault (@output);
539 die "Didn't start up properly: no \"Pintos booting\" startup message\n"
540 if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
541 die "Didn't start up properly: no \"Boot complete\" startup message\n"
542 if !grep (/Boot complete/, @output);
543 die "Didn't shut down properly: no \"Timer: # ticks\" shutdown message\n"
544 if !grep (/Timer: \d+ ticks/, @output);
545 die "Didn't shut down properly: no \"Powering off\" shutdown message\n"
546 if !grep (/Powering off/, @output);
552 my ($panic) = grep (/PANIC/, @output);
553 return unless defined $panic;
555 my ($details) = "Kernel panic:\n $panic\n";
557 my (@stack_line) = grep (/Call stack:/, @output);
558 if (@stack_line != 0) {
559 $details .= " $stack_line[0]\n\n";
560 $details .= "Translation of backtrace:\n";
561 my (@addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
565 =~ /i.86|pentium.*|[pk][56]|nexgen|viac3|6x86|athlon.*/) {
568 $A2L = "i386-elf-addr2line";
571 if ($hw eq 'threads') {
572 $kernel_o = "output/$test/kernel.o";
574 $kernel_o = "pintos/src/$hw/build/kernel.o";
576 open (A2L, "$A2L -fe $kernel_o @addrs|");
578 my ($function, $line);
579 last unless defined ($function = <A2L>);
583 $details .= " $function ($line)\n";
587 if ($panic =~ /sec_no < d->capacity/) {
589 \nThis assertion commonly fails when accessing a file via an inode that
590 has been closed and freed. Freeing an inode clears all its sector
591 indexes to 0xcccccccc, which is not a valid sector number for disks
592 smaller than about 1.6 TB.
596 $extra{$test} = $details;
597 die "Kernel panic. Details at end of file.\n";
603 my ($failure) = grep (/FAIL/, @output);
604 return unless defined $failure;
606 # Eliminate uninteresting header and trailer info if possible.
607 # The `eval' catches the `die' from get_core_output() in the "not
610 my (@core) = get_core_output (@output);
611 $details{$test} = "Program output:\n\n" . join ('', map ("$_\n", @core));
614 # Most output lines are prefixed by (test-name). Eliminate this
615 # from our `die' message for brevity.
616 $failure =~ s/^\([^\)]+\)\s+//;
617 die "$failure. Details at end of file.\n";
620 sub look_for_triple_fault {
623 return unless grep (/Pintos booting/, @output) > 1;
625 my ($details) = <<EOF;
626 Pintos spontaneously rebooted during this test. This is most often
627 due to unhandled page faults. Output from initial boot through the
628 first reboot is shown below:
636 last if /Pintos booting/ && ++$i > 1;
638 $details{$test} = $details;
639 die "Triple-fault caused spontaneous reboot(s). "
640 . "Details at end of file.\n";
643 # Get @output without header or trailer.
644 # Die if not possible.
645 sub get_core_output {
649 for ($first = 0; $first <= $#output; $first++) {
650 my ($line) = $output[$first];
652 if ($hw ne 'threads' && $line =~ /^Executing '$test.*':$/)
654 && grep (/^Boot complete.$/, @output[0...$first - 1])
655 && $line =~ /^\s*$/);
659 for ($last = $#output; $last >= 0; $last--) {
660 $last--, last if $output[$last] =~ /^Timer: \d+ ticks$/;
663 if ($last < $first) {
664 my ($no_first) = $first > $#output;
665 my ($no_last) = $last < $#output;
666 die "Couldn't locate output.\n";
669 return @output[$first ... $last];
672 sub canonicalize_exit_codes {
675 # Exit codes are supposed to be printed in the form "process: exit(code)"
676 # but people get unfortunately creative with it.
677 for my $i (0...$#output) {
678 local ($_) = $output[$i];
680 my ($process, $code);
681 if ((($process, $code) = /^([-a-z0-9 ]+):.*[ \(](-?\d+)\b\)?$/)
682 || (($process, $code) = /^([-a-z0-9 ]+) exit\((-?\d+)\)$/)
683 || (($process, $code)
684 = /^([-a-z0-9 ]+) \(.*\): exit\((-?\d+)\)$/)
685 || (($process, $code) = /^([-a-z0-9 ]+):\( (-?\d+) \) $/)
686 || (($code, $process) = /^shell: exit\((-?\d+)\) \| ([-a-z0-9]+)/))
688 # We additionally truncate to 15 character and strip all
689 # but the first word.
690 $process = substr ($process, 0, 15);
691 $process =~ s/\s.*//;
692 $output[$i] = "$process: exit($code)\n";
699 sub strip_exit_codes {
700 return grep (!/^[-a-z0-9]+: exit\(-?\d+\)/, canonicalize_exit_codes (@_));
704 my ($exp, @actual) = @_;
706 # Canonicalize output for comparison.
707 @actual = get_core_output (map ("$_\n", @actual));
708 if ($hw eq 'userprog') {
709 @actual = canonicalize_exit_codes (@actual);
710 } elsif ($hw eq 'vm' || $hw eq 'filesys') {
711 @actual = strip_exit_codes (@actual);
714 # There *was* some output, right?
715 die "Program produced no output.\n" if !@actual;
717 # Read expected output.
718 my (@exp) = map ("$_\n", snarf ($exp));
720 # Pessimistically, start preparation of detailed failure message.
722 $details .= "$test actual output:\n";
723 $details .= join ('', map (" $_", @actual));
725 # Set true when we find expected output that matches our actual
726 # output except for some extra actual output (that doesn't seem to
727 # be an error message etc.).
728 my ($fuzzy_match) = 0;
730 # Compare actual output against each allowed output.
732 # Grab one set of allowed output from @exp into @expected.
735 my ($s) = shift (@exp);
736 last if $s eq "--OR--\n";
737 push (@expected, $s);
740 $details .= "\n$test acceptable output:\n";
741 $details .= join ('', map (" $_", @expected));
743 # Check whether actual and expected match.
744 # If it's a perfect match, return.
745 if ($#actual == $#expected) {
747 for (my ($i) = 0; $i <= $#expected; $i++) {
748 $eq = 0 if $actual[$i] ne $expected[$i];
753 # They differ. Output a diff.
755 my ($d) = Algorithm::Diff->new (\@expected, \@actual);
756 my ($not_fuzzy_match) = 0;
757 while ($d->Next ()) {
758 my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
760 push (@diff, map (" $_", $d->Items (1)));
762 push (@diff, map ("- $_", $d->Items (1))) if $d->Items (1);
763 push (@diff, map ("+ $_", $d->Items (2))) if $d->Items (2);
765 || grep (/\($test\)|exit\(-?\d+\)|dying due to|Page fault/,
767 $not_fuzzy_match = 1;
772 # If we didn't find anything that means it's not,
773 # it's a fuzzy match.
774 $fuzzy_match = 1 if !$not_fuzzy_match;
776 $details .= "Differences in `diff -u' format:\n";
777 $details .= join ('', @diff);
778 $details .= "(This is considered a `fuzzy match'.)\n"
779 if !$not_fuzzy_match;
782 # Failed to match. Report failure.
785 "This test passed, but with extra, unexpected output.\n"
786 . "Please inspect your code to make sure that it does not\n"
787 . "produce output other than as specified in the project\n"
792 "This test failed because its output did not match any\n"
793 . "of the acceptable form(s).\n\n"
797 $details{$test} = $details;
798 die "Output differs from expected. Details at end of file.\n"
802 # Reads and returns the contents of the specified file.
803 # In an array context, returns the file's contents as an array of
804 # lines, omitting new-lines.
805 # In a scalar context, returns the file's contents as a single string.
808 open (OUTPUT, $file) or die "$file: open: $!\n";
809 my (@lines) = <OUTPUT>;
812 return wantarray ? @lines : join ('', map ("$_\n", @lines));
815 # Returns true if the two specified files are byte-for-byte identical,
820 open (A, "<$a") or die "$a: open: $!\n";
821 open (B, "<$b") or die "$b: open: $!\n";
827 sysread (A, $sa, 1024);
828 sysread (B, $sb, 1024);
829 $equal = 0, last if $sa ne $sb;
830 $equal = 1, last if $sa eq '';
838 # Returns true if the specified file is byte-for-byte identical with
839 # the specified string.
841 my ($file, $expected) = @_;
842 open (FILE, "<$file") or die "$file: open: $!\n";
844 sysread (FILE, $actual, -s FILE);
845 my ($equal) = $actual eq $expected;
851 for my $test (@TESTS) {
852 return 1 if !defined ($result{$test}) || $result{$test} ne 'ok';