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 # and applies any patches providing in the grading directory.
101 sub extract_sources {
102 # Make sure the output dir exists.
103 -d ("output") || mkdir ("output") or die "output: mkdir: $!\n";
105 # Nothing else to do if we already have a source tree.
106 return if -d "pintos";
108 my ($tarball) = choose_tarball ();
111 print "Creating pintos/src...\n";
112 mkdir "pintos" or die "pintos: mkdir: $!\n";
113 mkdir "pintos/src" or die "pintos/src: mkdir: $!\n";
115 print "Extracting $tarball into pintos/src...\n";
116 xsystem ("cd pintos/src && tar xzf ../../$tarball",
117 DIE => "extraction failed\n");
119 # Run custom script for this submission, if provided.
121 print "Running fixme.sh...\n";
122 xsystem ("sh -e fixme.sh", DIE => "fix script failed\n");
124 print "No fixme.sh, assuming no custom changes needed.\n";
127 # Apply patches from grading directory.
128 # Patches are applied in lexicographic order, so they should
129 # probably be named 00debug.patch, 01bitmap.patch, etc.
130 # Filenames in patches should be in the format pintos/src/...
131 print "Patching...\n";
132 for my $patch (glob ("$GRADES_DIR/patches/*.patch")) {
134 ($stem = $patch) =~ s%^$GRADES_DIR/patches/%% or die;
135 print "Applying $patch...\n";
136 xsystem ("patch -fs -p0 < $patch",
137 LOG => $stem, DIE => "applying patch $stem failed\n");
141 # Returns the name of the tarball to extract.
144 = grep (/^[a-z0-9]+\.[A-Za-z]+\.\d+\.\d+\.\d+\.\d+.\d+\.tar\.gz$/,
146 die "no pintos dir, no files matching username.MMM.DD.YY.hh.mm.ss.tar.gz\n"
147 if scalar (@tarballs) == 0;
150 # Sort tarballs in order by time.
151 @tarballs = sort { ext_mdyHMS ($a) cmp ext_mdyHMS ($b) } @tarballs;
153 print "Multiple tarballs:\n";
154 print "\t$_ submitted ", ext_mdyHMS ($_), "\n" foreach @tarballs;
155 print "Choosing $tarballs[$#tarballs]\n";
157 return $tarballs[$#tarballs];
160 # Extract the date within a tarball name into a string that compares
161 # lexicographically in chronological order.
164 my ($ms, $d, $y, $H, $M, $S) =
165 $s =~ /.([A-Za-z]+)\.(\d+)\.(\d+)\.(\d+)\.(\d+).(\d+)\.tar\.gz$/
167 my ($m) = index ("janfebmaraprmayjunjulaugsepoctnovdec", lc $ms) / 3
169 return sprintf "%02d-%02d-%02d %02d:%02d:%02d", $y, $m, $d, $H, $M, $S;
175 print "Compiling...\n";
176 xsystem ("cd pintos/src/$hw && make", LOG => "make") eq 'ok'
177 or return "Build error";
180 # Run and grade the tests.
181 sub run_and_grade_tests {
184 my ($result) = get_test_result ();
187 my ($grade) = grade_test ($test);
190 my ($msg) = $result eq 'ok' ? $grade : "$result - $grade";
191 $msg .= " - with warnings"
192 if $grade eq 'ok' && defined $details{$test};
195 $result{$test} = $grade;
199 # Write test grades to tests.out.
201 my (@summary) = snarf ("$GRADES_DIR/tests.txt");
207 for (my ($i) = 0; $i <= $#summary; $i++) {
208 local ($_) = $summary[$i];
209 if (my ($loss, $test) = /^ -(\d+) ([-a-zA-Z0-9]+):/) {
210 my ($result) = $result{$test} || "Not tested.";
212 if ($result eq 'ok') {
213 if (!defined $details{$test}) {
214 # Test successful and no warnings.
215 splice (@summary, $i, 1);
218 # Test successful with warnings.
221 splice (@summary, $i + 1, 0,
222 " Test passed with warnings. "
223 . "Details at end of file.");
229 splice (@summary, $i + 1, 0,
230 map (" $_", split ("\n", $result)));
232 } elsif (my ($ptotal) = /^Score: \/(\d+)$/) {
234 $summary[$i] = "Score: " . ($ptotal - $ploss) . "/$ptotal";
235 splice (@summary, $i, 0, " All tests passed.")
236 if $ploss == 0 && !$warnings;
242 my ($ts) = "(" . ($total - $tloss) . "/" . $total . ")";
243 $summary[0] =~ s/\[\[total\]\]/$ts/;
245 open (SUMMARY, ">tests.out");
246 print SUMMARY map ("$_\n", @summary);
250 # Write failure and warning details to details.out.
252 open (DETAILS, ">details.out");
255 next if $result{$test} eq 'ok' && !defined $details{$test};
257 my ($details) = $details{$test};
258 next if !defined ($details) && ! -e "output/$test/run.out";
261 if ($result{$test} ne 'ok') {
262 $banner = "$test failure details";
264 $banner = "$test warnings";
267 print DETAILS "\n" if $n++;
268 print DETAILS "--- $banner ", '-' x (50 - length ($banner));
269 print DETAILS "\n\n";
271 if (!defined $details) {
272 my (@output) = snarf ("output/$test/run.out");
274 # Print only the first in a series of recursing panics.
276 for my $i (0...$#output) {
277 local ($_) = $output[$i];
278 if (/PANIC/ && $panic++ > 0) {
279 @output = @output[0...$i];
281 "[...details of recursive panic(s) omitted...]");
285 $details = "Output:\n\n" . join ('', map ("$_\n", @output));
287 print DETAILS $details;
289 print DETAILS "\n", "-" x 10, "\n\n$extra{$test}"
290 if defined $extra{$test};
296 my ($command, %options) = @_;
297 print "$command\n" if $verbose || $options{VERBOSE};
299 my ($log) = $options{LOG};
303 local $SIG{ALRM} = sub { die "alarm\n" };
304 alarm $options{TIMEOUT} if defined $options{TIMEOUT};
306 die "fork: $!\n" if !defined $pid;
309 open (STDOUT, ">output/$log.out");
310 open (STDERR, ">output/$log.err");
312 chdir $options{CHDIR} or die "$options{CHDIR}: chdir: $!\n"
313 if defined ($options{CHDIR});
314 if (!defined ($options{EXEC})) {
317 exec (@{$options{EXEC}});
328 die unless $@ eq "alarm\n"; # propagate unexpected errors
330 for ($i = 0; $i < 10; $i++) {
331 kill ('SIGTERM', $pid);
333 my ($retval) = waitpid ($pid, WNOHANG);
334 last if $retval == $pid || $retval == -1;
335 print "Timed out - Waiting for $pid to die" if $i == 0;
341 if (WIFSIGNALED ($status)) {
342 my ($signal) = WTERMSIG ($status);
343 die "Interrupted\n" if $signal == SIGINT;
344 print "Child terminated with signal $signal\n";
347 $result = $status == 0 ? "ok" : "error";
350 if ($result eq 'error' && defined $options{DIE}) {
351 my ($msg) = $options{DIE};
352 if (defined ($log)) {
354 $msg .= "; see output/$log.err and output/$log.out for details\n";
357 } elsif ($result ne 'error' && defined ($log)) {
358 unlink ("output/$log.err");
364 sub get_test_result {
365 my ($cache_file) = "output/$test/run.result";
366 # Reuse older results if any.
367 if (open (RESULT, "<$cache_file")) {
375 # If there's residue from an earlier test, move it to .old.
376 # If there's already a .old, delete it.
377 xsystem ("rm -rf output/$test.old", VERBOSE => 1) if -d "output/$test.old";
378 rename "output/$test", "output/$test.old" or die "rename: $!\n"
379 if -d "output/$test";
381 # Make output directory.
382 mkdir "output/$test";
385 my ($result) = run_test ($test);
387 # Delete any disks in the output directory because they take up
389 unlink (glob ("output/$test/*.dsk"));
391 # Save the results for later.
392 open (DONE, ">$cache_file") or die "$cache_file: create: $!\n";
393 print DONE "$result\n";
400 my ($cmd_line, %args) = @_;
401 unshift (@$cmd_line, 'pintos');
402 my ($retval) = xsystem (join (' ', @$cmd_line), %args, EXEC => $cmd_line);
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";
419 if (-s "output/$test/make.err") {
421 $details{$test} = snarf ("output/$test/make.err");
422 return "make failed. Error messages at end of file.";
424 return "preparation for test failed";
426 my (@output) = snarf ($outfile);
428 # If there's a function "grade_$test", use it to evaluate the output.
429 # If there's a file "$GRADES_DIR/$test.exp", compare its contents
430 # against the output.
431 # (If both exist, prefer the function.)
433 # If the test was successful, it returns normally.
434 # If it failed, it invokes `die' with an error message terminated
435 # by a new-line. The message will be given as an explanation in
436 # the output file tests.out.
437 # (Internal errors will invoke `die' without a terminating
438 # new-line, in which case we detect it and propagate the `die'
440 my ($grade_func) = "grade_$test";
441 $grade_func =~ s/-/_/g;
442 if (-e "$GRADES_DIR/$test.exp" && !defined (&$grade_func)) {
444 verify_common (@output);
445 compare_output ("$GRADES_DIR/$test.exp", @output);
448 eval "$grade_func (\@output)";
451 die $@ if $@ =~ /at \S+ line \d+$/;
458 # Combines grade.txt, tests.out, review.txt, and details.out,
459 # producing grade.out.
460 sub assemble_final_grade {
461 open (OUT, ">grade.out") or die "grade.out: create: $!\n";
463 open (GRADE, "<grade.txt") or die "grade.txt: open: $!\n";
470 my (@tests) = snarf ("tests.out");
471 my ($p_got, $p_pos) = $tests[0] =~ m%\((\d+)/(\d+)\)% or die;
473 my (@review) = snarf ("review.txt");
474 my ($part_lost) = (0, 0);
475 for (my ($i) = $#review; $i >= 0; $i--) {
476 local ($_) = $review[$i];
477 if (my ($loss) = /^\s*([-+]\d+)/) {
479 } elsif (my ($out_of) = m%\[\[/(\d+)\]\]%) {
480 my ($got) = $out_of + $part_lost;
481 $got = 0 if $got < 0;
482 $review[$i] =~ s%\[\[/\d+\]\]%($got/$out_of)% or die;
489 die "Lost points outside a section\n" if $part_lost;
491 for (my ($i) = 1; $i <= $#review; $i++) {
492 if ($review[$i] =~ /^-{3,}\s*$/ && $review[$i - 1] !~ /^\s*$/) {
493 $review[$i] = '-' x (length ($review[$i - 1]));
497 print OUT "\nOVERALL SCORE\n";
498 print OUT "-------------\n";
499 print OUT "$p_got points out of $p_pos total\n\n";
501 print OUT map ("$_\n", @tests), "\n";
502 print OUT map ("$_\n", @review), "\n";
504 print OUT "DETAILS\n";
505 print OUT "-------\n\n";
506 print OUT map ("$_\n", snarf ("details.out"));
509 # Clean up our generated files.
511 # Verify that we're roughly in the correct directory
512 # before we go blasting away files.
515 # Blow away everything.
516 xsystem ("rm -rf output pintos", VERBOSE => 1);
517 xsystem ("rm -f details.out tests.out", VERBOSE => 1);
520 # Provided a test's output as an array, verifies that it, in general,
521 # looks sensible; that is, that there are no PANIC or FAIL messages,
522 # that Pintos started up and shut down normally, and so on.
523 # Die if something odd found.
527 die "No output at all\n" if @output == 0;
529 look_for_panic (@output);
530 look_for_fail (@output);
531 look_for_triple_fault (@output);
533 die "Didn't start up properly: no \"Pintos booting\" startup message\n"
534 if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
535 die "Didn't start up properly: no \"Boot complete\" startup message\n"
536 if !grep (/Boot complete/, @output);
537 die "Didn't shut down properly: no \"Timer: # ticks\" shutdown message\n"
538 if !grep (/Timer: \d+ ticks/, @output);
539 die "Didn't shut down properly: no \"Powering off\" shutdown message\n"
540 if !grep (/Powering off/, @output);
546 my ($panic) = grep (/PANIC/, @output);
547 return unless defined $panic;
549 my ($details) = "Kernel panic:\n $panic\n";
551 my (@stack_line) = grep (/Call stack:/, @output);
552 if (@stack_line != 0) {
553 $details .= " $stack_line[0]\n\n";
554 $details .= "Translation of backtrace:\n";
555 my (@addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
559 =~ /i.86|pentium.*|[pk][56]|nexgen|viac3|6x86|athlon.*/) {
562 $A2L = "i386-elf-addr2line";
565 if ($hw eq 'threads') {
566 $kernel_o = "output/$test/kernel.o";
568 $kernel_o = "pintos/src/$hw/build/kernel.o";
570 open (A2L, "$A2L -fe $kernel_o @addrs|");
572 my ($function, $line);
573 last unless defined ($function = <A2L>);
577 $details .= " $function ($line)\n";
581 if ($panic =~ /sec_no < d->capacity/) {
583 \nThis assertion commonly fails when accessing a file via an inode that
584 has been closed and freed. Freeing an inode clears all its sector
585 indexes to 0xcccccccc, which is not a valid sector number for disks
586 smaller than about 1.6 TB.
590 $extra{$test} = $details;
591 die "Kernel panic. Details at end of file.\n";
597 my ($failure) = grep (/FAIL/, @output);
598 return unless defined $failure;
600 # Eliminate uninteresting header and trailer info if possible.
601 # The `eval' catches the `die' from get_core_output() in the "not
604 my (@core) = get_core_output (@output);
605 $details{$test} = "Program output:\n\n" . join ('', map ("$_\n", @core));
608 # Most output lines are prefixed by (test-name). Eliminate this
609 # from our `die' message for brevity.
610 $failure =~ s/^\([^\)]+\)\s+//;
611 die "$failure. Details at end of file.\n";
614 sub look_for_triple_fault {
617 return unless grep (/Pintos booting/, @output) > 1;
619 my ($details) = <<EOF;
620 Pintos spontaneously rebooted during this test. This is most often
621 due to unhandled page faults. Output from initial boot through the
622 first reboot is shown below:
630 last if /Pintos booting/ && ++$i > 1;
632 $details{$test} = $details;
633 die "Triple-fault caused spontaneous reboot(s). "
634 . "Details at end of file.\n";
637 # Get @output without header or trailer.
638 # Die if not possible.
639 sub get_core_output {
643 for ($first = 0; $first <= $#output; $first++) {
644 my ($line) = $output[$first];
646 if ($hw ne 'threads' && $line =~ /^Executing '$test.*':$/)
648 && grep (/^Boot complete.$/, @output[0...$first - 1])
649 && $line =~ /^\s*$/);
653 for ($last = $#output; $last >= 0; $last--) {
654 $last--, last if $output[$last] =~ /^Timer: \d+ ticks$/;
657 if ($last < $first) {
658 my ($no_first) = $first > $#output;
659 my ($no_last) = $last < $#output;
660 die "Couldn't locate output.\n";
663 return @output[$first ... $last];
666 sub canonicalize_exit_codes {
669 # Exit codes are supposed to be printed in the form "process: exit(code)"
670 # but people get unfortunately creative with it.
671 for my $i (0...$#output) {
672 local ($_) = $output[$i];
674 my ($process, $code);
675 if ((($process, $code) = /^([-a-z0-9 ]+):.*[ \(](-?\d+)\b\)?$/)
676 || (($process, $code) = /^([-a-z0-9 ]+) exit\((-?\d+)\)$/)
677 || (($process, $code)
678 = /^([-a-z0-9 ]+) \(.*\): exit\((-?\d+)\)$/)
679 || (($process, $code) = /^([-a-z0-9 ]+):\( (-?\d+) \) $/)
680 || (($code, $process) = /^shell: exit\((-?\d+)\) \| ([-a-z0-9]+)/))
682 # We additionally truncate to 15 character and strip all
683 # but the first word.
684 $process = substr ($process, 0, 15);
685 $process =~ s/\s.*//;
686 $output[$i] = "$process: exit($code)\n";
693 sub strip_exit_codes {
694 return grep (!/^[-a-z0-9]+: exit\(-?\d+\)/, canonicalize_exit_codes (@_));
698 my ($exp, @actual) = @_;
700 # Canonicalize output for comparison.
701 @actual = get_core_output (map ("$_\n", @actual));
702 if ($hw eq 'userprog') {
703 @actual = canonicalize_exit_codes (@actual);
704 } elsif ($hw eq 'vm' || $hw eq 'filesys') {
705 @actual = strip_exit_codes (@actual);
708 # There *was* some output, right?
709 die "Program produced no output.\n" if !@actual;
711 # Read expected output.
712 my (@exp) = map ("$_\n", snarf ($exp));
714 # Pessimistically, start preparation of detailed failure message.
716 $details .= "$test actual output:\n";
717 $details .= join ('', map (" $_", @actual));
719 # Set true when we find expected output that matches our actual
720 # output except for some extra actual output (that doesn't seem to
721 # be an error message etc.).
722 my ($fuzzy_match) = 0;
724 # Compare actual output against each allowed output.
726 # Grab one set of allowed output from @exp into @expected.
729 my ($s) = shift (@exp);
730 last if $s eq "--OR--\n";
731 push (@expected, $s);
734 $details .= "\n$test acceptable output:\n";
735 $details .= join ('', map (" $_", @expected));
737 # Check whether actual and expected match.
738 # If it's a perfect match, return.
739 if ($#actual == $#expected) {
741 for (my ($i) = 0; $i <= $#expected; $i++) {
742 $eq = 0 if $actual[$i] ne $expected[$i];
747 # They differ. Output a diff.
749 my ($d) = Algorithm::Diff->new (\@expected, \@actual);
750 my ($not_fuzzy_match) = 0;
751 while ($d->Next ()) {
752 my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
754 push (@diff, map (" $_", $d->Items (1)));
756 push (@diff, map ("- $_", $d->Items (1))) if $d->Items (1);
757 push (@diff, map ("+ $_", $d->Items (2))) if $d->Items (2);
759 || grep (/\($test\)|exit\(-?\d+\)|dying due to|Page fault/,
761 $not_fuzzy_match = 1;
766 # If we didn't find anything that means it's not,
767 # it's a fuzzy match.
768 $fuzzy_match = 1 if !$not_fuzzy_match;
770 $details .= "Differences in `diff -u' format:\n";
771 $details .= join ('', @diff);
772 $details .= "(This is considered a `fuzzy match'.)\n"
773 if !$not_fuzzy_match;
776 # Failed to match. Report failure.
779 "This test passed, but with extra, unexpected output.\n"
780 . "Please inspect your code to make sure that it does not\n"
781 . "produce output other than as specified in the project\n"
786 "This test failed because its output did not match any\n"
787 . "of the acceptable form(s).\n\n"
791 $details{$test} = $details;
792 die "Output differs from expected. Details at end of file.\n"
796 # Reads and returns the contents of the specified file.
797 # In an array context, returns the file's contents as an array of
798 # lines, omitting new-lines.
799 # In a scalar context, returns the file's contents as a single string.
802 open (OUTPUT, $file) or die "$file: open: $!\n";
803 my (@lines) = <OUTPUT>;
806 return wantarray ? @lines : join ('', map ("$_\n", @lines));
809 # Returns true if the two specified files are byte-for-byte identical,
814 open (A, "<$a") or die "$a: open: $!\n";
815 open (B, "<$b") or die "$b: open: $!\n";
821 sysread (A, $sa, 1024);
822 sysread (B, $sb, 1024);
823 $equal = 0, last if $sa ne $sb;
824 $equal = 1, last if $sa eq '';
832 # Returns true if the specified file is byte-for-byte identical with
833 # the specified string.
835 my ($file, $expected) = @_;
836 open (FILE, "<$file") or die "$file: open: $!\n";
838 sysread (FILE, $actual, -s FILE);
839 my ($equal) = $actual eq $expected;
845 for my $test (@TESTS) {
846 return 1 if !defined ($result{$test}) || $result{$test} ne 'ok';