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

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