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