From 4a78889ac2a99d515119aa599d640fc81e9ba833 Mon Sep 17 00:00:00 2001 From: Ben Pfaff Date: Fri, 10 Dec 2004 02:02:12 +0000 Subject: [PATCH] Clean up grading scripts. --- grading/filesys/run-tests | 74 +- grading/lib/Pintos/Grading.pm | 187 ++--- grading/threads/panic.diff | 20 - grading/threads/run-tests | 517 +------------ grading/userprog/panic.diff | 20 - .../patches/00random.patch} | 8 +- grading/userprog/run-tests | 685 ++--------------- grading/vm/panic.diff | 20 - .../random.diff => vm/patches/00random.patch} | 8 +- grading/vm/run-tests | 693 +----------------- 10 files changed, 275 insertions(+), 1957 deletions(-) delete mode 100644 grading/threads/panic.diff delete mode 100644 grading/userprog/panic.diff rename grading/{vm/random.diff => userprog/patches/00random.patch} (71%) delete mode 100644 grading/vm/panic.diff rename grading/{userprog/random.diff => vm/patches/00random.patch} (71%) diff --git a/grading/filesys/run-tests b/grading/filesys/run-tests index 7e7b0e9..0f1f8eb 100755 --- a/grading/filesys/run-tests +++ b/grading/filesys/run-tests @@ -1,7 +1,7 @@ #! /usr/bin/perl # Find the directory that contains the grading files. -use vars qw($GRADES_DIR); +our ($GRADES_DIR); # Add our Perl library directory to the include path. BEGIN { @@ -15,10 +15,9 @@ use strict; use Pintos::Grading; our ($hw) = "filesys"; -our ($verbose) = 0; # Verbosity of output our (@TESTS); # Tests to run. -our ($clean) = 0; -our ($grade) = 0; +our ($test); +our ($action); parse_cmd_line (); @@ -39,27 +38,60 @@ parse_cmd_line (); syn-remove syn-read syn-write syn-rw ) unless @TESTS > 0; -compose_final_grade (), exit 0 if $grade; -clean_dir (), exit 0 if $clean; +clean_dir (), exit if $action eq 'clean'; -# Create output directory, if it doesn't already exist. --d ("output") || mkdir ("output") or die "output: mkdir: $!\n"; +extract_sources (); +exit if $action eq 'extract'; -# Extract submission. -obtain_sources (); +build (); +exit if $action eq 'build'; -# 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. -run_and_grade_tests (); - -# Write output. -write_grades (); +run_and_grade_tests (); +write_grades (); write_details (); +exit if $action eq 'test'; + +assemble_final_grade (); +exit if $action eq 'assemble'; + +die "Don't know how to '$action'"; + +# Runs $test in directory output/$test. +# Returns 'ok' if it went ok, otherwise an explanation. +sub run_test { + my ($result); + + 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/$hw/build/os.dsk " + . "--fs-disk=output/$test/fs.dsk " + . "--swap-disk=output/$test/swap.dsk " + . "-v"; + $result = run_pintos ("$pintos_base_cmd put -f $GRADES_DIR/$test $test", + LOG => "$test/put", TIMEOUT => 60); + return $result if $result ne 'ok'; + + 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) { + $result = run_pintos ("$pintos_base_cmd put $GRADES_DIR/$fn $fn", + LOG => "$test/put-$fn", TIMEOUT => 60); + return "Error running `put $fn': $result" if $result ne 'ok'; + } + + # Run. + return run_pintos ("$pintos_base_cmd run -q -ex \"$test\"", + LOG => "$test/run", TIMEOUT => 120); +} sub grade_dir_lsdir { my (@output) = @_; diff --git a/grading/lib/Pintos/Grading.pm b/grading/lib/Pintos/Grading.pm index 200b779..3411b63 100644 --- a/grading/lib/Pintos/Grading.pm +++ b/grading/lib/Pintos/Grading.pm @@ -5,13 +5,11 @@ our ($test); our ($GRADES_DIR); our ($verbose); -our (%args); our %result; our %details; our %extra; our @TESTS; -our $clean; -our $grade; +our $action; our $hw; use POSIX; @@ -21,27 +19,65 @@ use Algorithm::Diff; sub parse_cmd_line { GetOptions ("v|verbose+" => \$verbose, "h|help" => sub { usage (0) }, - "t|test=s" => \@TESTS, - "c|clean" => \$clean, - "g|grade" => \$grade) + "T|tests=s" => \@TESTS, + "c|clean" => sub { set_action ('clean'); }, + "x|extract" => sub { set_action ('extract'); }, + "b|build" => sub { set_action ('build'); }, + "t|test" => sub { set_action ('test'); }, + "a|assemble" => sub { set_action ('assemble'); }) or die "Malformed command line; use --help for help.\n"; die "Non-option argument not supported; use --help for help.\n" if @ARGV > 0; + @TESTS = split(/,/, join (',', @TESTS)) if defined @TESTS; + + if (!defined $action) { + $action = -e 'review.txt' ? 'assemble' : 'test'; + } +} + +sub set_action { + my ($new_action) = @_; + die "actions `$action' and `$new_action' conflict\n" + if defined ($action) && $action ne $new_action; + $action = $new_action; } sub usage { my ($exitcode) = @_; - print "run-tests, for grading Pintos projects.\n\n"; - print "Invoke from a directory containing a student tarball named by\n"; - print "the submit script, e.g. username.MMM.DD.YY.hh.mm.ss.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"; + print < "make") - or return "compile error"; + xsystem ("cd pintos/src/$hw && make", LOG => "make") eq 'ok' + or return "Build error"; } # Run and grade the tests. @@ -137,15 +175,15 @@ sub run_and_grade_tests { for $test (@TESTS) { print "$test: "; my ($result) = get_test_result (); - if ($result eq 'ok') { - $result = grade_test ($test); - } elsif ($result =~ /^Timed out/) { - $result = "$result - " . grade_test ($test); - } chomp ($result); - print "$result"; - print " - with warnings" if $result eq 'ok' && defined $details{$test}; - print "\n"; + + my ($grade) = grade_test ($test); + chomp ($grade); + + my ($msg) = $result eq 'ok' ? $grade : "$result - $grade"; + $msg .= " - with warnings" + if $grade eq 'ok' && defined $details{$test}; + print "$msg\n"; $result{$test} = $result; } @@ -330,9 +368,16 @@ sub get_test_result { rename "output/$test", "output/$test.old" or die "rename: $!\n" if -d "output/$test"; + # Make output directory. + mkdir "output/$test"; + # Run the test. my ($result) = run_test ($test); + # Delete any disks in the output directory because they take up + # lots of space. + unlink (glob ("output/$test/*.dsk")); + # Save the results for later. open (DONE, ">$cache_file") or die "$cache_file: create: $!\n"; print DONE "$result\n"; @@ -341,59 +386,14 @@ sub get_test_result { return $result; } -# Creates an output directory for the test, -# creates all the files needed -sub run_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) ne 'ok'; - - 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) - ne 'ok'; - } - - # Run. - my ($timeout) = 120; - my ($testargs) = defined ($args{$test}) ? " $args{$test}" : ""; - my ($retval) = - xsystem ("$pintos_base_cmd run -q -ex \"$test$testargs\"", - LOG => "$test/run", TIMEOUT => $timeout, EXPECT => 1); - my ($result); - if ($retval eq 'ok') { - $result = "ok"; - } elsif ($retval eq 'timeout') { - $result = "Timed out after $timeout seconds"; - } elsif ($retval eq 'error') { - $result = "Bochs error"; - } else { - die; - } - unlink ("output/$test/fs.dsk", "output/$test/swap.dsk"); - return $result; +sub run_pintos { + my ($cmd_line, %args) = @_; + $args{EXPECT} = 1 unless defined $args{EXPECT}; + my ($retval) = xsystem ($cmd_line, %args); + return 'ok' if $retval eq 'ok'; + return "Timed out after $args{TIMEOUT} seconds" if $retval eq 'timeout'; + return 'Error running Bochs' if $retval eq 'error'; + die; } # Grade the test. @@ -433,7 +433,7 @@ sub grade_test { # Do final grade. # Combines grade.txt, tests.out, review.txt, and details.out, # producing grade.out. -sub compose_final_grade { +sub assemble_final_grade { open (OUT, ">grade.out") or die "grade.out: create: $!\n"; open (GRADE, "); @@ -611,7 +617,12 @@ sub get_core_output { my ($first); for ($first = 0; $first <= $#output; $first++) { - $first++, last if $output[$first] =~ /^Executing '$test.*':$/; + my ($line) = $output[$first]; + $first++, last + if ($hw ne 'threads' && $line =~ /^Executing '$test.*':$/) + || ($hw eq 'threads' + && grep (/^Boot complete.$/, @output[0...$first - 1]) + && $line =~ /^\s*$/); } my ($last); diff --git a/grading/threads/panic.diff b/grading/threads/panic.diff deleted file mode 100644 index 6134d47..0000000 --- a/grading/threads/panic.diff +++ /dev/null @@ -1,20 +0,0 @@ -diff -up /home/blp/cs140/pintos/src/lib/debug.c.\~1.8.\~ /home/blp/cs140/pintos/src/lib/debug.c ---- /home/blp/cs140/pintos/src/lib/debug.c.~1.8.~ 2004-09-12 13:14:11.000000000 -0700 -+++ /home/blp/cs140/pintos/src/lib/debug.c 2004-10-17 00:02:32.000000000 -0700 -@@ -5,6 +5,7 @@ - #include - #include - #ifdef KERNEL -+#include "threads/init.h" - #include "threads/interrupt.h" - #include "devices/serial.h" - #else -@@ -83,7 +84,7 @@ debug_panic (const char *file, int line, - - #ifdef KERNEL - serial_flush (); -- for (;;); -+ power_off (); - #else - exit (1); - #endif diff --git a/grading/threads/run-tests b/grading/threads/run-tests index 1a869fa..37bc659 100755 --- a/grading/threads/run-tests +++ b/grading/threads/run-tests @@ -12,39 +12,16 @@ BEGIN { use warnings; use strict; -use POSIX; -use Algorithm::Diff; -use Getopt::Long; +use Pintos::Grading; -our ($VERBOSE) = 0; # Verbosity of output +our ($hw) = "threads"; 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 thread projects.\n\n"; - print "Invoke from a directory containing a student tarball named by\n"; - print "the submit script, e.g. username.MMM.DD.YY.hh.mm.ss.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; -} +our ($test); +our (%details); +our (%result); +our ($action); + +parse_cmd_line (); # Default set of tests. @TESTS = ("alarm-single", "alarm-multiple", "alarm-zero", "alarm-negative", @@ -56,191 +33,31 @@ sub usage { "mlfqs-on", "mlfqs-off") unless @TESTS > 0; -# 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])); - } - } +clean_dir (), exit if $action eq 'clean'; - print OUT "\nOVERALL SCORE\n"; - print OUT "-------------\n"; - print OUT "$p_got points out of $p_pos total\n\n"; +extract_sources (); +exit if $action eq 'extract'; - print OUT map ("$_\n", @tests), "\n"; - print OUT map ("$_\n", @review), "\n"; +build (); +exit if $action eq 'build'; - 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"; - -# 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\n"; - - $result{$test} = $result; -} - -# MLFQS takes results from mlfqs-on and mlfqs-off. +run_and_grade_tests (); grade_mlfqs_speedup (); grade_mlfqs_priority (); - -# Write output. -write_grades (); +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]; -} +exit if $action eq 'test'; -sub extract_tarball { - my ($tarball) = choose_tarball (); +assemble_final_grade (); +exit if $action eq 'assemble'; - 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"); - - print "Patching...\n"; - xsystem ("patch -fs pintos/src/lib/debug.c < $GRADES_DIR/panic.diff", - LOG => "patch", - DIE => "patch failed\n"); -} - -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"; - $src = "$GRADES_DIR/mlfqs.c" if $test =~ /^mlfqs/; - -e $src or die "$src: stat: $!\n"; - return $src; -} - -sub test_constants { - my ($defines) = ""; - $defines .= "#define MLFQS 1\n" if $test eq 'mlfqs-on'; - return $defines; - } +die "Don't know how to '$action'"; +# Runs $test in directory output/$test. +# Returns 'ok' if it went ok, otherwise an explanation. 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 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"; - # Change constants.h if necessary. - my ($defines) = test_constants ($test); + my ($defines) = $test ne 'mlfqs-on' ? "" : "#define MLFQS 1\n"; if ($defines ne snarf ("pintos/src/constants.h")) { open (CONSTANTS, ">pintos/src/constants.h"); print CONSTANTS $defines; @@ -259,7 +76,8 @@ sub really_run_test { } # Copy in the new test.c and delete enough files to ensure a full rebuild. - my ($src) = test_source ($test); + my ($src) = "$GRADES_DIR/" . ($test !~ /^mlfqs/ ? "$test.c" : "mlfqs.c"); + -e $src or die "$src: stat: $!\n"; xsystem ("cp $src pintos/src/threads/test.c", DIE => "cp failed\n"); unlink ("pintos/src/threads/build/threads/test.o"); unlink ("pintos/src/threads/build/kernel.o"); @@ -267,44 +85,21 @@ sub really_run_test { unlink ("pintos/src/threads/build/os.dsk"); # Build. - xsystem ("cd pintos/src/threads && make", LOG => "$test/make") - or return "compile error"; + if (xsystem ("cd pintos/src/threads && make", + LOG => "$test/make") ne 'ok') { + $details{$test} = snarf ("output/$test/make.err"); + return "Compile error"; + } # Copy out files for backtraces later. xsystem ("cp pintos/src/threads/build/kernel.o output/$test"); xsystem ("cp pintos/src/threads/build/os.dsk output/$test"); # Run. - my ($timeout) = 10; - $timeout = 600 if $test =~ /^mlfqs/; - xsystem ("cd pintos/src/threads/build && pintos -v run -q", - LOG => "$test/run", - TIMEOUT => $timeout) - or return "Bochs error"; - - return "ok"; -} - -sub grade_test { - my ($test) = @_; - - my (@output) = snarf ("output/$test/run.out"); - - if (-e "$GRADES_DIR/$test.exp") { - eval { - verify_common (@output); - compare_output ("$GRADES_DIR/$test.exp", @output); - } - } else { - my ($grade_func); - ($grade_func = $test) =~ s/-/_/g; - eval "grade_$grade_func (\@output)"; - } - if ($@) { - die $@ if $@ =~ /at \S+ line \d+$/; - return $@; - } - return "ok"; + my ($timeout) = $test !~ /^mlfqs/ ? 10 : 600; + return run_pintos ("cd pintos/src/threads/build && pintos -v run -q", + LOG => "$test/run", + TIMEOUT => $timeout); } sub grade_alarm_single { @@ -539,249 +334,3 @@ sub mlfqs_stats { return (\%stats, $ticks); } - -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 output/$test/kernel.o @addrs|"); - for (;;) { - my ($function, $line); - last unless defined ($function = ); - $line = ; - chomp $function; - chomp $line; - $details .= " $function ($line)\n"; - } - } - $extra{$test} = $details; - die "Kernel panic. 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); -} - -sub compare_output { - my ($exp_file, @actual) = @_; - my (@expected) = snarf ($exp_file); - - @actual = map ("$_\n", @actual); - @expected = map ("$_\n", @expected); - - # Trim header and trailer from @actual. - while (scalar (@actual) && $actual[0] ne $expected[0]) { - shift (@actual); - } - die "First line of expected output was not present.\n" if !@actual; - while (scalar (@actual) && $actual[$#actual] ne $expected[$#expected]) { - pop (@actual); - } - die "Final line of expected output was not present.\n" if !@actual; - - # 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); - 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); - } - } - - my ($details) = ""; - $details .= "$test actual output:\n"; - $details .= join ('', map (" $_", @actual)); - $details .= "\n$test expected output:\n"; - $details .= join ('', map (" $_", @expected)); - $details .= "\nOutput differences in `diff -u' format:\n"; - $details .= join ('', @diff) . "\n"; - $details{$test} = $details; - die "Output differs from expected. Details at end of file.\n"; -} - -sub write_grades { - my (@summary) = snarf ("$GRADES_DIR/tests.txt"); - - my ($ploss) = 0; - my ($tloss) = 0; - my ($total) = 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') { - splice (@summary, $i, 1); - $i--; - } 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; - $ploss = 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'; - - my ($details) = $details{$test}; - next if !defined ($details) && ! -e "output/$test/run.out"; - - print DETAILS "\n" if $n++; - print DETAILS "--- $test details ", '-' x (50 - length ($test)); - print DETAILS "\n\n"; - - if (!defined $details) { - $details = "Output:\n\n" . snarf ("output/$test/run.out"); - } - 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}; - if (defined ($log)) { - $command = "($command) >output/$log.out 2>output/$log.err"; - } - - 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; - exec ($command), die "$command: exec: $!\n" if !$pid; - waitpid ($pid, 0); - $status = $?; - alarm 0; - }; - if ($@) { - die unless $@ eq "alarm\n"; # propagate unexpected errors - print "Timed out.\n"; - kill SIGTERM, $pid; - $status = 0; - } - - if (WIFSIGNALED ($status)) { - my ($signal) = WTERMSIG ($status); - die "Interrupted\n" if $signal == SIGINT; - print "Child terminated with signal $signal\n"; - } - - unlink ("output/$log.err") if defined ($log) && $status == 0; - - die $options{DIE} if $status != 0 && defined $options{DIE}; - - return $status == 0; -} - -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; -} diff --git a/grading/userprog/panic.diff b/grading/userprog/panic.diff deleted file mode 100644 index 6134d47..0000000 --- a/grading/userprog/panic.diff +++ /dev/null @@ -1,20 +0,0 @@ -diff -up /home/blp/cs140/pintos/src/lib/debug.c.\~1.8.\~ /home/blp/cs140/pintos/src/lib/debug.c ---- /home/blp/cs140/pintos/src/lib/debug.c.~1.8.~ 2004-09-12 13:14:11.000000000 -0700 -+++ /home/blp/cs140/pintos/src/lib/debug.c 2004-10-17 00:02:32.000000000 -0700 -@@ -5,6 +5,7 @@ - #include - #include - #ifdef KERNEL -+#include "threads/init.h" - #include "threads/interrupt.h" - #include "devices/serial.h" - #else -@@ -83,7 +84,7 @@ debug_panic (const char *file, int line, - - #ifdef KERNEL - serial_flush (); -- for (;;); -+ power_off (); - #else - exit (1); - #endif diff --git a/grading/vm/random.diff b/grading/userprog/patches/00random.patch similarity index 71% rename from grading/vm/random.diff rename to grading/userprog/patches/00random.patch index bbc1541..6e74443 100644 --- a/grading/vm/random.diff +++ b/grading/userprog/patches/00random.patch @@ -1,5 +1,9 @@ ---- bitmap.c.~1.5.~ 2004-10-06 14:29:56.000000000 -0700 -+++ bitmap.c 2004-11-03 14:35:22.000000000 -0800 +Modifies bitmap_scan() to return a random set of bits instead of the +first set. Helps to stress-test VM implementation. + +diff -u pintos/src/lib/kernel/bitmap.c~ pintos/src/lib/kernel/bitmap.c +--- pintos/src/lib/kernel/bitmap.c~ 2004-10-06 14:29:56.000000000 -0700 ++++ pintos/src/lib/kernel/bitmap.c 2004-11-03 14:35:22.000000000 -0800 @@ -1,6 +1,7 @@ #include "bitmap.h" #include diff --git a/grading/userprog/run-tests b/grading/userprog/run-tests index 8104a7f..afb9317 100755 --- a/grading/userprog/run-tests +++ b/grading/userprog/run-tests @@ -12,39 +12,15 @@ BEGIN { use warnings; use strict; -use POSIX; -use Algorithm::Diff; -use Getopt::Long; +use Pintos::Grading; -our ($VERBOSE) = 0; # Verbosity of output +our ($hw) = "userprog"; our (@TESTS); # Tests to run. -my ($clean) = 0; -my ($grade) = 0; +our ($test); +our (%extra); +our ($action); -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; -} +parse_cmd_line (); # Default set of tests. @TESTS = qw (args-argc args-argv0 args-argvn args-single args-multiple @@ -65,254 +41,51 @@ sub usage { multi-recurse multi-oom multi-child-fd ) unless @TESTS > 0; -our (%args); -for my $key ('args-argc', 'args-argv0', 'args-argvn', 'args-multiple') { - $args{$key} = "some arguments for you!"; -} -$args{'args-single'} = "onearg"; -$args{'args-dbl-space'} = "two args"; -$args{'multi-recurse'} = "15"; -$args{'multi-oom'} = "0"; - -# 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"; +clean_dir (), exit if $action eq 'clean'; - 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); -} +extract_sources (); +exit if $action eq 'extract'; -# Create output directory, if it doesn't already exist. --d ("output") || mkdir ("output") or die "output: mkdir: $!\n"; +build (); +exit if $action eq 'build'; -# 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 (); +run_and_grade_tests (); +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]; -} +exit if $action eq 'test'; -sub extract_tarball { - my ($tarball) = choose_tarball (); +assemble_final_grade (); +exit if $action eq 'assemble'; - 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"); - xsystem ("patch -fs pintos/src/lib/kernel/bitmap.c " - . "< $GRADES_DIR/random.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; - } +die "Don't know how to '$action'"; +# Runs $test in directory output/$test. +# Returns 'ok' if it went ok, otherwise an explanation. 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/userprog && 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"; xsystem ("cp $GRADES_DIR/$test.dsk output/$test/fs.dsk", DIE => "cp failed\n"); - # Run. - my ($timeout) = 10; - $timeout = 600 if $test =~ /^multi-/; - my ($testargs) = defined ($args{$test}) ? " $args{$test}" : ""; - xsystem ("pintos " - . "--os-disk=pintos/src/userprog/build/os.dsk " - . "--fs-disk=output/$test/fs.dsk " - . "-v run -q -ex \"$test$testargs\"", - LOG => "$test/run", - TIMEOUT => $timeout) - or return "Bochs error"; - - return "ok"; -} - -sub grade_test { - my ($test) = @_; + my ($args) = ""; + $args = 'some arguments for you!' + if grep ($_ eq $test, qw(args-argc args-argv0 + args-argvn args-multiple)); + $args = 'onearg' if $test eq 'args-single'; + $args = 'two args' if $test eq 'args-dbl-space'; + $args = '15' if $test eq 'multi-recurse'; + $args = '0' if $test eq 'multi-oom'; + $args = " $args" if $args ne ''; - 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"; + # Run. + my ($timeout) = $test !~ /^multi-/ ? 10 : 600; + my ($result) = run_pintos ("pintos " + . "--os-disk=pintos/src/userprog/build/os.dsk " + . "--fs-disk=output/$test/fs.dsk " + . "-v run -q -ex \"$test$args\"", + LOG => "$test/run", + TIMEOUT => $timeout); + rename "output/$test/fs.dsk", "output/$test/fs.dsk.keep" + if $test eq 'write-normal'; + return $result; } sub grade_write_normal { @@ -350,7 +123,7 @@ sub grade_multi_oom { my (@output) = @_; verify_common (@output); - @output = fix_exit_codes (get_core_output (@output)); + @output = canonicalize_exit_codes (get_core_output (@output)); my ($n) = 0; while (my ($m) = $output[0] =~ /^\(multi-oom\) begin (\d+)$/) { die "Child process $m started out of order.\n" if $m != $n; @@ -386,373 +159,13 @@ sub grade_multi_oom { sub get_file { my ($guest_fn, $host_fn) = @_; - xsystem ("pintos " - . "--os-disk=pintos/src/userprog/build/os.dsk " - . "--fs-disk=output/$test/fs.dsk " - . "-v get $guest_fn $host_fn", - LOG => "$test/get-$guest_fn", - TIMEOUT => 10) - or die "get $guest_fn failed\n"; -} - - -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/userprog/build/kernel.o @addrs|"); - for (;;) { - my ($function, $line); - last unless defined ($function = ); - $line = ; - chomp $function; - chomp $line; - $details .= " $function ($line)\n"; - } - } - $extra{$test} = $details; - die "Kernel panic. Details at end of file.\n" - } - - if (grep (/Pintos booting/, @output) > 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) = @_; - - # Fix up 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...$#output) { - 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]+)/) -) { - $process = substr ($process, 0, 15); - $process =~ s/\s.*//; - $output[$i] = "$process: exit($code)\n"; - } - } - - return @output; -} - -sub compare_output { - my ($exp, @actual) = @_; - @actual = fix_exit_codes (get_core_output (map ("$_\n", @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+\)/, $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) { - $details = "Output:\n\n" . snarf ("output/$test/run.out"); - } - 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}; - if (defined ($log)) { - $command = "($command) >output/$log.out 2>output/$log.err"; - } - - 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; - exec ($command), die "$command: exec: $!\n" if !$pid; - waitpid ($pid, 0); - $status = $?; - alarm 0; - }; - if ($@) { - die unless $@ eq "alarm\n"; # propagate unexpected errors - print "Timed out.\n"; - kill SIGTERM, $pid; - $status = 0; - } - - if (WIFSIGNALED ($status)) { - my ($signal) = WTERMSIG ($status); - die "Interrupted\n" if $signal == SIGINT; - print "Child terminated with signal $signal\n"; - } - - unlink ("output/$log.err") if defined ($log) && $status == 0; - - die $options{DIE} if $status != 0 && defined $options{DIE}; - - return $status == 0; -} - -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; + my ($result) = run_pintos ("pintos " + . "--os-disk=pintos/src/userprog/build/os.dsk " + . "--fs-disk=output/$test/fs.dsk.keep " + . "-v get $guest_fn $host_fn", + LOG => "$test/get-$guest_fn", + TIMEOUT => 10, + EXPECT => 0); + die "`pintos get $guest_fn' failed - $result\n" + if $result ne 'ok'; } diff --git a/grading/vm/panic.diff b/grading/vm/panic.diff deleted file mode 100644 index 6134d47..0000000 --- a/grading/vm/panic.diff +++ /dev/null @@ -1,20 +0,0 @@ -diff -up /home/blp/cs140/pintos/src/lib/debug.c.\~1.8.\~ /home/blp/cs140/pintos/src/lib/debug.c ---- /home/blp/cs140/pintos/src/lib/debug.c.~1.8.~ 2004-09-12 13:14:11.000000000 -0700 -+++ /home/blp/cs140/pintos/src/lib/debug.c 2004-10-17 00:02:32.000000000 -0700 -@@ -5,6 +5,7 @@ - #include - #include - #ifdef KERNEL -+#include "threads/init.h" - #include "threads/interrupt.h" - #include "devices/serial.h" - #else -@@ -83,7 +84,7 @@ debug_panic (const char *file, int line, - - #ifdef KERNEL - serial_flush (); -- for (;;); -+ power_off (); - #else - exit (1); - #endif diff --git a/grading/userprog/random.diff b/grading/vm/patches/00random.patch similarity index 71% rename from grading/userprog/random.diff rename to grading/vm/patches/00random.patch index bbc1541..6e74443 100644 --- a/grading/userprog/random.diff +++ b/grading/vm/patches/00random.patch @@ -1,5 +1,9 @@ ---- bitmap.c.~1.5.~ 2004-10-06 14:29:56.000000000 -0700 -+++ bitmap.c 2004-11-03 14:35:22.000000000 -0800 +Modifies bitmap_scan() to return a random set of bits instead of the +first set. Helps to stress-test VM implementation. + +diff -u pintos/src/lib/kernel/bitmap.c~ pintos/src/lib/kernel/bitmap.c +--- pintos/src/lib/kernel/bitmap.c~ 2004-10-06 14:29:56.000000000 -0700 ++++ pintos/src/lib/kernel/bitmap.c 2004-11-03 14:35:22.000000000 -0800 @@ -1,6 +1,7 @@ #include "bitmap.h" #include diff --git a/grading/vm/run-tests b/grading/vm/run-tests index 108821f..c04faea 100755 --- a/grading/vm/run-tests +++ b/grading/vm/run-tests @@ -12,39 +12,14 @@ BEGIN { use warnings; use strict; -use POSIX; -use Algorithm::Diff; -use Getopt::Long; +use Pintos::Grading; -our ($verbose) = 0; # Verbosity of output +our ($hw) = "vm"; our (@TESTS); # Tests to run. -my ($clean) = 0; -my ($grade) = 0; +our ($test); +our ($action); -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; -} +parse_cmd_line (); # Default set of tests. @TESTS = qw (pt-grow-stack pt-big-stk-obj pt-bad-addr pt-write-code @@ -53,250 +28,41 @@ sub usage { mmap-twice mmap-write mmap-exit mmap-shuffle ) 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])); - } - } +clean_dir (), exit if $action eq 'clean'; - 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); -} +extract_sources (); +exit if $action eq 'extract'; -# Create output directory, if it doesn't already exist. --d ("output") || mkdir ("output") or die "output: mkdir: $!\n"; +build (); +exit if $action eq 'build'; -# 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 (); +run_and_grade_tests (); +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"); - } +exit if $action eq 'test'; - print "Patching...\n"; - xsystem ("patch -fs pintos/src/lib/debug.c < $GRADES_DIR/panic.diff", - LOG => "patch", - DIE => "patch failed\n"); - xsystem ("patch -fs pintos/src/lib/kernel/bitmap.c " - . "< $GRADES_DIR/random.diff", - LOG => "patch", - DIE => "patch failed\n"); +assemble_final_grade (); +exit if $action eq 'assemble'; - 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; - } +die "Don't know how to '$action'"; +# Runs $test in directory output/$test. +# Returns 'ok' if it went ok, otherwise an explanation. 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/vm && 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"; + # Set up output directory. xsystem ("cp $GRADES_DIR/$test.dsk output/$test/fs.dsk", DIE => "cp failed\n"); xsystem ("pintos make-disk output/$test/swap.dsk 2 >/dev/null 2>&1", DIE => "failed to create swap disk"); # Run. - my ($timeout) = 600; - my ($testargs) = defined ($args{$test}) ? " $args{$test}" : ""; - my ($result) = xsystem ("pintos " - . "--os-disk=pintos/src/vm/build/os.dsk " - . "--fs-disk=output/$test/fs.dsk " - . "--swap-disk=output/$test/swap.dsk " - . "-v 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"; + return run_pintos ("pintos " + . "--os-disk=pintos/src/vm/build/os.dsk " + . "--fs-disk=output/$test/fs.dsk " + . "--swap-disk=output/$test/swap.dsk " + . "-v run -q -ex \"$test\"", + LOG => "$test/run", + TIMEOUT => 600); } sub grade_process_death { @@ -305,11 +71,11 @@ sub grade_process_death { 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"; + if $output[0] ne "($proc_name) begin"; die "Output contains `FAIL' message.\n" - if grep (/FAIL/, @output); + if grep (/FAIL/, @output); die "Output contains spurious ($proc_name) message.\n" - if grep (/\($proc_name\)/, @output) > 1; + if grep (/\($proc_name\)/, @output) > 1; } sub grade_pt_bad_addr { @@ -323,404 +89,3 @@ sub grade_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/vm/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; - } - - unlink ("output/$log.err") if defined ($log) && $ok; - - die $options{DIE} if !$ok && defined $options{DIE}; - - 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; -} -- 2.30.2