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 (%args);
   9 our %result;
  10 our %details;
  11 our %extra;
  12 our @TESTS;
  13 our $clean;
  14 our $grade;
  15 our $hw;
  16
  17 use POSIX;
  18 use Getopt::Long;
  19 use Algorithm::Diff;
  20 \f
  21 sub parse_cmd_line {
  22     GetOptions ("v|verbose+" => \$verbose,
  23                 "h|help" => sub { usage (0) },
  24                 "t|test=s" => \@TESTS,
  25                 "c|clean" => \$clean,
  26                 "g|grade" => \$grade)
  27         or die "Malformed command line; use --help for help.\n";
  28     die "Non-option argument not supported; use --help for help.\n"
  29         if @ARGV > 0;
  30 }
  31
  32 sub usage {
  33     my ($exitcode) = @_;
  34     print "run-tests, for grading Pintos projects.\n\n";
  35     print "Invoke from a directory containing a student tarball named by\n";
  36     print "the submit script, e.g. username.MMM.DD.YY.hh.mm.ss.tar.gz.\n";
  37     print "In normal usage, no options are needed.\n\n";
  38     print "Output is produced in tests.out and details.out.\n\n";
  39     print "Options:\n";
  40     print "  -c, --clean     Remove old output files before starting\n";
  41     print "  -t, --test=TEST Execute TEST only (allowed multiple times)\n";
  42     print "  -g, --grade     Instead of running tests, compose grade.out\n";
  43     print "  -v, --verbose   Print commands before executing them\n";
  44     print "  -h, --help      Print this help message\n";
  45     exit $exitcode;
  46 }
  47 \f
  48 # Source tarballs.
  49
  50 # Extracts the group's source files into pintos/src,
  51 # applies any patches providing in the grading directory,
  52 # and installs a default pintos/src/constants.h
  53 sub obtain_sources {
  54     # Nothing to do if we already have a source tree.
  55     return if -d "pintos";
  56
  57     my ($tarball) = choose_tarball ();
  58
  59     # Extract sources.
  60     print "Creating pintos/src...\n";
  61     mkdir "pintos" or die "pintos: mkdir: $!\n";
  62     mkdir "pintos/src" or die "pintos/src: mkdir: $!\n";
  63
  64     print "Extracting $tarball into pintos/src...\n";
  65     xsystem ("cd pintos/src && tar xzf ../../$tarball",
  66              DIE => "extraction failed\n");
  67
  68     # Run custom script for this submission, if provided.
  69     if (-e "fixme.sh") {
  70         print "Running fixme.sh...\n";
  71         xsystem ("sh -e fixme.sh", DIE => "fix script failed\n");
  72     } else {
  73         print "No fixme.sh, assuming no custom changes needed.\n";
  74     }
  75
  76     # Apply patches from grading directory.
  77     # Patches are applied in lexicographic order, so they should
  78     # probably be named 00-debug.patch, 01-bitmap.patch, etc.
  79     # Filenames in patches should be in the format pintos/src/...
  80     print "Patching...\n";
  81     for my $patch (glob ("$GRADES_DIR/patches/*.patch")) {
  82         my ($stem);
  83         ($stem = $patch) =~ s%^$GRADES_DIR/patches/%% or die;
  84         print "Applying $patch...\n";
  85         xsystem ("patch -fs -p0 < $patch",
  86                  LOG => $stem, DIE => "applying patch $stem failed\n");
  87     }
  88
  89     # Install default pintos/src/constants.h.
  90     open (CONSTANTS, ">pintos/src/constants.h")
  91         or die "constants.h: create: $!\n";
  92     print CONSTANTS "#define THREAD_JOIN_IMPLEMENTED 1\n";
  93     close CONSTANTS;
  94 }
  95
  96 # Returns the name of the tarball to extract.
  97 sub choose_tarball {
  98     my (@tarballs)
  99         = grep (/^[a-z0-9]+\.[A-Za-z]+\.\d+\.\d+\.\d+\.\d+.\d+\.tar\.gz$/,
 100                 glob ("*.tar.gz"));
 101     die "no pintos dir, no files matching username.MMM.DD.YY.hh.mm.ss.tar.gz\n"
 102         if scalar (@tarballs) == 0;
 103
 104     if (@tarballs > 1) {
 105         # Sort tarballs in order by time.
 106         @tarballs = sort { ext_mdyHMS ($a) cmp ext_mdyHMS ($b) } @tarballs;
 107
 108         print "Multiple tarballs:";
 109         print "\t$_ submitted ", ext_mdyHMS ($_), "\n" foreach @tarballs;
 110         print "Choosing $tarballs[$#tarballs]\n";
 111     }
 112     return $tarballs[$#tarballs];
 113 }
 114
 115 # Extract the date within a tarball name into a string that compares
 116 # lexicographically in chronological order.
 117 sub ext_mdyHMS {
 118     my ($s) = @_;
 119     my ($ms, $d, $y, $H, $M, $S) =
 120         $s =~ /.([A-Za-z]+)\.(\d+)\.(\d+)\.(\d+)\.(\d+).(\d+)\.tar\.gz$/
 121         or die;
 122     my ($m) = index ("janfebmaraprmayjunjulaugsepoctnovdec", lc $ms) / 3
 123         or die;
 124     return sprintf "%02d-%02d-%02d %02d:%02d:%02d", $y, $m, $d, $H, $M, $S;
 125 }
 126 \f
 127 # Compiling.
 128
 129 sub compile {
 130     print "Compiling...\n";
 131     xsystem ("cd pintos/src/filesys && make", LOG => "make")
 132         or return "compile error";
 133 }
 134 \f
 135 # Run and grade the tests.
 136 sub run_and_grade_tests {
 137     for $test (@TESTS) {
 138         print "$test: ";
 139         my ($result) = get_test_result ();
 140         if ($result eq 'ok') {
 141             $result = grade_test ($test);
 142         } elsif ($result =~ /^Timed out/) {
 143             $result = "$result - " . grade_test ($test);
 144         }
 145         chomp ($result);
 146         print "$result";
 147         print " - with warnings" if $result eq 'ok' && defined $details{$test};
 148         print "\n";
 149
 150         $result{$test} = $result;
 151     }
 152 }
 153
 154 # Write test grades to tests.out.
 155 sub write_grades {
 156     my (@summary) = snarf ("$GRADES_DIR/tests.txt");
 157
 158     my ($ploss) = 0;
 159     my ($tloss) = 0;
 160     my ($total) = 0;
 161     my ($warnings) = 0;
 162     for (my ($i) = 0; $i <= $#summary; $i++) {
 163         local ($_) = $summary[$i];
 164         if (my ($loss, $test) = /^  -(\d+) ([-a-zA-Z0-9]+):/) {
 165             my ($result) = $result{$test} || "Not tested.";
 166
 167             if ($result eq 'ok') {
 168                 if (!defined $details{$test}) {
 169                     # Test successful and no warnings.
 170                     splice (@summary, $i, 1);
 171                     $i--;
 172                 } else {
 173                     # Test successful with warnings.
 174                     s/-(\d+) //;
 175                     $summary[$i] = $_;
 176                     splice (@summary, $i + 1, 0,
 177                             "     Test passed with warnings.  "
 178                             . "Details at end of file.");
 179                     $warnings++;
 180                 }
 181             } else {
 182                 $ploss += $loss;
 183                 $tloss += $loss;
 184                 splice (@summary, $i + 1, 0,
 185                         map ("     $_", split ("\n", $result)));
 186             }
 187         } elsif (my ($ptotal) = /^Score: \/(\d+)$/) {
 188             $total += $ptotal;
 189             $summary[$i] = "Score: " . ($ptotal - $ploss) . "/$ptotal";
 190             splice (@summary, $i, 0, "  All tests passed.")
 191                 if $ploss == 0 && !$warnings;
 192             $ploss = 0;
 193             $warnings = 0;
 194             $i++;
 195         }
 196     }
 197     my ($ts) = "(" . ($total - $tloss) . "/" . $total . ")";
 198     $summary[0] =~ s/\[\[total\]\]/$ts/;
 199
 200     open (SUMMARY, ">tests.out");
 201     print SUMMARY map ("$_\n", @summary);
 202     close (SUMMARY);
 203 }
 204
 205 # Write failure and warning details to details.out.
 206 sub write_details {
 207     open (DETAILS, ">details.out");
 208     my ($n) = 0;
 209     for $test (@TESTS) {
 210         next if $result{$test} eq 'ok' && !defined $details{$test};
 211
 212         my ($details) = $details{$test};
 213         next if !defined ($details) && ! -e "output/$test/run.out";
 214
 215         my ($banner);
 216         if ($result{$test} ne 'ok') {
 217             $banner = "$test failure details";
 218         } else {
 219             $banner = "$test warnings";
 220         }
 221
 222         print DETAILS "\n" if $n++;
 223         print DETAILS "--- $banner ", '-' x (50 - length ($banner));
 224         print DETAILS "\n\n";
 225
 226         if (!defined $details) {
 227             my (@output) = snarf ("output/$test/run.out");
 228
 229             # Print only the first in a series of recursing panics.
 230             my ($panic) = 0;
 231             for my $i (0...$#output) {
 232                 local ($_) = $output[$i];
 233                 if (/PANIC/ && $panic++ > 0) {
 234                     @output = @output[0...$i];
 235                     push (@output,
 236                           "[...details of recursive panic(s) omitted...]");
 237                     last;
 238                 }
 239             }
 240             $details = "Output:\n\n" . join ('', map ("$_\n", @output));
 241         }
 242         print DETAILS $details;
 243
 244         print DETAILS "\n", "-" x 10, "\n\n$extra{$test}"
 245             if defined $extra{$test};
 246     }
 247     close (DETAILS);
 248 }
 249 \f
 250 sub xsystem {
 251     my ($command, %options) = @_;
 252     print "$command\n" if $verbose || $options{VERBOSE};
 253
 254     my ($log) = $options{LOG};
 255
 256     my ($pid, $status);
 257     eval {
 258         local $SIG{ALRM} = sub { die "alarm\n" };
 259         alarm $options{TIMEOUT} if defined $options{TIMEOUT};
 260         $pid = fork;
 261         die "fork: $!\n" if !defined $pid;
 262         if (!$pid) {
 263             if (defined $log) {
 264                 open (STDOUT, ">output/$log.out");
 265                 open (STDERR, ">output/$log.err");
 266             }
 267             exec ($command);
 268             exit (-1);
 269         }
 270         waitpid ($pid, 0);
 271         $status = $?;
 272         alarm 0;
 273     };
 274
 275     my ($result);
 276     if ($@) {
 277         die unless $@ eq "alarm\n";   # propagate unexpected errors
 278         my ($i);
 279         for ($i = 0; $i < 10; $i++) {
 280             kill ('SIGTERM', $pid);
 281             sleep (1);
 282             my ($retval) = waitpid ($pid, WNOHANG);
 283             last if $retval == $pid || $retval == -1;
 284             print "Timed out - Waiting for $pid to die" if $i == 0;
 285             print ".";
 286         }
 287         print "\n" if $i;
 288         $result = 'timeout';
 289     } else {
 290         if (WIFSIGNALED ($status)) {
 291             my ($signal) = WTERMSIG ($status);
 292             die "Interrupted\n" if $signal == SIGINT;
 293             print "Child terminated with signal $signal\n";
 294         }
 295
 296         my ($exp_status) = !defined ($options{EXPECT}) ? 0 : $options{EXPECT};
 297         $result = WIFEXITED ($status) && WEXITSTATUS ($status) == $exp_status
 298             ? "ok" : "error";
 299     }
 300
 301
 302     if ($result eq 'error' && defined $options{DIE}) {
 303         my ($msg) = $options{DIE};
 304         if (defined ($log)) {
 305             chomp ($msg);
 306             $msg .= "; see output/$log.err and output/$log.out for details\n";
 307         }
 308         die $msg;
 309     } elsif ($result ne 'error' && defined ($log)) {
 310         unlink ("output/$log.err");
 311     }
 312
 313     return $result;
 314 }
 315 \f
 316 sub get_test_result {
 317     my ($cache_file) = "output/$test/run.result";
 318     # Reuse older results if any.
 319     if (open (RESULT, "<$cache_file")) {
 320         my ($result);
 321         $result = <RESULT>;
 322         chomp $result;
 323         close (RESULT);
 324         return $result;
 325     }
 326
 327     # If there's residue from an earlier test, move it to .old.
 328     # If there's already a .old, delete it.
 329     xsystem ("rm -rf output/$test.old", VERBOSE => 1) if -d "output/$test.old";
 330     rename "output/$test", "output/$test.old" or die "rename: $!\n"
 331         if -d "output/$test";
 332
 333     # Run the test.
 334     my ($result) = run_test ($test);
 335
 336     # Save the results for later.
 337     open (DONE, ">$cache_file") or die "$cache_file: create: $!\n";
 338     print DONE "$result\n";
 339     close (DONE);
 340
 341     return $result;
 342 }
 343
 344 # Creates an output directory for the test,
 345 # creates all the files needed
 346 sub run_test {
 347     # Make output directory.
 348     mkdir "output/$test";
 349
 350     my ($fs_size) = $test ne 'grow-too-big' ? 2 : .25;
 351     xsystem ("pintos make-disk output/$test/fs.dsk $fs_size >/dev/null 2>&1",
 352              DIE => "failed to create file system disk");
 353     xsystem ("pintos make-disk output/$test/swap.dsk 2 >/dev/null 2>&1",
 354              DIE => "failed to create swap disk");
 355
 356     # Format disk, install test.
 357     my ($pintos_base_cmd) =
 358         "pintos "
 359         . "--os-disk=pintos/src/filesys/build/os.dsk "
 360         . "--fs-disk=output/$test/fs.dsk "
 361         . "--swap-disk=output/$test/swap.dsk "
 362         . "-v";
 363     unlink ("output/$test/fs.dsk", "output/$test/swap.dsk"),
 364     return "format/put error"
 365         if xsystem ("$pintos_base_cmd put -f $GRADES_DIR/$test $test",
 366                     LOG => "$test/put", TIMEOUT => 60, EXPECT => 1) ne 'ok';
 367
 368     my (@extra_files);
 369     push (@extra_files, "child-syn-read") if $test eq 'syn-read';
 370     push (@extra_files, "child-syn-wrt") if $test eq 'syn-write';
 371     push (@extra_files, "child-syn-rw") if $test eq 'syn-rw';
 372     for my $fn (@extra_files) {
 373         return "format/put error"
 374             if xsystem ("$pintos_base_cmd put $GRADES_DIR/$fn $fn",
 375                         LOG => "$test/put-$fn", TIMEOUT => 60, EXPECT => 1)
 376                ne 'ok';
 377     }
 378
 379     # Run.
 380     my ($timeout) = 120;
 381     my ($testargs) = defined ($args{$test}) ? " $args{$test}" : "";
 382     my ($retval) =
 383         xsystem ("$pintos_base_cmd run -q -ex \"$test$testargs\"",
 384                  LOG => "$test/run", TIMEOUT => $timeout, EXPECT => 1);
 385     my ($result);
 386     if ($retval eq 'ok') {
 387         $result = "ok";
 388     } elsif ($retval eq 'timeout') {
 389         $result = "Timed out after $timeout seconds";
 390     } elsif ($retval eq 'error') {
 391         $result = "Bochs error";
 392     } else {
 393         die;
 394     }
 395     unlink ("output/$test/fs.dsk", "output/$test/swap.dsk");
 396     return $result;
 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 compose_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         open (A2L, "$A2L -fe pintos/src/filesys/build/kernel.o @addrs|");
 541         for (;;) {
 542             my ($function, $line);
 543             last unless defined ($function = <A2L>);
 544             $line = <A2L>;
 545             chomp $function;
 546             chomp $line;
 547             $details .= "  $function ($line)\n";
 548         }
 549     }
 550
 551     if ($panic =~ /sec_no < d->capacity/) {
 552         $details .= <<EOF;
 553 \nThis assertion commonly fails when accessing a file via an inode that
 554 has been closed and freed.  Freeing an inode clears all its sector
 555 indexes to 0xcccccccc, which is not a valid sector number for disks
 556 smaller than about 1.6 TB.
 557 EOF
 558         }
 559
 560     $extra{$test} = $details;
 561     die "Kernel panic.  Details at end of file.\n";
 562 }
 563
 564 sub look_for_fail {
 565     my (@output) = @_;
 566
 567     my ($failure) = grep (/FAIL/, @output);
 568     return unless defined $failure;
 569
 570     # Eliminate uninteresting header and trailer info if possible.
 571     # The `eval' catches the `die' from get_core_output() in the "not
 572     # possible" case.
 573     eval {
 574         my (@core) = get_core_output (@output);
 575         $details{$test} = "Program output:\n\n" . join ('', map ("$_\n", @core));
 576     };
 577
 578     # Most output lines are prefixed by (test-name).  Eliminate this
 579     # from our `die' message for brevity.
 580     $failure =~ s/^\([^\)]+\)\s+//;
 581     die "$failure.  Details at end of file.\n";
 582 }
 583
 584 sub look_for_triple_fault {
 585     my (@output) = @_;
 586
 587     return unless grep (/Pintos booting/, @output) > 1;
 588
 589     my ($details) = <<EOF;
 590 Pintos spontaneously rebooted during this test.  This is most often
 591 due to unhandled page faults.  Output from initial boot through the
 592 first reboot is shown below:
 593
 594 EOF
 595
 596     my ($i) = 0;
 597     local ($_);
 598     for (@output) {
 599         $details .= "  $_\n";
 600         last if /Pintos booting/ && ++$i > 1;
 601     }
 602     $details{$test} = $details;
 603     die "Triple-fault caused spontaneous reboot(s).  "
 604         . "Details at end of file.\n";
 605 }
 606
 607 # Get @output without header or trailer.
 608 # Die if not possible.
 609 sub get_core_output {
 610     my (@output) = @_;
 611
 612     my ($first);
 613     for ($first = 0; $first <= $#output; $first++) {
 614         $first++, last if $output[$first] =~ /^Executing '$test.*':$/;
 615     }
 616
 617     my ($last);
 618     for ($last = $#output; $last >= 0; $last--) {
 619         $last--, last if $output[$last] =~ /^Timer: \d+ ticks$/;
 620     }
 621
 622     if ($last < $first) {
 623         my ($no_first) = $first > $#output;
 624         my ($no_last) = $last < $#output;
 625         die "Couldn't locate output.\n";
 626     }
 627
 628     return @output[$first ... $last];
 629 }
 630
 631 sub canonicalize_exit_codes {
 632     my (@output) = @_;
 633
 634     # Exit codes are supposed to be printed in the form "process: exit(code)"
 635     # but people get unfortunately creative with it.
 636     for my $i (0...$#output) {
 637         local ($_) = $output[$i];
 638
 639         my ($process, $code);
 640         if ((($process, $code) = /^([-a-z0-9 ]+):.*[ \(](-?\d+)\b\)?$/)
 641             || (($process, $code) = /^([-a-z0-9 ]+) exit\((-?\d+)\)$/)
 642             || (($process, $code)
 643                 = /^([-a-z0-9 ]+) \(.*\): exit\((-?\d+)\)$/)
 644             || (($process, $code) = /^([-a-z0-9 ]+):\( (-?\d+) \) $/)
 645             || (($code, $process) = /^shell: exit\((-?\d+)\) \| ([-a-z0-9]+)/))
 646         {
 647             # We additionally truncate to 15 character and strip all
 648             # but the first word.
 649             $process = substr ($process, 0, 15);
 650             $process =~ s/\s.*//;
 651             $output[$i] = "$process: exit($code)\n";
 652         }
 653     }
 654
 655     return @output;
 656 }
 657
 658 sub strip_exit_codes {
 659     return grep (!/^[-a-z0-9]+: exit\(-?\d+\)/, canonicalize_exit_codes (@_));
 660 }
 661
 662 sub compare_output {
 663     my ($exp, @actual) = @_;
 664
 665     # Canonicalize output for comparison.
 666     @actual = get_core_output (map ("$_\n", @actual));
 667     if ($hw eq 'userprog') {
 668         @actual = canonicalize_exit_codes (@actual);
 669     } elsif ($hw eq 'vm' || $hw eq 'filesys') {
 670         @actual = strip_exit_codes (@actual);
 671     }
 672
 673     # There *was* some output, right?
 674     die "Program produced no output.\n" if !@actual;
 675
 676     # Read expected output.
 677     my (@exp) = map ("$_\n", snarf ($exp));
 678
 679     # Pessimistically, start preparation of detailed failure message.
 680     my ($details) = "";
 681     $details .= "$test actual output:\n";
 682     $details .= join ('', map ("  $_", @actual));
 683
 684     # Set true when we find expected output that matches our actual
 685     # output except for some extra actual output (that doesn't seem to
 686     # be an error message etc.).
 687     my ($fuzzy_match) = 0;
 688
 689     # Compare actual output against each allowed output.
 690     while (@exp != 0) {
 691         # Grab one set of allowed output from @exp into @expected.
 692         my (@expected);
 693         while (@exp != 0) {
 694             my ($s) = shift (@exp);
 695             last if $s eq "--OR--\n";
 696             push (@expected, $s);
 697         }
 698
 699         $details .= "\n$test acceptable output:\n";
 700         $details .= join ('', map ("  $_", @expected));
 701
 702         # Check whether actual and expected match.
 703         # If it's a perfect match, return.
 704         if ($#actual == $#expected) {
 705             my ($eq) = 1;
 706             for (my ($i) = 0; $i <= $#expected; $i++) {
 707                 $eq = 0 if $actual[$i] ne $expected[$i];
 708             }
 709             return if $eq;
 710         }
 711
 712         # They differ.  Output a diff.
 713         my (@diff) = "";
 714         my ($d) = Algorithm::Diff->new (\@expected, \@actual);
 715         my ($not_fuzzy_match) = 0;
 716         while ($d->Next ()) {
 717             my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
 718             if ($d->Same ()) {
 719                 push (@diff, map ("  $_", $d->Items (1)));
 720             } else {
 721                 push (@diff, map ("- $_", $d->Items (1))) if $d->Items (1);
 722                 push (@diff, map ("+ $_", $d->Items (2))) if $d->Items (2);
 723                 if ($d->Items (1)
 724                     || grep (/\($test\)|exit\(-?\d+\)|dying due to|Page fault/,
 725                              $d->Items (2))) {
 726                     $not_fuzzy_match = 1;
 727                 }
 728             }
 729         }
 730
 731         # If we didn't find anything that means it's not,
 732         # it's a fuzzy match.
 733         $fuzzy_match = 1 if !$not_fuzzy_match;
 734
 735         $details .= "Differences in `diff -u' format:\n";
 736         $details .= join ('', @diff);
 737         $details .= "(This is considered a `fuzzy match'.)\n"
 738             if !$not_fuzzy_match;
 739     }
 740
 741     # Failed to match.  Report failure.
 742     if ($fuzzy_match) {
 743         $details =
 744             "This test passed, but with extra, unexpected output.\n"
 745             . "Please inspect your code to make sure that it does not\n"
 746             . "produce output other than as specified in the project\n"
 747             . "description.\n\n"
 748             . "$details";
 749     } else {
 750         $details =
 751             "This test failed because its output did not match any\n"
 752             . "of the acceptable form(s).\n\n"
 753             . "$details";
 754     }
 755
 756     $details{$test} = $details;
 757     die "Output differs from expected.  Details at end of file.\n"
 758         unless $fuzzy_match;
 759 }
 760 \f
 761 # Reads and returns the contents of the specified file.
 762 # In an array context, returns the file's contents as an array of
 763 # lines, omitting new-lines.
 764 # In a scalar context, returns the file's contents as a single string.
 765 sub snarf {
 766     my ($file) = @_;
 767     open (OUTPUT, $file) or die "$file: open: $!\n";
 768     my (@lines) = <OUTPUT>;
 769     chomp (@lines);
 770     close (OUTPUT);
 771     return wantarray ? @lines : join ('', map ("$_\n", @lines));
 772 }
 773
 774 # Returns true if the two specified files are byte-for-byte identical,
 775 # false otherwise.
 776 sub files_equal {
 777     my ($a, $b) = @_;
 778     my ($equal);
 779     open (A, "<$a") or die "$a: open: $!\n";
 780     open (B, "<$b") or die "$b: open: $!\n";
 781     if (-s A != -s B) {
 782         $equal = 0;
 783     } else {
 784         my ($sa, $sb);
 785         for (;;) {
 786             sysread (A, $sa, 1024);
 787             sysread (B, $sb, 1024);
 788             $equal = 0, last if $sa ne $sb;
 789             $equal = 1, last if $sa eq '';
 790         }
 791     }
 792     close (A);
 793     close (B);
 794     return $equal;
 795 }
 796
 797 # Returns true if the specified file is byte-for-byte identical with
 798 # the specified string.
 799 sub file_contains {
 800     my ($file, $expected) = @_;
 801     open (FILE, "<$file") or die "$file: open: $!\n";
 802     my ($actual);
 803     sysread (FILE, $actual, -s FILE);
 804     my ($equal) = $actual eq $expected;
 805     close (FILE);
 806     return $equal;
 807 }
 808
 809 1;