X-Git-Url: https://pintos-os.org/cgi-bin/gitweb.cgi?p=pintos-anon;a=blobdiff_plain;f=src%2Ftests%2Ftests.pm;h=4599cb98fe49d7627173d182f48ce2ef072f03ab;hp=d085df1c98de59d7430a7cfc3dc9caa571f5672f;hb=59f738d500f51ffc5f487344865b8bed69c26281;hpb=615bf3b3d2a8573ed6fb9ddc0055745e163ac999

diff --git a/src/tests/tests.pm b/src/tests/tests.pm
index d085df1..4599cb9 100644
--- a/src/tests/tests.pm
+++ b/src/tests/tests.pm
@@ -1,60 +1,90 @@
 use strict;
 use warnings;
-use Algorithm::Diff;
+use tests::Algorithm::Diff;
+use File::Temp 'tempfile';
+use Fcntl qw(SEEK_SET SEEK_CUR);
 
 sub fail;
 sub pass;
 
 die if @ARGV != 2;
 our ($test, $src_dir) = @ARGV;
-our ($src_stem) = "$src_dir/$test";
 
-our ($messages) = "";
-open (MESSAGES, '>', \$messages);
-select (MESSAGES);
+my ($msg_file) = tempfile ();
+select ($msg_file);
+
+our (@prereq_tests) = ();
+if ($test =~ /^(.*)-persistence$/) {
+    push (@prereq_tests, $1);
+}
+for my $prereq_test (@prereq_tests) {
+    my (@result) = read_text_file ("$prereq_test.result");
+    fail "Prerequisite test $prereq_test failed.\n" if $result[0] ne 'PASS';
+}
+
+
+# Generic testing.
 
 sub check_expected {
     my ($expected) = pop @_;
     my (@options) = @_;
     my (@output) = read_text_file ("$test.output");
-    common_checks (@output);
-    compare_output (@options, \@output, $expected);
+    common_checks ("run", @output);
+    compare_output ("run", @options, \@output, $expected);
 }
 
 sub common_checks {
-    my (@output) = @_;
+    my ($run, @output) = @_;
 
-    fail "No output at all\n" if @output == 0;
+    fail "\u$run produced no output at all\n" if @output == 0;
 
-    check_for_panic (@output);
-    check_for_keyword ("FAIL", @output);
-    check_for_triple_fault (@output);
-    check_for_keyword ("TIMEOUT", @output);
+    check_for_panic ($run, @output);
+    check_for_keyword ($run, "FAIL", @output);
+    check_for_triple_fault ($run, @output);
+    check_for_keyword ($run, "TIMEOUT", @output);
 
-    fail "Didn't start up properly: no \"Pintos booting\" startup message\n"
+    fail "\u$run didn't start up properly: no \"Pintos booting\" message\n"
       if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
-    fail "Didn't start up properly: no \"Boot complete\" startup message\n"
+    fail "\u$run didn't start up properly: no \"Boot complete\" message\n"
       if !grep (/Boot complete/, @output);
-    fail "Didn't shut down properly: no \"Timer: # ticks\" shutdown message\n"
+    fail "\u$run didn't shut down properly: no \"Timer: # ticks\" message\n"
       if !grep (/Timer: \d+ ticks/, @output);
-    fail "Didn't shut down properly: no \"Powering off\" shutdown message\n"
+    fail "\u$run didn't shut down properly: no \"Powering off\" message\n"
       if !grep (/Powering off/, @output);
 }
 
 sub check_for_panic {
-    my (@output) = @_;
+    my ($run, @output) = @_;
 
     my ($panic) = grep (/PANIC/, @output);
     return unless defined $panic;
 
-    print "Kernel panic: ", substr ($panic, index ($panic, "PANIC")), "\n";
+    print "Kernel panic in $run: ", substr ($panic, index ($panic, "PANIC")),
+      "\n";
 
     my (@stack_line) = grep (/Call stack:/, @output);
     if (@stack_line != 0) {
-	my (@addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
-	print "Call stack: @addrs\n";
+	my ($addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
+
+	# Find a user program to translate user virtual addresses.
+	my ($userprog) = "";
+	$userprog = "$test"
+	  if grep (hex ($_) < 0xc0000000, split (' ', $addrs)) > 0 && -e $test;
+
+	# Get and print the backtrace.
+	my ($trace) = scalar (`backtrace kernel.o $userprog $addrs`);
+	print "Call stack:$addrs\n";
 	print "Translation of call stack:\n";
-	print `backtrace kernel.o @addrs`;
+	print $trace;
+
+	# Print disclaimer.
+	if ($userprog ne '' && index ($trace, $userprog) >= 0) {
+	    print <<EOF;
+Translations of user virtual addresses above are based on a guess at
+the binary to use.  If this guess is incorrect, then those
+translations will be misleading.
+EOF
+	}
     }
 
     if ($panic =~ /sec_no \< d-\>capacity/) {
@@ -70,7 +100,7 @@ EOF
 }
 
 sub check_for_keyword {
-    my ($keyword, @output) = @_;
+    my ($run, $keyword, @output) = @_;
     
     my ($kw_line) = grep (/$keyword/, @output);
     return unless defined $kw_line;
@@ -78,68 +108,88 @@ sub check_for_keyword {
     # Most output lines are prefixed by (test-name).  Eliminate this
     # from our message for brevity.
     $kw_line =~ s/^\([^\)]+\)\s+//;
-    print "$kw_line\n";
-
-    # Append output, eliminating uninteresting header and trailer info
-    # if possible.
-    my (@core) = get_core_output (@output);
-    @output = @core if @core;
-    print "Program output:\n\n" . join ('', map ("$_\n", @output));
+    print "$run: $kw_line\n";
 
     fail;
 }
 
 sub check_for_triple_fault {
-    my (@output) = @_;
+    my ($run, @output) = @_;
 
-    return unless grep (/Pintos booting/, @output) > 1;
+    my ($reboots) = grep (/Pintos booting/, @output) - 1;
+    return unless $reboots > 0;
 
     print <<EOF;
-Pintos spontaneously rebooted during this test.
-This is most often caused by unhandled page faults.  Output from
-initial boot through the first reboot is shown below:
-
+\u$run spontaneously rebooted $reboots times.
+This is most often caused by unhandled page faults.
+Read the Triple Faults section in the Debugging chapter
+of the Pintos manual for more information.
 EOF
 
-    my ($i) = 0;
-    local ($_);
-    for (@output) {
-	print "  $_\n";
-	last if /Pintos booting/ && ++$i > 1;
-    }
-
     fail;
 }
 
 # Get @output without header or trailer.
 sub get_core_output {
+    my ($run, @output) = @_;
     my ($p);
-    do { $p = shift; } while (defined ($p) && $p !~ /^Executing '.*':$/);
-    do { $p = pop; } while (defined ($p) && $p !~ /^Execution of '.*' complete.$/);
-    return @_;
+
+    my ($process);
+    my ($start);
+    for my $i (0...$#_) {
+	$start = $i + 1, last
+	  if ($process) = $output[$i] =~ /^Executing '(\S+).*':$/;
+    }
+
+    my ($end);
+    for my $i ($start...$#output) {
+	$end = $i - 1, last if $output[$i] =~ /^Execution of '.*' complete.$/;
+    }
+
+    fail "\u$run didn't start a thread or process\n" if !defined $start;
+    fail "\u$run started '$process' but it never finished\n" if !defined $end;
+
+    return @output[$start...$end];
 }
 
 sub compare_output {
+    my ($run) = shift @_;
     my ($expected) = pop @_;
     my ($output) = pop @_;
     my (%options) = @_;
 
-    my (@output) = get_core_output (@$output);
-    fail "'$test' didn't run or didn't produce any output\n" if !@output;
+    my (@output) = get_core_output ($run, @$output);
+    fail "\u$run didn't produce any output" if !@output;
 
-    if (exists $options{IGNORE_EXIT_CODES}) {
+    my $ignore_exit_codes = exists $options{IGNORE_EXIT_CODES};
+    if ($ignore_exit_codes) {
 	delete $options{IGNORE_EXIT_CODES};
-	@output = grep (!/^[a-zA-Z0-9-_]+: exit\(\d+\)$/, @output);
+	@output = grep (!/^[a-zA-Z0-9-_]+: exit\(\-?\d+\)$/, @output);
+    }
+    my $ignore_user_faults = exists $options{IGNORE_USER_FAULTS};
+    if ($ignore_user_faults) {
+	delete $options{IGNORE_USER_FAULTS};
+	@output = grep (!/^Page fault at.*in user context\.$/
+			&& !/: dying due to interrupt 0x0e \(.*\).$/
+			&& !/^Interrupt 0x0e \(.*\) at eip=/
+			&& !/^ cr2=.* error=.*/
+			&& !/^ eax=.* ebx=.* ecx=.* edx=.*/
+			&& !/^ esi=.* edi=.* esp=.* ebp=.*/
+			&& !/^ cs=.* ds=.* es=.* ss=.*/, @output);
     }
     die "unknown option " . (keys (%options))[0] . "\n" if %options;
 
-    my ($msg) = "Actual output:\n" . join ('', map ("  $_\n", @output));
+    my ($msg);
 
     # Compare actual output against each allowed output.
-    foreach my $exp_string (@$expected) {
-	my (@expected) = split ("\n", $exp_string);
+    if (ref ($expected) eq 'ARRAY') {
+	my ($i) = 0;
+	$expected = {map ((++$i => $_), @$expected)};
+    }
+    foreach my $key (keys %$expected) {
+	my (@expected) = split ("\n", $expected->{$key});
 
-	$msg .= "\nAcceptable output:\n";
+	$msg .= "Acceptable output:\n";
 	$msg .= join ('', map ("  $_\n", @expected));
 
 	# Check whether actual and expected match.
@@ -149,7 +199,7 @@ sub compare_output {
 	    for (my ($i) = 0; $i <= $#expected; $i++) {
 		$eq = 0 if $output[$i] ne $expected[$i];
 	    }
-	    pass if $eq;
+	    return $key if $eq;
 	}
 
 	# They differ.  Output a diff.
@@ -170,8 +220,366 @@ sub compare_output {
     }
 
     # Failed to match.  Report failure.
+    $msg .= "\n(Process exit codes are excluded for matching purposes.)\n"
+      if $ignore_exit_codes;
+    $msg .= "\n(User fault messages are excluded for matching purposes.)\n"
+      if $ignore_user_faults;
     fail "Test output failed to match any acceptable form.\n\n$msg";
 }
+
+# File system extraction.
+
+# check_archive (\%CONTENTS)
+#
+# Checks that the extracted file system's contents match \%CONTENTS.
+# Each key in the hash is a file name.  Each value may be:
+#
+#	- $FILE: Name of a host file containing the expected contents.
+#
+#	- [$FILE, $OFFSET, $LENGTH]: An excerpt of host file $FILE
+#	  comprising the $LENGTH bytes starting at $OFFSET.
+#
+#	- [$CONTENTS]: The literal expected file contents, as a string.
+#
+#       - {SUBDIR}: A subdirectory, in the same form described here,
+#         recursively.
+sub check_archive {
+    my ($expected_hier) = @_;
+
+    my (@output) = read_text_file ("$test.output");
+    common_checks ("file system extraction run", @output);
+
+    @output = get_core_output ("file system extraction run", @output);
+    @output = grep (!/^[a-zA-Z0-9-_]+: exit\(\d+\)$/, @output);
+    fail join ("\n", "Error extracting file system:", @output) if @output;
+
+    my ($test_base_name) = $test;
+    $test_base_name =~ s%.*/%%;
+    $test_base_name =~ s%-persistence$%%;
+    $expected_hier->{$test_base_name} = $prereq_tests[0];
+    $expected_hier->{'tar'} = 'tests/filesys/extended/tar';
+
+    my (%expected) = normalize_fs (flatten_hierarchy ($expected_hier, ""));
+    my (%actual) = read_tar ("$prereq_tests[0].tar");
+
+    my ($errors) = 0;
+    foreach my $name (sort keys %expected) {
+	if (exists $actual{$name}) {
+	    if (is_dir ($actual{$name}) && !is_dir ($expected{$name})) {
+		print "$name is a directory but should be an ordinary file.\n";
+		$errors++;
+	    } elsif (!is_dir ($actual{$name}) && is_dir ($expected{$name})) {
+		print "$name is an ordinary file but should be a directory.\n";
+		$errors++;
+	    }
+	} else {
+	    print "$name is missing from the file system.\n";
+	    $errors++;
+	}
+    }
+    foreach my $name (sort keys %actual) {
+	if (!exists $expected{$name}) {
+	    if ($name =~ /^[[:print:]]+$/) {
+		print "$name exists in the file system but it should not.\n";
+	    } else {
+		my ($esc_name) = $name;
+		$esc_name =~ s/[^[:print:]]/./g;
+		print <<EOF;
+$esc_name exists in the file system but should not.  (The name
+of this file contains unusual characters that were printed as `.'.)
+EOF
+	    }
+	    $errors++;
+ 	}
+    }
+    if ($errors) {
+	print "\nActual contents of file system:\n";
+	print_fs (%actual);
+	print "\nExpected contents of file system:\n";
+	print_fs (%expected);
+    } else {
+	foreach my $name (sort keys %expected) {
+	    if (!is_dir ($expected{$name})) {
+		my ($exp_file, $exp_length) = open_file ($expected{$name});
+		my ($act_file, $act_length) = open_file ($actual{$name});
+		$errors += !compare_files ($exp_file, $exp_length,
+					   $act_file, $act_length, $name,
+					   !$errors);
+		close ($exp_file);
+		close ($act_file);
+	    }
+	}
+    }
+    fail "Extracted file system contents are not correct.\n" if $errors;
+}
+
+# open_file ([$FILE, $OFFSET, $LENGTH])
+# open_file ([$CONTENTS])
+#
+# Opens a file for the contents passed in, which must be in one of
+# the two above forms that correspond to check_archive() arguments.
+#
+# Returns ($HANDLE, $LENGTH), where $HANDLE is the file's handle and
+# $LENGTH is the number of bytes in the file's content.
+sub open_file {
+    my ($value) = @_;
+    die if ref ($value) ne 'ARRAY';
+
+    my ($file) = tempfile ();
+    my ($length);
+    if (@$value == 1) {
+	$length = length ($value->[0]);
+	$file = tempfile ();
+	syswrite ($file, $value->[0]) == $length
+	  or die "writing temporary file: $!\n";
+	sysseek ($file, 0, SEEK_SET);
+    } elsif (@$value == 3) {
+	$length = $value->[2];
+	open ($file, '<', $value->[0]) or die "$value->[0]: open: $!\n";
+	die "$value->[0]: file is smaller than expected\n"
+	  if -s $file < $value->[1] + $length;
+	sysseek ($file, $value->[1], SEEK_SET);
+    } else {
+	die;
+    }
+    return ($file, $length);
+}
+
+# compare_files ($A, $A_SIZE, $B, $B_SIZE, $NAME, $VERBOSE)
+#
+# Compares $A_SIZE bytes in $A to $B_SIZE bytes in $B.
+# ($A and $B are handles.)
+# If their contents differ, prints a brief message describing
+# the differences, using $NAME to identify the file.
+# The message contains more detail if $VERBOSE is nonzero.
+# Returns 1 if the contents are identical, 0 otherwise.
+sub compare_files {
+    my ($a, $a_size, $b, $b_size, $name, $verbose) = @_;
+    my ($ofs) = 0;
+    select(STDOUT);
+    for (;;) {
+	my ($a_amt) = $a_size >= 1024 ? 1024 : $a_size;
+	my ($b_amt) = $b_size >= 1024 ? 1024 : $b_size;
+	my ($a_data, $b_data);
+	if (!defined (sysread ($a, $a_data, $a_amt))
+	    || !defined (sysread ($b, $b_data, $b_amt))) {
+	    die "reading $name: $!\n";
+	}
+
+	my ($a_len) = length $a_data;
+	my ($b_len) = length $b_data;
+	last if $a_len == 0 && $b_len == 0;
+
+	if ($a_data ne $b_data) {
+	    my ($min_len) = $a_len < $b_len ? $a_len : $b_len;
+	    my ($diff_ofs);
+	    for ($diff_ofs = 0; $diff_ofs < $min_len; $diff_ofs++) {
+		last if (substr ($a_data, $diff_ofs, 1)
+			 ne substr ($b_data, $diff_ofs, 1));
+	    }
+
+	    printf "\nFile $name differs from expected "
+	      . "starting at offset 0x%x.\n", $ofs + $diff_ofs;
+	    if ($verbose ) {
+		print "Expected contents:\n";
+		hex_dump (substr ($a_data, $diff_ofs, 64), $ofs + $diff_ofs);
+		print "Actual contents:\n";
+		hex_dump (substr ($b_data, $diff_ofs, 64), $ofs + $diff_ofs);
+	    }
+	    return 0;
+	}
+
+	$ofs += $a_len;
+	$a_size -= $a_len;
+	$b_size -= $b_len;
+    }
+    return 1;
+}
+
+# hex_dump ($DATA, $OFS)
+#
+# Prints $DATA in hex and text formats.
+# The first byte of $DATA corresponds to logical offset $OFS
+# in whatever file the data comes from.
+sub hex_dump {
+    my ($data, $ofs) = @_;
+
+    if ($data eq '') {
+	printf "  (File ends at offset %08x.)\n", $ofs;
+	return;
+    }
+
+    my ($per_line) = 16;
+    while ((my $size = length ($data)) > 0) {
+	my ($start) = $ofs % $per_line;
+	my ($end) = $per_line;
+	$end = $start + $size if $end - $start > $size;
+	my ($n) = $end - $start;
+
+	printf "0x%08x  ", int ($ofs / $per_line) * $per_line;
+
+	# Hex version.
+	print "   " x $start;
+	for my $i ($start...$end - 1) {
+	    printf "%02x", ord (substr ($data, $i - $start, 1));
+	    print $i == $per_line / 2 - 1 ? '-' : ' ';
+	}
+	print "   " x ($per_line - $end);
+
+	# Character version.
+	my ($esc_data) = substr ($data, 0, $n);
+	$esc_data =~ s/[^[:print:]]/./g;
+	print "|", " " x $start, $esc_data, " " x ($per_line - $end), "|";
+
+	print "\n";
+
+	$data = substr ($data, $n);
+	$ofs += $n;
+    }
+}
+
+# print_fs (%FS)
+#
+# Prints a list of files in %FS, which must be a file system
+# as flattened by flatten_hierarchy() and normalized by
+# normalize_fs().
+sub print_fs {
+    my (%fs) = @_;
+    foreach my $name (sort keys %fs) {
+	my ($esc_name) = $name;
+	$esc_name =~ s/[^[:print:]]/./g;
+	print "$esc_name: ";
+	if (!is_dir ($fs{$name})) {
+	    print +file_size ($fs{$name}), "-byte file";
+	} else {
+	    print "directory";
+	}
+	print "\n";
+    }
+    print "(empty)\n" if !@_;
+}
+
+# normalize_fs (%FS)
+#
+# Takes a file system as flattened by flatten_hierarchy().
+# Returns a similar file system in which values of the form $FILE
+# are replaced by those of the form [$FILE, $OFFSET, $LENGTH].
+sub normalize_fs {
+    my (%fs) = @_;
+    foreach my $name (keys %fs) {
+	my ($value) = $fs{$name};
+	next if is_dir ($value) || ref ($value) ne '';
+	die "can't open $value\n" if !stat $value;
+	$fs{$name} = [$value, 0, -s _];
+    }
+    return %fs;
+}
+
+# is_dir ($VALUE)
+#
+# Takes a value like one in the hash returned by flatten_hierarchy()
+# and returns 1 if it represents a directory, 0 otherwise.
+sub is_dir {
+    my ($value) = @_;
+    return ref ($value) eq '' && $value eq 'directory';
+}
+
+# file_size ($VALUE)
+#
+# Takes a value like one in the hash returned by flatten_hierarchy()
+# and returns the size of the file it represents.
+sub file_size {
+    my ($value) = @_;
+    die if is_dir ($value);
+    die if ref ($value) ne 'ARRAY';
+    return @$value > 1 ? $value->[2] : length ($value->[0]);
+}
+
+# flatten_hierarchy ($HIER_FS, $PREFIX)
+#
+# Takes a file system in the format expected by check_archive() and
+# returns a "flattened" version in which file names include all parent
+# directory names and the value of directories is just "directory".
+sub flatten_hierarchy {
+    my (%hier_fs) = %{$_[0]};
+    my ($prefix) = $_[1];
+    my (%flat_fs);
+    for my $name (keys %hier_fs) {
+	my ($value) = $hier_fs{$name};
+	if (ref $value eq 'HASH') {
+	    %flat_fs = (%flat_fs, flatten_hierarchy ($value, "$prefix$name/"));
+	    $flat_fs{"$prefix$name"} = 'directory';
+	} else {
+	    $flat_fs{"$prefix$name"} = $value;
+	}
+    }
+    return %flat_fs;
+}
+
+# read_tar ($ARCHIVE)
+#
+# Reads the ustar-format tar file in $ARCHIVE
+# and returns a flattened file system for it.
+sub read_tar {
+    my ($archive) = @_;
+    my (%content);
+    open (ARCHIVE, '<', $archive) or fail "$archive: open: $!\n";
+    for (;;) {
+	my ($header);
+	if ((my $retval = sysread (ARCHIVE, $header, 512)) != 512) {
+	    fail "$archive: unexpected end of file\n" if $retval >= 0;
+	    fail "$archive: read: $!\n";
+	}
+
+	last if $header eq "\0" x 512;
+
+	# Verify magic numbers.
+	if (substr ($header, 257, 6) ne "ustar\0"
+	    || substr ($header, 263, 2) ne '00') {
+	    fail "$archive: corrupt ustar header\n";
+	}
+
+	# Verify checksum.
+	my ($chksum) = oct (unpack ("Z*", substr ($header, 148, 8, ' ' x 8)));
+	my ($correct_chksum) = unpack ("%32a*", $header);
+	fail "$archive: bad header checksum\n" if $chksum != $correct_chksum;
+
+	# Get file name.
+	my ($name) = unpack ("Z100", $header);
+	my ($prefix) = unpack ("Z*", substr ($header, 345));
+	$name = "$prefix/$name" if $prefix ne '';
+	fail "$archive: contains file with empty name" if $name eq '';
+
+	# Get type.
+	my ($typeflag) = substr ($header, 156, 1);
+	$typeflag = '0' if $typeflag eq "\0";
+	fail "unknown file type '$typeflag'\n" if $typeflag !~ /[05]/;
+
+	# Get size.
+	my ($size) = oct (unpack ("Z*", substr ($header, 124, 12)));
+	fail "bad size $size\n" if $size < 0;
+	$size = 0 if $typeflag eq '5';
+
+	# Store content.
+	$name =~ s%^(/|\./|\.\./)*%%;	# Strip leading "/", "./", "../".
+	$name = '' if $name eq '.' || $name eq '..';
+	if (exists $content{$name}) {
+	    fail "$archive: contains multiple entries for $name\n";
+	}
+	if ($typeflag eq '5') {
+	    $content{$name} = 'directory' if $name ne '';
+	} else {
+	    fail "$archive: contains file with empty name\n" if $name eq '';
+	    my ($position) = sysseek (ARCHIVE, 0, SEEK_CUR);
+	    $content{$name} = [$archive, $position, $size];
+	    sysseek (ARCHIVE, int (($size + 511) / 512) * 512, SEEK_CUR);
+	}
+    }
+    close (ARCHIVE);
+    return %content;
+}
+
+# Utilities.
 
 sub fail {
     finish ("FAIL", @_);
@@ -182,11 +590,17 @@ sub pass {
 }
 
 sub finish {
-    my ($verdict, @rest) = @_;
+    my ($verdict, @messages) = @_;
+
+    seek ($msg_file, 0, 0);
+    push (@messages, <$msg_file>);
+    close ($msg_file);
+    chomp (@messages);
 
     my ($result_fn) = "$test.result";
     open (RESULT, '>', $result_fn) or die "$result_fn: create: $!\n";
-    print RESULT "$verdict\n", $messages, @rest;
+    print RESULT "$verdict\n";
+    print RESULT "$_\n" foreach @messages;
     close (RESULT);
 
     if ($verdict eq 'PASS') {
@@ -194,7 +608,7 @@ sub finish {
     } else {
 	print STDOUT "FAIL $test\n";
     }
-    print STDOUT $messages, @rest, "\n";
+    print STDOUT "$_\n" foreach @messages;
 
     exit 0;
 }