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