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         $result = $status == 0 ? "ok" : "error";
 349     }
 350
 351     if ($result eq 'error' && defined $options{DIE}) {
 352         my ($msg) = $options{DIE};
 353         if (defined ($log)) {
 354             chomp ($msg);
 355             $msg .= "; see output/$log.err and output/$log.out for details\n";
 356         }
 357         die $msg;
 358     } elsif ($result ne 'error' && defined ($log)) {
 359         unlink ("output/$log.err");
 360     }
 361
 362     return $result;
 363 }
 364 \f
 365 sub get_test_result {
 366     my ($cache_file) = "output/$test/run.result";
 367     # Reuse older results if any.
 368     if (open (RESULT, "<$cache_file")) {
 369         my ($result);
 370         $result = <RESULT>;
 371         chomp $result;
 372         close (RESULT);
 373         return $result;
 374     }
 375
 376     # If there's residue from an earlier test, move it to .old.
 377     # If there's already a .old, delete it.
 378     xsystem ("rm -rf output/$test.old", VERBOSE => 1) if -d "output/$test.old";
 379     rename "output/$test", "output/$test.old" or die "rename: $!\n"
 380         if -d "output/$test";
 381
 382     # Make output directory.
 383     mkdir "output/$test";
 384
 385     # Run the test.
 386     my ($result) = run_test ($test);
 387
 388     # Delete any disks in the output directory because they take up
 389     # lots of space.
 390     unlink (glob ("output/$test/*.dsk"));
 391
 392     # Save the results for later.
 393     open (DONE, ">$cache_file") or die "$cache_file: create: $!\n";
 394     print DONE "$result\n";
 395     close (DONE);
 396
 397     return $result;
 398 }
 399
 400 sub run_pintos {
 401     my ($cmd_line, %args) = @_;
 402     my ($retval) = xsystem ($cmd_line, %args);
 403     return 'ok' if $retval eq 'ok';
 404     return "Timed out after $args{TIMEOUT} seconds" if $retval eq 'timeout';
 405     return 'Error running Bochs' if $retval eq 'error';
 406     die;
 407 }
 408
 409 # Grade the test.
 410 sub grade_test {
 411     # Read test output.
 412     my ($outfile) = "output/$test/run.out";
 413     die "$outfile: missing test output file (make failed?)" if ! -e $outfile;
 414     my (@output) = snarf ($outfile);
 415
 416     # If there's a function "grade_$test", use it to evaluate the output.
 417     # If there's a file "$GRADES_DIR/$test.exp", compare its contents
 418     # against the output.
 419     # (If both exist, prefer the function.)
 420     #
 421     # If the test was successful, it returns normally.
 422     # If it failed, it invokes `die' with an error message terminated
 423     # by a new-line.  The message will be given as an explanation in
 424     # the output file tests.out.
 425     # (Internal errors will invoke `die' without a terminating
 426     # new-line, in which case we detect it and propagate the `die'
 427     # upward.)
 428     my ($grade_func) = "grade_$test";
 429     $grade_func =~ s/-/_/g;
 430     if (-e "$GRADES_DIR/$test.exp" && !defined (&$grade_func)) {
 431         eval {
 432             verify_common (@output);
 433             compare_output ("$GRADES_DIR/$test.exp", @output);
 434         }
 435     } else {
 436         eval "$grade_func (\@output)";
 437     }
 438     if ($@) {
 439         die $@ if $@ =~ /at \S+ line \d+$/;
 440         return $@;
 441     }
 442     return "ok";
 443 }
 444 \f
 445 # Do final grade.
 446 # Combines grade.txt, tests.out, review.txt, and details.out,
 447 # producing grade.out.
 448 sub assemble_final_grade {
 449     open (OUT, ">grade.out") or die "grade.out: create: $!\n";
 450
 451     open (GRADE, "<grade.txt") or die "grade.txt: open: $!\n";
 452     while (<GRADE>) {
 453         last if /^\s*$/;
 454         print OUT;
 455     }
 456     close (GRADE);
 457
 458     my (@tests) = snarf ("tests.out");
 459     my ($p_got, $p_pos) = $tests[0] =~ m%\((\d+)/(\d+)\)% or die;
 460
 461     my (@review) = snarf ("review.txt");
 462     my ($part_lost) = (0, 0);
 463     for (my ($i) = $#review; $i >= 0; $i--) {
 464         local ($_) = $review[$i];
 465         if (my ($loss) = /^\s*([-+]\d+)/) {
 466             $part_lost += $loss;
 467         } elsif (my ($out_of) = m%\[\[/(\d+)\]\]%) {
 468             my ($got) = $out_of + $part_lost;
 469             $got = 0 if $got < 0;
 470             $review[$i] =~ s%\[\[/\d+\]\]%($got/$out_of)% or die;
 471             $part_lost = 0;
 472
 473             $p_got += $got;
 474             $p_pos += $out_of;
 475         }
 476     }
 477     die "Lost points outside a section\n" if $part_lost;
 478
 479     for (my ($i) = 1; $i <= $#review; $i++) {
 480         if ($review[$i] =~ /^-{3,}\s*$/ && $review[$i - 1] !~ /^\s*$/) {
 481             $review[$i] = '-' x (length ($review[$i - 1]));
 482         }
 483     }
 484
 485     print OUT "\nOVERALL SCORE\n";
 486     print OUT "-------------\n";
 487     print OUT "$p_got points out of $p_pos total\n\n";
 488
 489     print OUT map ("$_\n", @tests), "\n";
 490     print OUT map ("$_\n", @review), "\n";
 491
 492     print OUT "DETAILS\n";
 493     print OUT "-------\n\n";
 494     print OUT map ("$_\n", snarf ("details.out"));
 495 }
 496 \f
 497 # Clean up our generated files.
 498 sub clean_dir {
 499     # Verify that we're roughly in the correct directory
 500     # before we go blasting away files.
 501     choose_tarball ();
 502
 503     # Blow away everything.
 504     xsystem ("rm -rf output pintos", VERBOSE => 1);
 505     xsystem ("rm -f details.out tests.out", VERBOSE => 1);
 506 }
 507 \f
 508 # Provided a test's output as an array, verifies that it, in general,
 509 # looks sensible; that is, that there are no PANIC or FAIL messages,
 510 # that Pintos started up and shut down normally, and so on.
 511 # Die if something odd found.
 512 sub verify_common {
 513     my (@output) = @_;
 514
 515     die "No output at all\n" if @output == 0;
 516
 517     look_for_panic (@output);
 518     look_for_fail (@output);
 519     look_for_triple_fault (@output);
 520
 521     die "Didn't start up properly: no \"Pintos booting\" startup message\n"
 522         if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
 523     die "Didn't start up properly: no \"Boot complete\" startup message\n"
 524         if !grep (/Boot complete/, @output);
 525     die "Didn't shut down properly: no \"Timer: # ticks\" shutdown message\n"
 526         if !grep (/Timer: \d+ ticks/, @output);
 527     die "Didn't shut down properly: no \"Powering off\" shutdown message\n"
 528         if !grep (/Powering off/, @output);
 529 }
 530
 531 sub look_for_panic {
 532     my (@output) = @_;
 533
 534     my ($panic) = grep (/PANIC/, @output);
 535     return unless defined $panic;
 536
 537     my ($details) = "Kernel panic:\n  $panic\n";
 538
 539     my (@stack_line) = grep (/Call stack:/, @output);
 540     if (@stack_line != 0) {
 541         $details .= "  $stack_line[0]\n\n";
 542         $details .= "Translation of backtrace:\n";
 543         my (@addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
 544
 545         my ($A2L);
 546         if (`uname -m`
 547             =~ /i.86|pentium.*|[pk][56]|nexgen|viac3|6x86|athlon.*/) {
 548             $A2L = "addr2line";
 549         } else {
 550             $A2L = "i386-elf-addr2line";
 551         }
 552         my ($kernel_o);
 553         if ($hw eq 'threads') {
 554             $kernel_o = "output/$test/kernel.o";
 555         } else {
 556             $kernel_o = "pintos/src/$hw/build/kernel.o";
 557         }
 558         open (A2L, "$A2L -fe $kernel_o @addrs|");
 559         for (;;) {
 560             my ($function, $line);
 561             last unless defined ($function = <A2L>);
 562             $line = <A2L>;
 563             chomp $function;
 564             chomp $line;
 565             $details .= "  $function ($line)\n";
 566         }
 567     }
 568
 569     if ($panic =~ /sec_no < d->capacity/) {
 570         $details .= <<EOF;
 571 \nThis assertion commonly fails when accessing a file via an inode that
 572 has been closed and freed.  Freeing an inode clears all its sector
 573 indexes to 0xcccccccc, which is not a valid sector number for disks
 574 smaller than about 1.6 TB.
 575 EOF
 576         }
 577
 578     $extra{$test} = $details;
 579     die "Kernel panic.  Details at end of file.\n";
 580 }
 581
 582 sub look_for_fail {
 583     my (@output) = @_;
 584
 585     my ($failure) = grep (/FAIL/, @output);
 586     return unless defined $failure;
 587
 588     # Eliminate uninteresting header and trailer info if possible.
 589     # The `eval' catches the `die' from get_core_output() in the "not
 590     # possible" case.
 591     eval {
 592         my (@core) = get_core_output (@output);
 593         $details{$test} = "Program output:\n\n" . join ('', map ("$_\n", @core));
 594     };
 595
 596     # Most output lines are prefixed by (test-name).  Eliminate this
 597     # from our `die' message for brevity.
 598     $failure =~ s/^\([^\)]+\)\s+//;
 599     die "$failure.  Details at end of file.\n";
 600 }
 601
 602 sub look_for_triple_fault {
 603     my (@output) = @_;
 604
 605     return unless grep (/Pintos booting/, @output) > 1;
 606
 607     my ($details) = <<EOF;
 608 Pintos spontaneously rebooted during this test.  This is most often
 609 due to unhandled page faults.  Output from initial boot through the
 610 first reboot is shown below:
 611
 612 EOF
 613
 614     my ($i) = 0;
 615     local ($_);
 616     for (@output) {
 617         $details .= "  $_\n";
 618         last if /Pintos booting/ && ++$i > 1;
 619     }
 620     $details{$test} = $details;
 621     die "Triple-fault caused spontaneous reboot(s).  "
 622         . "Details at end of file.\n";
 623 }
 624
 625 # Get @output without header or trailer.
 626 # Die if not possible.
 627 sub get_core_output {
 628     my (@output) = @_;
 629
 630     my ($first);
 631     for ($first = 0; $first <= $#output; $first++) {
 632         my ($line) = $output[$first];
 633         $first++, last
 634             if ($hw ne 'threads' && $line =~ /^Executing '$test.*':$/)
 635             || ($hw eq 'threads'
 636                 && grep (/^Boot complete.$/, @output[0...$first - 1])
 637                 && $line =~ /^\s*$/);
 638     }
 639
 640     my ($last);
 641     for ($last = $#output; $last >= 0; $last--) {
 642         $last--, last if $output[$last] =~ /^Timer: \d+ ticks$/;
 643     }
 644
 645     if ($last < $first) {
 646         my ($no_first) = $first > $#output;
 647         my ($no_last) = $last < $#output;
 648         die "Couldn't locate output.\n";
 649     }
 650
 651     return @output[$first ... $last];
 652 }
 653
 654 sub canonicalize_exit_codes {
 655     my (@output) = @_;
 656
 657     # Exit codes are supposed to be printed in the form "process: exit(code)"
 658     # but people get unfortunately creative with it.
 659     for my $i (0...$#output) {
 660         local ($_) = $output[$i];
 661
 662         my ($process, $code);
 663         if ((($process, $code) = /^([-a-z0-9 ]+):.*[ \(](-?\d+)\b\)?$/)
 664             || (($process, $code) = /^([-a-z0-9 ]+) exit\((-?\d+)\)$/)
 665             || (($process, $code)
 666                 = /^([-a-z0-9 ]+) \(.*\): exit\((-?\d+)\)$/)
 667             || (($process, $code) = /^([-a-z0-9 ]+):\( (-?\d+) \) $/)
 668             || (($code, $process) = /^shell: exit\((-?\d+)\) \| ([-a-z0-9]+)/))
 669         {
 670             # We additionally truncate to 15 character and strip all
 671             # but the first word.
 672             $process = substr ($process, 0, 15);
 673             $process =~ s/\s.*//;
 674             $output[$i] = "$process: exit($code)\n";
 675         }
 676     }
 677
 678     return @output;
 679 }
 680
 681 sub strip_exit_codes {
 682     return grep (!/^[-a-z0-9]+: exit\(-?\d+\)/, canonicalize_exit_codes (@_));
 683 }
 684
 685 sub compare_output {
 686     my ($exp, @actual) = @_;
 687
 688     # Canonicalize output for comparison.
 689     @actual = get_core_output (map ("$_\n", @actual));
 690     if ($hw eq 'userprog') {
 691         @actual = canonicalize_exit_codes (@actual);
 692     } elsif ($hw eq 'vm' || $hw eq 'filesys') {
 693         @actual = strip_exit_codes (@actual);
 694     }
 695
 696     # There *was* some output, right?
 697     die "Program produced no output.\n" if !@actual;
 698
 699     # Read expected output.
 700     my (@exp) = map ("$_\n", snarf ($exp));
 701
 702     # Pessimistically, start preparation of detailed failure message.
 703     my ($details) = "";
 704     $details .= "$test actual output:\n";
 705     $details .= join ('', map ("  $_", @actual));
 706
 707     # Set true when we find expected output that matches our actual
 708     # output except for some extra actual output (that doesn't seem to
 709     # be an error message etc.).
 710     my ($fuzzy_match) = 0;
 711
 712     # Compare actual output against each allowed output.
 713     while (@exp != 0) {
 714         # Grab one set of allowed output from @exp into @expected.
 715         my (@expected);
 716         while (@exp != 0) {
 717             my ($s) = shift (@exp);
 718             last if $s eq "--OR--\n";
 719             push (@expected, $s);
 720         }
 721
 722         $details .= "\n$test acceptable output:\n";
 723         $details .= join ('', map ("  $_", @expected));
 724
 725         # Check whether actual and expected match.
 726         # If it's a perfect match, return.
 727         if ($#actual == $#expected) {
 728             my ($eq) = 1;
 729             for (my ($i) = 0; $i <= $#expected; $i++) {
 730                 $eq = 0 if $actual[$i] ne $expected[$i];
 731             }
 732             return if $eq;
 733         }
 734
 735         # They differ.  Output a diff.
 736         my (@diff) = "";
 737         my ($d) = Algorithm::Diff->new (\@expected, \@actual);
 738         my ($not_fuzzy_match) = 0;
 739         while ($d->Next ()) {
 740             my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
 741             if ($d->Same ()) {
 742                 push (@diff, map ("  $_", $d->Items (1)));
 743             } else {
 744                 push (@diff, map ("- $_", $d->Items (1))) if $d->Items (1);
 745                 push (@diff, map ("+ $_", $d->Items (2))) if $d->Items (2);
 746                 if ($d->Items (1)
 747                     || grep (/\($test\)|exit\(-?\d+\)|dying due to|Page fault/,
 748                              $d->Items (2))) {
 749                     $not_fuzzy_match = 1;
 750                 }
 751             }
 752         }
 753
 754         # If we didn't find anything that means it's not,
 755         # it's a fuzzy match.
 756         $fuzzy_match = 1 if !$not_fuzzy_match;
 757
 758         $details .= "Differences in `diff -u' format:\n";
 759         $details .= join ('', @diff);
 760         $details .= "(This is considered a `fuzzy match'.)\n"
 761             if !$not_fuzzy_match;
 762     }
 763
 764     # Failed to match.  Report failure.
 765     if ($fuzzy_match) {
 766         $details =
 767             "This test passed, but with extra, unexpected output.\n"
 768             . "Please inspect your code to make sure that it does not\n"
 769             . "produce output other than as specified in the project\n"
 770             . "description.\n\n"
 771             . "$details";
 772     } else {
 773         $details =
 774             "This test failed because its output did not match any\n"
 775             . "of the acceptable form(s).\n\n"
 776             . "$details";
 777     }
 778
 779     $details{$test} = $details;
 780     die "Output differs from expected.  Details at end of file.\n"
 781         unless $fuzzy_match;
 782 }
 783 \f
 784 # Reads and returns the contents of the specified file.
 785 # In an array context, returns the file's contents as an array of
 786 # lines, omitting new-lines.
 787 # In a scalar context, returns the file's contents as a single string.
 788 sub snarf {
 789     my ($file) = @_;
 790     open (OUTPUT, $file) or die "$file: open: $!\n";
 791     my (@lines) = <OUTPUT>;
 792     chomp (@lines);
 793     close (OUTPUT);
 794     return wantarray ? @lines : join ('', map ("$_\n", @lines));
 795 }
 796
 797 # Returns true if the two specified files are byte-for-byte identical,
 798 # false otherwise.
 799 sub files_equal {
 800     my ($a, $b) = @_;
 801     my ($equal);
 802     open (A, "<$a") or die "$a: open: $!\n";
 803     open (B, "<$b") or die "$b: open: $!\n";
 804     if (-s A != -s B) {
 805         $equal = 0;
 806     } else {
 807         my ($sa, $sb);
 808         for (;;) {
 809             sysread (A, $sa, 1024);
 810             sysread (B, $sb, 1024);
 811             $equal = 0, last if $sa ne $sb;
 812             $equal = 1, last if $sa eq '';
 813         }
 814     }
 815     close (A);
 816     close (B);
 817     return $equal;
 818 }
 819
 820 # Returns true if the specified file is byte-for-byte identical with
 821 # the specified string.
 822 sub file_contains {
 823     my ($file, $expected) = @_;
 824     open (FILE, "<$file") or die "$file: open: $!\n";
 825     my ($actual);
 826     sysread (FILE, $actual, -s FILE);
 827     my ($equal) = $actual eq $expected;
 828     close (FILE);
 829     return $equal;
 830 }
 831 \f
 832 sub success {
 833     for my $test (@TESTS) {
 834         return 1 if !defined ($result{$test}) || $result{$test} ne 'ok';
 835     }
 836     return 0;
 837 }
 838
 839 1;