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