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

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