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