#! /usr/bin/perl # Find the directory that contains the grading files. our ($GRADES_DIR); # Add our Perl library directory to the include path. BEGIN { ($GRADES_DIR = $0) =~ s#/[^/]+$##; -d $GRADES_DIR or die "$GRADES_DIR: stat: $!\n"; unshift @INC, "$GRADES_DIR/../lib"; } use warnings; use strict; use POSIX; use Algorithm::Diff; use Getopt::Long; our ($verbose) = 0; # Verbosity of output our (@TESTS); # Tests to run. my ($clean) = 0; my ($grade) = 0; GetOptions ("v|verbose+" => \$verbose, "h|help" => sub { usage (0) }, "t|test=s" => \@TESTS, "c|clean" => \$clean, "g|grade" => \$grade) or die "Malformed command line; use --help for help.\n"; die "Non-option argument not supported; use --help for help.\n" if @ARGV > 0; sub usage { my ($exitcode) = @_; print "run-tests, for grading Pintos multiprogramming projects.\n\n"; print "Invoke from a directory containing a student tarball named by\n"; print "the submit script, e.g. username.Oct.12.04.20.04.09.tar.gz.\n"; print "In normal usage, no options are needed.\n\n"; print "Output is produced in tests.out and details.out.\n\n"; print "Options:\n"; print " -c, --clean Remove old output files before starting\n"; print " -t, --test=TEST Execute TEST only (allowed multiple times)\n"; print " -g, --grade Instead of running tests, compose grade.out\n"; print " -v, --verbose Print commands before executing them\n"; print " -h, --help Print this help message\n"; exit $exitcode; } # Default set of tests. @TESTS = qw (sm-create sm-full sm-seq-block sm-seq-random sm-random grow-create grow-seq-sm grow-seq-lg grow-file-size grow-tell grow-sparse grow-too-big grow-root-sm grow-root-lg grow-dir-lg grow-two-files dir-mkdir dir-rmdir dir-mk-vine dir-rm-vine dir-mk-tree dir-rm-tree dir-lsdir dir-rm-cwd dir-rm-cwd-cd dir-rm-parent dir-rm-root dir-over-file dir-under-file dir-empty-name dir-open syn-remove syn-read syn-write syn-rw ) unless @TESTS > 0; our (%args); # Handle final grade mode. if ($grade) { open (OUT, ">grade.out") or die "grade.out: create: $!\n"; open (GRADE, ") { last if /^\s*$/; print OUT; } close (GRADE); my (@tests) = snarf ("tests.out"); my ($p_got, $p_pos) = $tests[0] =~ m%\((\d+)/(\d+)\)% or die; my (@review) = snarf ("review.txt"); my ($part_lost) = (0, 0); for (my ($i) = $#review; $i >= 0; $i--) { local ($_) = $review[$i]; if (my ($loss) = /^\s*([-+]\d+)/) { $part_lost += $loss; } elsif (my ($out_of) = m%\[\[/(\d+)\]\]%) { my ($got) = $out_of + $part_lost; $got = 0 if $got < 0; $review[$i] =~ s%\[\[/\d+\]\]%($got/$out_of)% or die; $part_lost = 0; $p_got += $got; $p_pos += $out_of; } } die "Lost points outside a section\n" if $part_lost; for (my ($i) = 1; $i <= $#review; $i++) { if ($review[$i] =~ /^-{3,}\s*$/ && $review[$i - 1] !~ /^\s*$/) { $review[$i] = '-' x (length ($review[$i - 1])); } } print OUT "\nOVERALL SCORE\n"; print OUT "-------------\n"; print OUT "$p_got points out of $p_pos total\n\n"; print OUT map ("$_\n", @tests), "\n"; print OUT map ("$_\n", @review), "\n"; print OUT "DETAILS\n"; print OUT "-------\n\n"; print OUT map ("$_\n", snarf ("details.out")); exit 0; } if ($clean) { # Verify that we're roughly in the correct directory # before we go blasting away files. choose_tarball (); xsystem ("rm -rf output pintos", VERBOSE => 1); xsystem ("rm -f details.out tests.out", VERBOSE => 1); } # Create output directory, if it doesn't already exist. -d ("output") || mkdir ("output") or die "output: mkdir: $!\n"; # Extract submission. extract_tarball () if ! -d "pintos"; # Compile submission. compile (); # Verify that the proper directory was submitted. -d "pintos/src/threads" or die "pintos/src/threads: stat: $!\n"; # Run and grade the tests. our $test; our %result; our %details; our %extra; for $test (@TESTS) { print "$test: "; my ($result) = run_test ($test); if ($result eq 'ok') { $result = grade_test ($test); $result =~ s/\n$//; } print "$result"; print " - with warnings" if $result eq 'ok' && defined $details{$test}; print "\n"; $result{$test} = $result; } # Write output. write_grades (); write_details (); sub choose_tarball { my (@tarballs) = grep (/^[a-z0-9]+\.[A-Za-z]+\.\d+\.\d+\.\d+\.\d+.\d+\.tar\.gz$/, glob ("*.tar.gz")); die "no pintos dir and no source tarball\n" if scalar (@tarballs) == 0; # Sort tarballs in reverse order by time. @tarballs = sort { ext_mdyHMS ($b) cmp ext_mdyHMS ($a) } @tarballs; print "Multiple tarballs: choosing $tarballs[0]\n" if scalar (@tarballs) > 1; return $tarballs[0]; } sub extract_tarball { my ($tarball) = choose_tarball (); mkdir "pintos" or die "pintos: mkdir: $!\n"; mkdir "pintos/src" or die "pintos: mkdir: $!\n"; print "Extracting $tarball...\n"; xsystem ("cd pintos/src && tar xzf ../../$tarball", DIE => "extraction failed\n"); if (-e "fixme.sh") { print "Running fixme.sh...\n"; xsystem ("sh -e fixme.sh", DIE => "fix script failed\n"); } print "Patching...\n"; xsystem ("patch -fs pintos/src/lib/debug.c < $GRADES_DIR/panic.diff", LOG => "patch", DIE => "patch failed\n"); open (CONSTANTS, ">pintos/src/constants.h") or die "constants.h: create: $!\n"; print CONSTANTS "#define THREAD_JOIN_IMPLEMENTED 1\n"; close CONSTANTS; } sub ext_mdyHMS { my ($s) = @_; my ($ms, $d, $y, $H, $M, $S) = $s =~ /.([A-Za-z]+)\.(\d+)\.(\d+)\.(\d+)\.(\d+).(\d+)\.tar\.gz$/ or die; my ($m) = index ("janfebmaraprmayjunjulaugsepoctnovdec", lc $ms) / 3 or die; return sprintf "%02d-%02d-%02d %02d:%02d:%02d", $y, $m, $d, $H, $M, $S; } sub test_source { my ($test) = @_; my ($src) = "$GRADES_DIR/$test.c"; -e $src or die "$src: stat: $!\n"; return $src; } sub test_constants { my ($defines) = ""; return $defines; } sub run_test { my ($test) = @_; # Reuse older results if any if (open (DONE, "; chomp $status; close (DONE); return $status; } # Really run the test. my ($status) = really_run_test ($test); # Save the results for later. open (DONE, ">output/$test/done") or die "output/$test/done: create: $!\n"; print DONE "$status\n"; close (DONE); return $status; } sub compile { print "Compiling...\n"; xsystem ("cd pintos/src/filesys && make", LOG => "make") or return "compile error"; } sub really_run_test { # Need to run it. # If there's residue from an earlier test, move it to .old. # If there's already a .old, delete it. xsystem ("rm -rf output/$test.old", VERBOSE => 1) if -d "output/$test.old"; rename "output/$test", "output/$test.old" or die "rename: $!\n" if -d "output/$test"; # Make output directory. mkdir "output/$test"; my ($fs_size) = $test ne 'grow-too-big' ? 2 : .25; xsystem ("pintos make-disk output/$test/fs.dsk $fs_size >/dev/null 2>&1", DIE => "failed to create file system disk"); xsystem ("pintos make-disk output/$test/swap.dsk 2 >/dev/null 2>&1", DIE => "failed to create swap disk"); # Format disk, install test. my ($pintos_base_cmd) = "pintos " . "--os-disk=pintos/src/filesys/build/os.dsk " . "--fs-disk=output/$test/fs.dsk " . "--swap-disk=output/$test/swap.dsk " . "-v"; unlink ("output/$test/fs.dsk", "output/$test/swap.dsk"), return "format/put error" if !xsystem ("$pintos_base_cmd put -f $GRADES_DIR/$test $test", LOG => "$test/put", TIMEOUT => 60, EXPECT => 1); my (@extra_files); push (@extra_files, "child-syn-read") if $test eq 'syn-read'; push (@extra_files, "child-syn-wrt") if $test eq 'syn-write'; push (@extra_files, "child-syn-rw") if $test eq 'syn-rw'; for my $fn (@extra_files) { return "format/put error" if !xsystem ("$pintos_base_cmd put $GRADES_DIR/$fn $fn", LOG => "$test/put-$fn", TIMEOUT => 60, EXPECT => 1); } # Run. my ($timeout) = 60; my ($testargs) = defined ($args{$test}) ? " $args{$test}" : ""; my ($result) = xsystem ("$pintos_base_cmd run -q -ex \"$test$testargs\"", LOG => "$test/run", TIMEOUT => $timeout, EXPECT => 1) ? "ok" : "Bochs error"; unlink ("output/$test/fs.dsk", "output/$test/swap.dsk"); return $result; } sub grade_test { my ($test) = @_; my (@output) = snarf ("output/$test/run.out"); my ($grade_func) = "grade_$test"; $grade_func =~ s/-/_/g; if (-e "$GRADES_DIR/$test.exp" && !defined (&$grade_func)) { eval { verify_common (@output); compare_output ("$GRADES_DIR/$test.exp", @output); } } else { eval "$grade_func (\@output)"; } if ($@) { die $@ if $@ =~ /at \S+ line \d+$/; return $@; } return "ok"; } sub grade_process_death { my ($proc_name, @output) = @_; verify_common (@output); @output = get_core_output (@output); die "First line of output is not `($proc_name) begin' message.\n" if $output[0] ne "($proc_name) begin"; die "Output contains `FAIL' message.\n" if grep (/FAIL/, @output); die "Output contains spurious ($proc_name) message.\n" if grep (/\($proc_name\)/, @output) > 1; } sub grade_pt_bad_addr { grade_process_death ('pt-bad-addr', @_); } sub grade_pt_write_code { grade_process_death ('pt-write-code', @_); } sub grade_mmap_unmap { grade_process_death ('mmap-unmap', @_); } sub verify_common { my (@output) = @_; my (@assertion) = grep (/PANIC/, @output); if (@assertion != 0) { my ($details) = "Kernel panic:\n $assertion[0]\n"; my (@stack_line) = grep (/Call stack:/, @output); if (@stack_line != 0) { $details .= " $stack_line[0]\n\n"; $details .= "Translation of backtrace:\n"; my (@addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/; my ($A2L); if (`uname -m` =~ /i.86|pentium.*|[pk][56]|nexgen|viac3|6x86|athlon.*/) { $A2L = "addr2line"; } else { $A2L = "i386-elf-addr2line"; } open (A2L, "$A2L -fe pintos/src/filesys/build/kernel.o @addrs|"); for (;;) { my ($function, $line); last unless defined ($function = ); $line = ; chomp $function; chomp $line; $details .= " $function ($line)\n"; } } if ($assertion[0] =~ /sec_no < d->capacity/) { $details .= < 1) { my ($details); $details = "Pintos spontaneously rebooted during this test.\n"; $details .= "This is most often due to unhandled page faults.\n"; $details .= "Here's the output from the initial boot through the\n"; $details .= "first reboot:\n\n"; my ($i) = 0; local ($_); for (@output) { $details .= " $_\n"; last if /Pintos booting/ && ++$i > 1; } $details{$test} = $details; die "Triple-fault caused spontaneous reboot(s). " . "Details at end of file.\n"; } die "No output at all\n" if @output == 0; die "Didn't start up properly: no \"Pintos booting\" startup message\n" if !grep (/Pintos booting with.*kB RAM\.\.\./, @output); die "Didn't start up properly: no \"Boot complete\" startup message\n" if !grep (/Boot complete/, @output); die "Didn't shut down properly: no \"Timer: # ticks\" shutdown message\n" if !grep (/Timer: \d+ ticks/, @output); die "Didn't shut down properly: no \"Powering off\" shutdown message\n" if !grep (/Powering off/, @output); } # Get @output without header or trailer. sub get_core_output { my (@output) = @_; our ($test); my ($first); for ($first = 0; $first <= $#output; $first++) { $first++, last if $output[$first] =~ /^Executing '$test.*':$/; } my ($last); for ($last = $#output; $last >= 0; $last--) { $last--, last if $output[$last] =~ /^Timer: \d+ ticks$/; } if ($last < $first) { my ($no_first) = $first > $#output; my ($no_last) = $last < $#output; die "Couldn't locate output.\n"; } return @output[$first ... $last]; } sub fix_exit_codes { my (@output) = @_; # Remove lines that look like exit codes. # Exit codes are supposed to be printed in the form "process: exit(code)" # but people get unfortunately creative with it. for (my ($i) = 0; $i <= $#output; $i++) { local ($_) = $output[$i]; my ($process, $code); if ((($process, $code) = /^([-a-z0-9 ]+):.*[ \(](-?\d+)\b\)?$/) || (($process, $code) = /^([-a-z0-9 ]+) exit\((-?\d+)\)$/) || (($process, $code) = /^([-a-z0-9 ]+) \(.*\): exit\((-?\d+)\)$/) || (($process, $code) = /^([-a-z0-9 ]+):\( (-?\d+) \) $/) || (($code, $process) = /^shell: exit\((-?\d+)\) \| ([-a-z0-9]+)/) ) { splice (@output, $i, 1); $i--; } } return @output; } sub compare_output { my ($exp, @actual) = @_; @actual = fix_exit_codes (get_core_output (map ("$_\n", @actual))); die "Program produced no output.\n" if !@actual; my ($details) = ""; $details .= "$test actual output:\n"; $details .= join ('', map (" $_", @actual)); my (@exp) = map ("$_\n", snarf ($exp)); my ($fuzzy_match) = 0; while (@exp != 0) { my (@expected); while (@exp != 0) { my ($s) = shift (@exp); last if $s eq "--OR--\n"; push (@expected, $s); } $details .= "\n$test acceptable output:\n"; $details .= join ('', map (" $_", @expected)); # Check whether they're the same. if ($#actual == $#expected) { my ($eq) = 1; for (my ($i) = 0; $i <= $#expected; $i++) { $eq = 0 if $actual[$i] ne $expected[$i]; } return if $eq; } # They differ. Output a diff. my (@diff) = ""; my ($d) = Algorithm::Diff->new (\@expected, \@actual); my ($not_fuzzy_match) = 0; while ($d->Next ()) { my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2)); if ($d->Same ()) { push (@diff, map (" $_", $d->Items (1))); } else { push (@diff, map ("- $_", $d->Items (1))) if $d->Items (1); push (@diff, map ("+ $_", $d->Items (2))) if $d->Items (2); if ($d->Items (1) || grep (/\($test\)|exit\(-?\d+\)|dying due to|Page fault/, $d->Items (2))) { $not_fuzzy_match = 1; } } } $fuzzy_match = 1 if !$not_fuzzy_match; $details .= "Differences in `diff -u' format:\n"; $details .= join ('', @diff); $details .= "(This is considered a `fuzzy match'.)\n" if !$not_fuzzy_match; } if ($fuzzy_match) { $details = "This test passed, but with extra, unexpected output.\n" . "Please inspect your code to make sure that it does not\n" . "produce output other than as specified in the project\n" . "description.\n\n" . "$details"; } else { $details = "This test failed because its output did not match any\n" . "of the acceptable form(s).\n\n" . "$details"; } $details{$test} = $details; die "Output differs from expected. Details at end of file.\n" unless $fuzzy_match; } sub write_grades { my (@summary) = snarf ("$GRADES_DIR/tests.txt"); my ($ploss) = 0; my ($tloss) = 0; my ($total) = 0; my ($warnings) = 0; for (my ($i) = 0; $i <= $#summary; $i++) { local ($_) = $summary[$i]; if (my ($loss, $test) = /^ -(\d+) ([-a-zA-Z0-9]+):/) { my ($result) = $result{$test} || "Not tested."; if ($result eq 'ok') { if (!defined $details{$test}) { # Test successful and no warnings. splice (@summary, $i, 1); $i--; } else { # Test successful with warnings. s/-(\d+) //; $summary[$i] = $_; splice (@summary, $i + 1, 0, " Test passed with warnings. " . "Details at end of file."); $warnings++; } } else { $ploss += $loss; $tloss += $loss; splice (@summary, $i + 1, 0, map (" $_", split ("\n", $result))); } } elsif (my ($ptotal) = /^Score: \/(\d+)$/) { $total += $ptotal; $summary[$i] = "Score: " . ($ptotal - $ploss) . "/$ptotal"; splice (@summary, $i, 0, " All tests passed.") if $ploss == 0 && !$warnings; $ploss = 0; $warnings = 0; $i++; } } my ($ts) = "(" . ($total - $tloss) . "/" . $total . ")"; $summary[0] =~ s/\[\[total\]\]/$ts/; open (SUMMARY, ">tests.out"); print SUMMARY map ("$_\n", @summary); close (SUMMARY); } sub write_details { open (DETAILS, ">details.out"); my ($n) = 0; for my $test (@TESTS) { next if $result{$test} eq 'ok' && !defined $details{$test}; my ($details) = $details{$test}; next if !defined ($details) && ! -e "output/$test/run.out"; my ($banner); if ($result{$test} ne 'ok') { $banner = "$test failure details"; } else { $banner = "$test warnings"; } print DETAILS "\n" if $n++; print DETAILS "--- $banner ", '-' x (50 - length ($banner)); print DETAILS "\n\n"; if (!defined $details) { my (@output) = snarf ("output/$test/run.out"); # Print only the first in a series of recursing panics. my ($panic) = 0; for my $i (0...$#output) { local ($_) = $output[$i]; if (/PANIC/ && $panic++ > 0) { @output = @output[0...$i]; push (@output, "[...details of recursive panic omitted...]"); last; } } $details = "Output:\n\n" . join ('', map ("$_\n", @output)); } print DETAILS $details; print DETAILS "\n", "-" x 10, "\n\n$extra{$test}" if defined $extra{$test}; } close (DETAILS); } sub xsystem { my ($command, %options) = @_; print "$command\n" if $verbose || $options{VERBOSE}; my ($log) = $options{LOG}; my ($pid, $status); eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm $options{TIMEOUT} if defined $options{TIMEOUT}; $pid = fork; die "fork: $!\n" if !defined $pid; if (!$pid) { if (defined $log) { open (STDOUT, ">output/$log.out"); open (STDERR, ">output/$log.err"); } exec ($command); exit (-1); } waitpid ($pid, 0); $status = $?; alarm 0; }; my ($ok); if ($@) { die unless $@ eq "alarm\n"; # propagate unexpected errors print "Timed out: "; for (my ($i) = 0; $i < 10; $i++) { kill ('SIGTERM', $pid); sleep (1); my ($retval) = waitpid ($pid, WNOHANG); last if $retval == $pid || $retval == -1; print "Waiting for $pid to die" if $i == 0; print "."; } $ok = 1; } else { if (WIFSIGNALED ($status)) { my ($signal) = WTERMSIG ($status); die "Interrupted\n" if $signal == SIGINT; print "Child terminated with signal $signal\n"; } my ($exp_status) = !defined ($options{EXPECT}) ? 0 : $options{EXPECT}; $ok = WIFEXITED ($status) && WEXITSTATUS ($status) == $exp_status; } if (!$ok && defined $options{DIE}) { my ($msg) = $options{DIE}; if (defined ($log)) { chomp ($msg); $msg .= "; see output/$log.err and output/$log.out for details\n"; } die $msg; } elsif (defined ($log) && $ok) { unlink ("output/$log.err"); } return $ok; } sub snarf { my ($file) = @_; open (OUTPUT, $file) or die "$file: open: $!\n"; my (@lines) = ; chomp (@lines); close (OUTPUT); return wantarray ? @lines : join ('', map ("$_\n", @lines)); } sub files_equal { my ($a, $b) = @_; my ($equal); open (A, "<$a") or die "$a: open: $!\n"; open (B, "<$b") or die "$b: open: $!\n"; if (-s A != -s B) { $equal = 0; } else { my ($sa, $sb); for (;;) { sysread (A, $sa, 1024); sysread (B, $sb, 1024); $equal = 0, last if $sa ne $sb; $equal = 1, last if $sa eq ''; } } close (A); close (B); return $equal; } sub file_contains { my ($file, $expected) = @_; open (FILE, "<$file") or die "$file: open: $!\n"; my ($actual); sysread (FILE, $actual, -s FILE); my ($equal) = $actual eq $expected; close (FILE); return $equal; } sub number_lines { my ($ln, $lines) = @_; my ($out); for my $line (@$lines) { chomp $line; $out .= sprintf "%4d %s\n", $ln++, $line; } return $out; }