pintos-os.org Git - pintos-anon/blob - grading/lib/Pintos/Grading.pm

   1 use strict;
   2 use warnings;
   3
   4 our ($test);
   5
   6 our ($GRADES_DIR);
   7 our ($verbose);
   8 our %result;
   9 our %details;
  10 our %extra;
  11 our @TESTS;
  12 our $action;
  13 our $hw;
  14
  15 use POSIX;
  16 use Getopt::Long qw(:config no_ignore_case);
  17 use Algorithm::Diff;
  18 \f
  19 # We execute lots of subprocesses.
  20 # Without this, our stdout output can get flushed multiple times,
  21 # which is harmless but looks bizarre.
  22 $| = 1;
  23
  24 sub parse_cmd_line {
  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"
  37         if @ARGV > 0;
  38     @TESTS = split(/,/, join (',', @TESTS)) if defined @TESTS;
  39
  40     if (!defined $action) {
  41         $action = -e 'review.txt' ? 'assemble' : 'test';
  42     }
  43
  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;
  48 }
  49
  50 sub set_action {
  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;
  55 }
  56
  57 sub usage {
  58     my ($exitcode) = @_;
  59     print <<EOF;
  60 run-tests, for grading Pintos $hw projects.
  61
  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.
  64
  65 Workflow:
  66
  67 1. Extracts the source tree into pintos/src and applies patches.
  68
  69 2. Builds the source tree.  (The threads project modifies and rebuilds
  70    the source tree for every test.)
  71
  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.
  75
  76 4. By hand, copy "review.txt" from the tests directory and use it as a
  77    template for grading design documents.
  78
  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.
  82
  83 Options:
  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.
  93 EOF
  94     exit $exitcode;
  95 }
  96 \f
  97 # Source tarballs.
  98
  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";
 105
 106     # Nothing else to do if we already have a source tree.
 107     return if -d "pintos";
 108
 109     my ($tarball) = choose_tarball ();
 110
 111     # Extract sources.
 112     print "Creating pintos/src...\n";
 113     mkdir "pintos" or die "pintos: mkdir: $!\n";
 114     mkdir "pintos/src" or die "pintos/src: mkdir: $!\n";
 115
 116     print "Extracting $tarball into pintos/src...\n";
 117     xsystem ("cd pintos/src && tar xzf ../../$tarball",
 118              DIE => "extraction failed\n");
 119
 120     # Run custom script for this submission, if provided.
 121     if (-e "fixme.sh") {
 122         print "Running fixme.sh...\n";
 123         xsystem ("sh -e fixme.sh", DIE => "fix script failed\n");
 124     } else {
 125         print "No fixme.sh, assuming no custom changes needed.\n";
 126     }
 127
 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")) {
 134         my ($stem);
 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");
 139     }
 140
 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";
 145     close CONSTANTS;
 146 }
 147
 148 # Returns the name of the tarball to extract.
 149 sub choose_tarball {
 150     my (@tarballs)
 151         = grep (/^[a-z0-9]+\.[A-Za-z]+\.\d+\.\d+\.\d+\.\d+.\d+\.tar\.gz$/,
 152                 glob ("*.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;
 155
 156     if (@tarballs > 1) {
 157         # Sort tarballs in order by time.
 158         @tarballs = sort { ext_mdyHMS ($a) cmp ext_mdyHMS ($b) } @tarballs;
 159
 160         print "Multiple tarballs:\n";
 161         print "\t$_ submitted ", ext_mdyHMS ($_), "\n" foreach @tarballs;
 162         print "Choosing $tarballs[$#tarballs]\n";
 163     }
 164     return $tarballs[$#tarballs];
 165 }
 166
 167 # Extract the date within a tarball name into a string that compares
 168 # lexicographically in chronological order.
 169 sub ext_mdyHMS {
 170     my ($s) = @_;
 171     my ($ms, $d, $y, $H, $M, $S) =
 172         $s =~ /.([A-Za-z]+)\.(\d+)\.(\d+)\.(\d+)\.(\d+).(\d+)\.tar\.gz$/
 173         or die;
 174     my ($m) = index ("janfebmaraprmayjunjulaugsepoctnovdec", lc $ms) / 3
 175         or die;
 176     return sprintf "%02d-%02d-%02d %02d:%02d:%02d", $y, $m, $d, $H, $M, $S;
 177 }
 178 \f
 179 # Building.
 180
 181 sub build {
 182     print "Compiling...\n";
 183     xsystem ("cd pintos/src/$hw && make", LOG => "make") eq 'ok'
 184         or return "Build error";
 185 }
 186 \f
 187 # Run and grade the tests.
 188 sub run_and_grade_tests {
 189     for $test (@TESTS) {
 190         print "$test: ";
 191         my ($result) = get_test_result ();
 192         chomp ($result);
 193
 194         my ($grade) = grade_test ($test);
 195         chomp ($grade);
 196
 197         my ($msg) = $result eq 'ok' ? $grade : "$result - $grade";
 198         $msg .= " - with warnings"
 199             if $grade eq 'ok' && defined $details{$test};
 200         print "$msg\n";
 201
 202         $result{$test} = $grade;
 203     }
 204 }
 205
 206 # Write test grades to tests.out.
 207 sub write_grades {
 208     my (@summary) = snarf ("$GRADES_DIR/tests.txt");
 209
 210     my ($ploss) = 0;
 211     my ($tloss) = 0;
 212     my ($total) = 0;
 213     my ($warnings) = 0;
 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.";
 218
 219             if ($result eq 'ok') {
 220                 if (!defined $details{$test}) {
 221                     # Test successful and no warnings.
 222                     splice (@summary, $i, 1);
 223                     $i--;
 224                 } else {
 225                     # Test successful with warnings.
 226                     s/-(\d+) //;
 227                     $summary[$i] = $_;
 228                     splice (@summary, $i + 1, 0,
 229                             "     Test passed with warnings.  "
 230                             . "Details at end of file.");
 231                     $warnings++;
 232                 }
 233             } else {
 234                 $ploss += $loss;
 235                 $tloss += $loss;
 236                 splice (@summary, $i + 1, 0,
 237                         map ("     $_", split ("\n", $result)));
 238             }
 239         } elsif (my ($ptotal) = /^Score: \/(\d+)$/) {
 240             $total += $ptotal;
 241             $summary[$i] = "Score: " . ($ptotal - $ploss) . "/$ptotal";
 242             splice (@summary, $i, 0, "  All tests passed.")
 243                 if $ploss == 0 && !$warnings;
 244             $ploss = 0;
 245             $warnings = 0;
 246             $i++;
 247         }
 248     }
 249     my ($ts) = "(" . ($total - $tloss) . "/" . $total . ")";
 250     $summary[0] =~ s/\[\[total\]\]/$ts/;
 251
 252     open (SUMMARY, ">tests.out");
 253     print SUMMARY map ("$_\n", @summary);
 254     close (SUMMARY);
 255 }
 256
 257 # Write failure and warning details to details.out.
 258 sub write_details {
 259     open (DETAILS, ">details.out");
 260     my ($n) = 0;
 261     for $test (@TESTS) {
 262         next if $result{$test} eq 'ok' && !defined $details{$test};
 263
 264         my ($details) = $details{$test};
 265         next if !defined ($details) && ! -e "output/$test/run.out";
 266
 267         my ($banner);
 268         if ($result{$test} ne 'ok') {
 269             $banner = "$test failure details";
 270         } else {
 271             $banner = "$test warnings";
 272         }
 273
 274         print DETAILS "\n" if $n++;
 275         print DETAILS "--- $banner ", '-' x (50 - length ($banner));
 276         print DETAILS "\n\n";
 277
 278         if (!defined $details) {
 279             my (@output) = snarf ("output/$test/run.out");
 280
 281             # Print only the first in a series of recursing panics.
 282             my ($panic) = 0;
 283             for my $i (0...$#output) {
 284                 local ($_) = $output[$i];
 285                 if (/PANIC/ && $panic++ > 0) {
 286                     @output = @output[0...$i];
 287                     push (@output,
 288                           "[...details of recursive panic(s) omitted...]");
 289                     last;
 290                 }
 291             }
 292             $details = "Output:\n\n" . join ('', map ("$_\n", @output));
 293         }
 294         print DETAILS $details;
 295
 296         print DETAILS "\n", "-" x 10, "\n\n$extra{$test}"
 297             if defined $extra{$test};
 298     }
 299     close (DETAILS);
 300 }
 301 \f
 302 sub xsystem {
 303     my ($command, %options) = @_;
 304     print "$command\n" if $verbose || $options{VERBOSE};
 305
 306     my ($log) = $options{LOG};
 307
 308     my ($pid, $status);
 309     eval {
 310         local $SIG{ALRM} = sub { die "alarm\n" };
 311         alarm $options{TIMEOUT} if defined $options{TIMEOUT};
 312         $pid = fork;
 313         die "fork: $!\n" if !defined $pid;
 314         if (!$pid) {
 315             if (defined $log) {
 316                 open (STDOUT, ">output/$log.out");
 317                 open (STDERR, ">output/$log.err");
 318             }
 319             chdir $options{CHDIR} or die "$options{CHDIR}: chdir: $!\n"
 320               if defined ($options{CHDIR});
 321             if (!defined ($options{EXEC})) {
 322                 exec ($command);
 323             } else {
 324                 exec (@{$options{EXEC}});
 325             }
 326             exit (-1);
 327         }
 328         waitpid ($pid, 0);
 329         $status = $?;
 330         alarm 0;
 331     };
 332
 333     my ($result);
 334     if ($@) {
 335         die unless $@ eq "alarm\n";   # propagate unexpected errors
 336         my ($i);
 337         for ($i = 0; $i < 10; $i++) {
 338             kill ('SIGTERM', $pid);
 339             sleep (1);
 340             my ($retval) = waitpid ($pid, WNOHANG);
 341             last if $retval == $pid || $retval == -1;
 342             print "Timed out - Waiting for $pid to die" if $i == 0;
 343             print ".";
 344         }
 345         print "\n" if $i;
 346         $result = 'timeout';
 347     } else {
 348         if (WIFSIGNALED ($status)) {
 349             my ($signal) = WTERMSIG ($status);
 350             die "Interrupted\n" if $signal == SIGINT;
 351             print "Child terminated with signal $signal\n";
 352         }
 353
 354         $result = $status == 0 ? "ok" : "error";
 355     }
 356
 357     if ($result eq 'error' && defined $options{DIE}) {
 358         my ($msg) = $options{DIE};
 359         if (defined ($log)) {
 360             chomp ($msg);
 361             $msg .= "; see output/$log.err and output/$log.out for details\n";
 362         }
 363         die $msg;
 364     } elsif ($result ne 'error' && defined ($log)) {
 365         unlink ("output/$log.err");
 366     }
 367
 368     return $result;
 369 }
 370 \f
 371 sub get_test_result {
 372     my ($cache_file) = "output/$test/run.result";
 373     # Reuse older results if any.
 374     if (open (RESULT, "<$cache_file")) {
 375         my ($result);
 376         $result = <RESULT>;
 377         chomp $result;
 378         close (RESULT);
 379         return $result;
 380     }
 381
 382     # If there's residue from an earlier test, move it to .old.
 383     # If there's already a .old, delete it.
 384     xsystem ("rm -rf output/$test.old", VERBOSE => 1) if -d "output/$test.old";
 385     rename "output/$test", "output/$test.old" or die "rename: $!\n"
 386         if -d "output/$test";
 387
 388     # Make output directory.
 389     mkdir "output/$test";
 390
 391     # Run the test.
 392     my ($result) = run_test ($test);
 393
 394     # Delete any disks in the output directory because they take up
 395     # lots of space.
 396     unlink (glob ("output/$test/*.dsk"));
 397
 398     # Save the results for later.
 399     open (DONE, ">$cache_file") or die "$cache_file: create: $!\n";
 400     print DONE "$result\n";
 401     close (DONE);
 402
 403     return $result;
 404 }
 405
 406 sub run_pintos {
 407     my ($cmd_line, %args) = @_;
 408     unshift (@$cmd_line, 'pintos');
 409     my ($retval) = xsystem (join (' ', @$cmd_line), %args, EXEC => $cmd_line);
 410     return 'ok' if $retval eq 'ok';
 411     if ($retval eq 'timeout') {
 412         my ($msg) = "Timed out after $args{TIMEOUT} seconds";
 413         my ($load_avg) = `uptime` =~ /(load average:.*)$/i;
 414         $msg .= " - $load_avg" if defined $load_avg;
 415         return $msg;
 416     }
 417     return 'Error running Bochs' if $retval eq 'error';
 418     die;
 419 }
 420
 421 # Grade the test.
 422 sub grade_test {
 423     # Read test output.
 424     my ($outfile) = "output/$test/run.out";
 425     if (! -e $outfile) {
 426         if (-s "output/$test/make.err") {
 427             # make failed.
 428             $details{$test} = snarf ("output/$test/make.err");
 429             return "make failed.  Error messages at end of file.";
 430         }
 431         die "$outfile: missing test output file";
 432     }
 433     my (@output) = snarf ($outfile);
 434
 435     # If there's a function "grade_$test", use it to evaluate the output.
 436     # If there's a file "$GRADES_DIR/$test.exp", compare its contents
 437     # against the output.
 438     # (If both exist, prefer the function.)
 439     #
 440     # If the test was successful, it returns normally.
 441     # If it failed, it invokes `die' with an error message terminated
 442     # by a new-line.  The message will be given as an explanation in
 443     # the output file tests.out.
 444     # (Internal errors will invoke `die' without a terminating
 445     # new-line, in which case we detect it and propagate the `die'
 446     # upward.)
 447     my ($grade_func) = "grade_$test";
 448     $grade_func =~ s/-/_/g;
 449     if (-e "$GRADES_DIR/$test.exp" && !defined (&$grade_func)) {
 450         eval {
 451             verify_common (@output);
 452             compare_output ("$GRADES_DIR/$test.exp", @output);
 453         }
 454     } else {
 455         eval "$grade_func (\@output)";
 456     }
 457     if ($@) {
 458         die $@ if $@ =~ /at \S+ line \d+$/;
 459         return $@;
 460     }
 461     return "ok";
 462 }
 463 \f
 464 # Do final grade.
 465 # Combines grade.txt, tests.out, review.txt, and details.out,
 466 # producing grade.out.
 467 sub assemble_final_grade {
 468     open (OUT, ">grade.out") or die "grade.out: create: $!\n";
 469
 470     open (GRADE, "<grade.txt") or die "grade.txt: open: $!\n";
 471     while (<GRADE>) {
 472         last if /^\s*$/;
 473         print OUT;
 474     }
 475     close (GRADE);
 476
 477     my (@tests) = snarf ("tests.out");
 478     my ($p_got, $p_pos) = $tests[0] =~ m%\((\d+)/(\d+)\)% or die;
 479
 480     my (@review) = snarf ("review.txt");
 481     my ($part_lost) = (0, 0);
 482     for (my ($i) = $#review; $i >= 0; $i--) {
 483         local ($_) = $review[$i];
 484         if (my ($loss) = /^\s*([-+]\d+)/) {
 485             $part_lost += $loss;
 486         } elsif (my ($out_of) = m%\[\[/(\d+)\]\]%) {
 487             my ($got) = $out_of + $part_lost;
 488             $got = 0 if $got < 0;
 489             $review[$i] =~ s%\[\[/\d+\]\]%($got/$out_of)% or die;
 490             $part_lost = 0;
 491
 492             $p_got += $got;
 493             $p_pos += $out_of;
 494         }
 495     }
 496     die "Lost points outside a section\n" if $part_lost;
 497
 498     for (my ($i) = 1; $i <= $#review; $i++) {
 499         if ($review[$i] =~ /^-{3,}\s*$/ && $review[$i - 1] !~ /^\s*$/) {
 500             $review[$i] = '-' x (length ($review[$i - 1]));
 501         }
 502     }
 503
 504     print OUT "\nOVERALL SCORE\n";
 505     print OUT "-------------\n";
 506     print OUT "$p_got points out of $p_pos total\n\n";
 507
 508     print OUT map ("$_\n", @tests), "\n";
 509     print OUT map ("$_\n", @review), "\n";
 510
 511     print OUT "DETAILS\n";
 512     print OUT "-------\n\n";
 513     print OUT map ("$_\n", snarf ("details.out"));
 514 }
 515 \f
 516 # Clean up our generated files.
 517 sub clean_dir {
 518     # Verify that we're roughly in the correct directory
 519     # before we go blasting away files.
 520     choose_tarball ();
 521
 522     # Blow away everything.
 523     xsystem ("rm -rf output pintos", VERBOSE => 1);
 524     xsystem ("rm -f details.out tests.out", VERBOSE => 1);
 525 }
 526 \f
 527 # Provided a test's output as an array, verifies that it, in general,
 528 # looks sensible; that is, that there are no PANIC or FAIL messages,
 529 # that Pintos started up and shut down normally, and so on.
 530 # Die if something odd found.
 531 sub verify_common {
 532     my (@output) = @_;
 533
 534     die "No output at all\n" if @output == 0;
 535
 536     look_for_panic (@output);
 537     look_for_fail (@output);
 538     look_for_triple_fault (@output);
 539
 540     die "Didn't start up properly: no \"Pintos booting\" startup message\n"
 541         if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
 542     die "Didn't start up properly: no \"Boot complete\" startup message\n"
 543         if !grep (/Boot complete/, @output);
 544     die "Didn't shut down properly: no \"Timer: # ticks\" shutdown message\n"
 545         if !grep (/Timer: \d+ ticks/, @output);
 546     die "Didn't shut down properly: no \"Powering off\" shutdown message\n"
 547         if !grep (/Powering off/, @output);
 548 }
 549
 550 sub look_for_panic {
 551     my (@output) = @_;
 552
 553     my ($panic) = grep (/PANIC/, @output);
 554     return unless defined $panic;
 555
 556     my ($details) = "Kernel panic:\n  $panic\n";
 557
 558     my (@stack_line) = grep (/Call stack:/, @output);
 559     if (@stack_line != 0) {
 560         $details .= "  $stack_line[0]\n\n";
 561         $details .= "Translation of backtrace:\n";
 562         my (@addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
 563
 564         my ($A2L);
 565         if (`uname -m`
 566             =~ /i.86|pentium.*|[pk][56]|nexgen|viac3|6x86|athlon.*/) {
 567             $A2L = "addr2line";
 568         } else {
 569             $A2L = "i386-elf-addr2line";
 570         }
 571         my ($kernel_o);
 572         if ($hw eq 'threads') {
 573             $kernel_o = "output/$test/kernel.o";
 574         } else {
 575             $kernel_o = "pintos/src/$hw/build/kernel.o";
 576         }
 577         open (A2L, "$A2L -fe $kernel_o @addrs|");
 578         for (;;) {
 579             my ($function, $line);
 580             last unless defined ($function = <A2L>);
 581             $line = <A2L>;
 582             chomp $function;
 583             chomp $line;
 584             $details .= "  $function ($line)\n";
 585         }
 586     }
 587
 588     if ($panic =~ /sec_no < d->capacity/) {
 589         $details .= <<EOF;
 590 \nThis assertion commonly fails when accessing a file via an inode that
 591 has been closed and freed.  Freeing an inode clears all its sector
 592 indexes to 0xcccccccc, which is not a valid sector number for disks
 593 smaller than about 1.6 TB.
 594 EOF
 595         }
 596
 597     $extra{$test} = $details;
 598     die "Kernel panic.  Details at end of file.\n";
 599 }
 600
 601 sub look_for_fail {
 602     my (@output) = @_;
 603
 604     my ($failure) = grep (/FAIL/, @output);
 605     return unless defined $failure;
 606
 607     # Eliminate uninteresting header and trailer info if possible.
 608     # The `eval' catches the `die' from get_core_output() in the "not
 609     # possible" case.
 610     eval {
 611         my (@core) = get_core_output (@output);
 612         $details{$test} = "Program output:\n\n" . join ('', map ("$_\n", @core));
 613     };
 614
 615     # Most output lines are prefixed by (test-name).  Eliminate this
 616     # from our `die' message for brevity.
 617     $failure =~ s/^\([^\)]+\)\s+//;
 618     die "$failure.  Details at end of file.\n";
 619 }
 620
 621 sub look_for_triple_fault {
 622     my (@output) = @_;
 623
 624     return unless grep (/Pintos booting/, @output) > 1;
 625
 626     my ($details) = <<EOF;
 627 Pintos spontaneously rebooted during this test.  This is most often
 628 due to unhandled page faults.  Output from initial boot through the
 629 first reboot is shown below:
 630
 631 EOF
 632
 633     my ($i) = 0;
 634     local ($_);
 635     for (@output) {
 636         $details .= "  $_\n";
 637         last if /Pintos booting/ && ++$i > 1;
 638     }
 639     $details{$test} = $details;
 640     die "Triple-fault caused spontaneous reboot(s).  "
 641         . "Details at end of file.\n";
 642 }
 643
 644 # Get @output without header or trailer.
 645 # Die if not possible.
 646 sub get_core_output {
 647     my (@output) = @_;
 648
 649     my ($first);
 650     for ($first = 0; $first <= $#output; $first++) {
 651         my ($line) = $output[$first];
 652         $first++, last
 653             if ($hw ne 'threads' && $line =~ /^Executing '$test.*':$/)
 654             || ($hw eq 'threads'
 655                 && grep (/^Boot complete.$/, @output[0...$first - 1])
 656                 && $line =~ /^\s*$/);
 657     }
 658
 659     my ($last);
 660     for ($last = $#output; $last >= 0; $last--) {
 661         $last--, last if $output[$last] =~ /^Timer: \d+ ticks$/;
 662     }
 663
 664     if ($last < $first) {
 665         my ($no_first) = $first > $#output;
 666         my ($no_last) = $last < $#output;
 667         die "Couldn't locate output.\n";
 668     }
 669
 670     return @output[$first ... $last];
 671 }
 672
 673 sub canonicalize_exit_codes {
 674     my (@output) = @_;
 675
 676     # Exit codes are supposed to be printed in the form "process: exit(code)"
 677     # but people get unfortunately creative with it.
 678     for my $i (0...$#output) {
 679         local ($_) = $output[$i];
 680
 681         my ($process, $code);
 682         if ((($process, $code) = /^([-a-z0-9 ]+):.*[ \(](-?\d+)\b\)?$/)
 683             || (($process, $code) = /^([-a-z0-9 ]+) exit\((-?\d+)\)$/)
 684             || (($process, $code)
 685                 = /^([-a-z0-9 ]+) \(.*\): exit\((-?\d+)\)$/)
 686             || (($process, $code) = /^([-a-z0-9 ]+):\( (-?\d+) \) $/)
 687             || (($code, $process) = /^shell: exit\((-?\d+)\) \| ([-a-z0-9]+)/))
 688         {
 689             # We additionally truncate to 15 character and strip all
 690             # but the first word.
 691             $process = substr ($process, 0, 15);
 692             $process =~ s/\s.*//;
 693             $output[$i] = "$process: exit($code)\n";
 694         }
 695     }
 696
 697     return @output;
 698 }
 699
 700 sub strip_exit_codes {
 701     return grep (!/^[-a-z0-9]+: exit\(-?\d+\)/, canonicalize_exit_codes (@_));
 702 }
 703
 704 sub compare_output {
 705     my ($exp, @actual) = @_;
 706
 707     # Canonicalize output for comparison.
 708     @actual = get_core_output (map ("$_\n", @actual));
 709     if ($hw eq 'userprog') {
 710         @actual = canonicalize_exit_codes (@actual);
 711     } elsif ($hw eq 'vm' || $hw eq 'filesys') {
 712         @actual = strip_exit_codes (@actual);
 713     }
 714
 715     # There *was* some output, right?
 716     die "Program produced no output.\n" if !@actual;
 717
 718     # Read expected output.
 719     my (@exp) = map ("$_\n", snarf ($exp));
 720
 721     # Pessimistically, start preparation of detailed failure message.
 722     my ($details) = "";
 723     $details .= "$test actual output:\n";
 724     $details .= join ('', map ("  $_", @actual));
 725
 726     # Set true when we find expected output that matches our actual
 727     # output except for some extra actual output (that doesn't seem to
 728     # be an error message etc.).
 729     my ($fuzzy_match) = 0;
 730
 731     # Compare actual output against each allowed output.
 732     while (@exp != 0) {
 733         # Grab one set of allowed output from @exp into @expected.
 734         my (@expected);
 735         while (@exp != 0) {
 736             my ($s) = shift (@exp);
 737             last if $s eq "--OR--\n";
 738             push (@expected, $s);
 739         }
 740
 741         $details .= "\n$test acceptable output:\n";
 742         $details .= join ('', map ("  $_", @expected));
 743
 744         # Check whether actual and expected match.
 745         # If it's a perfect match, return.
 746         if ($#actual == $#expected) {
 747             my ($eq) = 1;
 748             for (my ($i) = 0; $i <= $#expected; $i++) {
 749                 $eq = 0 if $actual[$i] ne $expected[$i];
 750             }
 751             return if $eq;
 752         }
 753
 754         # They differ.  Output a diff.
 755         my (@diff) = "";
 756         my ($d) = Algorithm::Diff->new (\@expected, \@actual);
 757         my ($not_fuzzy_match) = 0;
 758         while ($d->Next ()) {
 759             my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
 760             if ($d->Same ()) {
 761                 push (@diff, map ("  $_", $d->Items (1)));
 762             } else {
 763                 push (@diff, map ("- $_", $d->Items (1))) if $d->Items (1);
 764                 push (@diff, map ("+ $_", $d->Items (2))) if $d->Items (2);
 765                 if ($d->Items (1)
 766                     || grep (/\($test\)|exit\(-?\d+\)|dying due to|Page fault/,
 767                              $d->Items (2))) {
 768                     $not_fuzzy_match = 1;
 769                 }
 770             }
 771         }
 772
 773         # If we didn't find anything that means it's not,
 774         # it's a fuzzy match.
 775         $fuzzy_match = 1 if !$not_fuzzy_match;
 776
 777         $details .= "Differences in `diff -u' format:\n";
 778         $details .= join ('', @diff);
 779         $details .= "(This is considered a `fuzzy match'.)\n"
 780             if !$not_fuzzy_match;
 781     }
 782
 783     # Failed to match.  Report failure.
 784     if ($fuzzy_match) {
 785         $details =
 786             "This test passed, but with extra, unexpected output.\n"
 787             . "Please inspect your code to make sure that it does not\n"
 788             . "produce output other than as specified in the project\n"
 789             . "description.\n\n"
 790             . "$details";
 791     } else {
 792         $details =
 793             "This test failed because its output did not match any\n"
 794             . "of the acceptable form(s).\n\n"
 795             . "$details";
 796     }
 797
 798     $details{$test} = $details;
 799     die "Output differs from expected.  Details at end of file.\n"
 800         unless $fuzzy_match;
 801 }
 802 \f
 803 # Reads and returns the contents of the specified file.
 804 # In an array context, returns the file's contents as an array of
 805 # lines, omitting new-lines.
 806 # In a scalar context, returns the file's contents as a single string.
 807 sub snarf {
 808     my ($file) = @_;
 809     open (OUTPUT, $file) or die "$file: open: $!\n";
 810     my (@lines) = <OUTPUT>;
 811     chomp (@lines);
 812     close (OUTPUT);
 813     return wantarray ? @lines : join ('', map ("$_\n", @lines));
 814 }
 815
 816 # Returns true if the two specified files are byte-for-byte identical,
 817 # false otherwise.
 818 sub files_equal {
 819     my ($a, $b) = @_;
 820     my ($equal);
 821     open (A, "<$a") or die "$a: open: $!\n";
 822     open (B, "<$b") or die "$b: open: $!\n";
 823     if (-s A != -s B) {
 824         $equal = 0;
 825     } else {
 826         my ($sa, $sb);
 827         for (;;) {
 828             sysread (A, $sa, 1024);
 829             sysread (B, $sb, 1024);
 830             $equal = 0, last if $sa ne $sb;
 831             $equal = 1, last if $sa eq '';
 832         }
 833     }
 834     close (A);
 835     close (B);
 836     return $equal;
 837 }
 838
 839 # Returns true if the specified file is byte-for-byte identical with
 840 # the specified string.
 841 sub file_contains {
 842     my ($file, $expected) = @_;
 843     open (FILE, "<$file") or die "$file: open: $!\n";
 844     my ($actual);
 845     sysread (FILE, $actual, -s FILE);
 846     my ($equal) = $actual eq $expected;
 847     close (FILE);
 848     return $equal;
 849 }
 850 \f
 851 sub success {
 852     for my $test (@TESTS) {
 853         return 1 if !defined ($result{$test}) || $result{$test} ne 'ok';
 854     }
 855     return 0;
 856 }
 857
 858 1;