3 use tests::Algorithm::Diff;
4 use File::Temp 'tempfile';
5 use Fcntl qw(SEEK_SET SEEK_CUR);
11 our ($test, $src_dir) = @ARGV;
13 my ($msg_file) = tempfile ();
16 our (@prereq_tests) = ();
17 if ($test =~ /^(.*)-persistence$/) {
18 push (@prereq_tests, $1);
20 for my $prereq_test (@prereq_tests) {
21 my (@result) = read_text_file ("$prereq_test.result");
22 fail "Prerequisite test $prereq_test failed.\n" if $result[0] ne 'PASS';
29 my ($expected) = pop @_;
31 my (@output) = read_text_file ("$test.output");
32 common_checks ("run", @output);
33 compare_output ("run", @options, \@output, $expected);
37 my ($run, @output) = @_;
39 fail "\u$run produced no output at all\n" if @output == 0;
41 check_for_panic ($run, @output);
42 check_for_keyword ($run, "FAIL", @output);
43 check_for_triple_fault ($run, @output);
44 check_for_keyword ($run, "TIMEOUT", @output);
46 fail "\u$run didn't start up properly: no \"Pintos booting\" message\n"
47 if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
48 fail "\u$run didn't start up properly: no \"Boot complete\" message\n"
49 if !grep (/Boot complete/, @output);
50 fail "\u$run didn't shut down properly: no \"Timer: # ticks\" message\n"
51 if !grep (/Timer: \d+ ticks/, @output);
52 fail "\u$run didn't shut down properly: no \"Powering off\" message\n"
53 if !grep (/Powering off/, @output);
57 my ($run, @output) = @_;
59 my ($panic) = grep (/PANIC/, @output);
60 return unless defined $panic;
62 print "Kernel panic in $run: ", substr ($panic, index ($panic, "PANIC")),
65 my (@stack_line) = grep (/Call stack:/, @output);
66 if (@stack_line != 0) {
67 my ($addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
69 # Find a user program to translate user virtual addresses.
72 if grep (hex ($_) < 0xc0000000, split (' ', $addrs)) > 0 && -e $test;
74 # Get and print the backtrace.
75 my ($trace) = scalar (`backtrace kernel.o $userprog $addrs`);
76 print "Call stack:$addrs\n";
77 print "Translation of call stack:\n";
81 if ($userprog ne '' && index ($trace, $userprog) >= 0) {
83 Translations of user virtual addresses above are based on a guess at
84 the binary to use. If this guess is incorrect, then those
85 translations will be misleading.
90 if ($panic =~ /sec_no \< d-\>capacity/) {
92 \nThis assertion commonly fails when accessing a file via an inode that
93 has been closed and freed. Freeing an inode clears all its sector
94 indexes to 0xcccccccc, which is not a valid sector number for disks
95 smaller than about 1.6 TB.
102 sub check_for_keyword {
103 my ($run, $keyword, @output) = @_;
105 my ($kw_line) = grep (/$keyword/, @output);
106 return unless defined $kw_line;
108 # Most output lines are prefixed by (test-name). Eliminate this
109 # from our message for brevity.
110 $kw_line =~ s/^\([^\)]+\)\s+//;
111 print "$run: $kw_line\n";
116 sub check_for_triple_fault {
117 my ($run, @output) = @_;
119 my ($reboots) = grep (/Pintos booting/, @output) - 1;
120 return unless $reboots > 0;
123 \u$run spontaneously rebooted $reboots times.
124 This is most often caused by unhandled page faults.
125 Read the Triple Faults section in the Debugging chapter
126 of the Pintos manual for more information.
132 # Get @output without header or trailer.
133 sub get_core_output {
134 my ($run, @output) = @_;
139 for my $i (0...$#_) {
140 $start = $i + 1, last
141 if ($process) = $output[$i] =~ /^Executing '(\S+).*':$/;
145 for my $i ($start...$#output) {
146 $end = $i - 1, last if $output[$i] =~ /^Execution of '.*' complete.$/;
149 fail "\u$run didn't start a thread or process\n" if !defined $start;
150 fail "\u$run started '$process' but it never finished\n" if !defined $end;
152 return @output[$start...$end];
156 my ($run) = shift @_;
157 my ($expected) = pop @_;
158 my ($output) = pop @_;
161 my (@output) = get_core_output ($run, @$output);
162 fail "\u$run didn't produce any output" if !@output;
164 my $ignore_exit_codes = exists $options{IGNORE_EXIT_CODES};
165 if ($ignore_exit_codes) {
166 delete $options{IGNORE_EXIT_CODES};
167 @output = grep (!/^[a-zA-Z0-9-_]+: exit\(\-?\d+\)$/, @output);
169 my $ignore_user_faults = exists $options{IGNORE_USER_FAULTS};
170 if ($ignore_user_faults) {
171 delete $options{IGNORE_USER_FAULTS};
172 @output = grep (!/^Page fault at.*in user context\.$/
173 && !/: dying due to interrupt 0x0e \(.*\).$/
174 && !/^Interrupt 0x0e \(.*\) at eip=/
175 && !/^ cr2=.* error=.*/
176 && !/^ eax=.* ebx=.* ecx=.* edx=.*/
177 && !/^ esi=.* edi=.* esp=.* ebp=.*/
178 && !/^ cs=.* ds=.* es=.* ss=.*/, @output);
180 die "unknown option " . (keys (%options))[0] . "\n" if %options;
184 # Compare actual output against each allowed output.
185 if (ref ($expected) eq 'ARRAY') {
187 $expected = {map ((++$i => $_), @$expected)};
189 foreach my $key (keys %$expected) {
190 my (@expected) = split ("\n", $expected->{$key});
192 $msg .= "Acceptable output:\n";
193 $msg .= join ('', map (" $_\n", @expected));
195 # Check whether actual and expected match.
196 # If it's a perfect match, we're done.
197 if ($#output == $#expected) {
199 for (my ($i) = 0; $i <= $#expected; $i++) {
200 $eq = 0 if $output[$i] ne $expected[$i];
205 # They differ. Output a diff.
207 my ($d) = Algorithm::Diff->new (\@expected, \@output);
208 while ($d->Next ()) {
209 my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
211 push (@diff, map (" $_\n", $d->Items (1)));
213 push (@diff, map ("- $_\n", $d->Items (1))) if $d->Items (1);
214 push (@diff, map ("+ $_\n", $d->Items (2))) if $d->Items (2);
218 $msg .= "Differences in `diff -u' format:\n";
219 $msg .= join ('', @diff);
222 # Failed to match. Report failure.
223 $msg .= "\n(Process exit codes are excluded for matching purposes.)\n"
224 if $ignore_exit_codes;
225 $msg .= "\n(User fault messages are excluded for matching purposes.)\n"
226 if $ignore_user_faults;
227 fail "Test output failed to match any acceptable form.\n\n$msg";
230 # File system extraction.
232 # check_archive (\%CONTENTS)
234 # Checks that the extracted file system's contents match \%CONTENTS.
235 # Each key in the hash is a file name. Each value may be:
237 # - $FILE: Name of a host file containing the expected contents.
239 # - [$FILE, $OFFSET, $LENGTH]: An excerpt of host file $FILE
240 # comprising the $LENGTH bytes starting at $OFFSET.
242 # - [$CONTENTS]: The literal expected file contents, as a string.
244 # - {SUBDIR}: A subdirectory, in the same form described here,
247 my ($expected_hier) = @_;
249 my (@output) = read_text_file ("$test.output");
250 common_checks ("file system extraction run", @output);
252 @output = get_core_output ("file system extraction run", @output);
253 @output = grep (!/^[a-zA-Z0-9-_]+: exit\(\d+\)$/, @output);
254 fail join ("\n", "Error extracting file system:", @output) if @output;
256 my ($test_base_name) = $test;
257 $test_base_name =~ s%.*/%%;
258 $test_base_name =~ s%-persistence$%%;
259 $expected_hier->{$test_base_name} = $prereq_tests[0];
260 $expected_hier->{'tar'} = 'tests/filesys/extended/tar';
262 my (%expected) = normalize_fs (flatten_hierarchy ($expected_hier, ""));
263 my (%actual) = read_tar ("$prereq_tests[0].tar");
266 foreach my $name (sort keys %expected) {
267 if (exists $actual{$name}) {
268 if (is_dir ($actual{$name}) && !is_dir ($expected{$name})) {
269 print "$name is a directory but should be an ordinary file.\n";
271 } elsif (!is_dir ($actual{$name}) && is_dir ($expected{$name})) {
272 print "$name is an ordinary file but should be a directory.\n";
276 print "$name is missing from the file system.\n";
280 foreach my $name (sort keys %actual) {
281 if (!exists $expected{$name}) {
282 if ($name =~ /^[[:print:]]+$/) {
283 print "$name exists in the file system but it should not.\n";
285 my ($esc_name) = $name;
286 $esc_name =~ s/[^[:print:]]/./g;
288 $esc_name exists in the file system but should not. (The name
289 of this file contains unusual characters that were printed as `.'.)
296 print "\nActual contents of file system:\n";
298 print "\nExpected contents of file system:\n";
299 print_fs (%expected);
301 foreach my $name (sort keys %expected) {
302 if (!is_dir ($expected{$name})) {
303 my ($exp_file, $exp_length) = open_file ($expected{$name});
304 my ($act_file, $act_length) = open_file ($actual{$name});
305 $errors += !compare_files ($exp_file, $exp_length,
306 $act_file, $act_length, $name,
313 fail "Extracted file system contents are not correct.\n" if $errors;
316 # open_file ([$FILE, $OFFSET, $LENGTH])
317 # open_file ([$CONTENTS])
319 # Opens a file for the contents passed in, which must be in one of
320 # the two above forms that correspond to check_archive() arguments.
322 # Returns ($HANDLE, $LENGTH), where $HANDLE is the file's handle and
323 # $LENGTH is the number of bytes in the file's content.
326 die if ref ($value) ne 'ARRAY';
328 my ($file) = tempfile ();
331 $length = length ($value->[0]);
333 syswrite ($file, $value->[0]) == $length
334 or die "writing temporary file: $!\n";
335 sysseek ($file, 0, SEEK_SET);
336 } elsif (@$value == 3) {
337 $length = $value->[2];
338 open ($file, '<', $value->[0]) or die "$value->[0]: open: $!\n";
339 die "$value->[0]: file is smaller than expected\n"
340 if -s $file < $value->[1] + $length;
341 sysseek ($file, $value->[1], SEEK_SET);
345 return ($file, $length);
348 # compare_files ($A, $A_SIZE, $B, $B_SIZE, $NAME, $VERBOSE)
350 # Compares $A_SIZE bytes in $A to $B_SIZE bytes in $B.
351 # ($A and $B are handles.)
352 # If their contents differ, prints a brief message describing
353 # the differences, using $NAME to identify the file.
354 # The message contains more detail if $VERBOSE is nonzero.
355 # Returns 1 if the contents are identical, 0 otherwise.
357 my ($a, $a_size, $b, $b_size, $name, $verbose) = @_;
361 my ($a_amt) = $a_size >= 1024 ? 1024 : $a_size;
362 my ($b_amt) = $b_size >= 1024 ? 1024 : $b_size;
363 my ($a_data, $b_data);
364 if (!defined (sysread ($a, $a_data, $a_amt))
365 || !defined (sysread ($b, $b_data, $b_amt))) {
366 die "reading $name: $!\n";
369 my ($a_len) = length $a_data;
370 my ($b_len) = length $b_data;
371 last if $a_len == 0 && $b_len == 0;
373 if ($a_data ne $b_data) {
374 my ($min_len) = $a_len < $b_len ? $a_len : $b_len;
376 for ($diff_ofs = 0; $diff_ofs < $min_len; $diff_ofs++) {
377 last if (substr ($a_data, $diff_ofs, 1)
378 ne substr ($b_data, $diff_ofs, 1));
381 printf "\nFile $name differs from expected "
382 . "starting at offset 0x%x.\n", $ofs + $diff_ofs;
384 print "Expected contents:\n";
385 hex_dump (substr ($a_data, $diff_ofs, 64), $ofs + $diff_ofs);
386 print "Actual contents:\n";
387 hex_dump (substr ($b_data, $diff_ofs, 64), $ofs + $diff_ofs);
399 # hex_dump ($DATA, $OFS)
401 # Prints $DATA in hex and text formats.
402 # The first byte of $DATA corresponds to logical offset $OFS
403 # in whatever file the data comes from.
405 my ($data, $ofs) = @_;
408 printf " (File ends at offset %08x.)\n", $ofs;
413 while ((my $size = length ($data)) > 0) {
414 my ($start) = $ofs % $per_line;
415 my ($end) = $per_line;
416 $end = $start + $size if $end - $start > $size;
417 my ($n) = $end - $start;
419 printf "0x%08x ", int ($ofs / $per_line) * $per_line;
423 for my $i ($start...$end - 1) {
424 printf "%02x", ord (substr ($data, $i - $start, 1));
425 print $i == $per_line / 2 - 1 ? '-' : ' ';
427 print " " x ($per_line - $end);
430 my ($esc_data) = substr ($data, 0, $n);
431 $esc_data =~ s/[^[:print:]]/./g;
432 print "|", " " x $start, $esc_data, " " x ($per_line - $end), "|";
436 $data = substr ($data, $n);
443 # Prints a list of files in %FS, which must be a file system
444 # as flattened by flatten_hierarchy() and normalized by
448 foreach my $name (sort keys %fs) {
449 my ($esc_name) = $name;
450 $esc_name =~ s/[^[:print:]]/./g;
452 if (!is_dir ($fs{$name})) {
453 print +file_size ($fs{$name}), "-byte file";
459 print "(empty)\n" if !@_;
464 # Takes a file system as flattened by flatten_hierarchy().
465 # Returns a similar file system in which values of the form $FILE
466 # are replaced by those of the form [$FILE, $OFFSET, $LENGTH].
469 foreach my $name (keys %fs) {
470 my ($value) = $fs{$name};
471 next if is_dir ($value) || ref ($value) ne '';
472 die "can't open $value\n" if !stat $value;
473 $fs{$name} = [$value, 0, -s _];
480 # Takes a value like one in the hash returned by flatten_hierarchy()
481 # and returns 1 if it represents a directory, 0 otherwise.
484 return ref ($value) eq '' && $value eq 'directory';
489 # Takes a value like one in the hash returned by flatten_hierarchy()
490 # and returns the size of the file it represents.
493 die if is_dir ($value);
494 die if ref ($value) ne 'ARRAY';
495 return @$value > 1 ? $value->[2] : length ($value->[0]);
498 # flatten_hierarchy ($HIER_FS, $PREFIX)
500 # Takes a file system in the format expected by check_archive() and
501 # returns a "flattened" version in which file names include all parent
502 # directory names and the value of directories is just "directory".
503 sub flatten_hierarchy {
504 my (%hier_fs) = %{$_[0]};
505 my ($prefix) = $_[1];
507 for my $name (keys %hier_fs) {
508 my ($value) = $hier_fs{$name};
509 if (ref $value eq 'HASH') {
510 %flat_fs = (%flat_fs, flatten_hierarchy ($value, "$prefix$name/"));
511 $flat_fs{"$prefix$name"} = 'directory';
513 $flat_fs{"$prefix$name"} = $value;
519 # read_tar ($ARCHIVE)
521 # Reads the ustar-format tar file in $ARCHIVE
522 # and returns a flattened file system for it.
526 open (ARCHIVE, '<', $archive) or fail "$archive: open: $!\n";
529 if ((my $retval = sysread (ARCHIVE, $header, 512)) != 512) {
530 fail "$archive: unexpected end of file\n" if $retval >= 0;
531 fail "$archive: read: $!\n";
534 last if $header eq "\0" x 512;
536 # Verify magic numbers.
537 if (substr ($header, 257, 6) ne "ustar\0"
538 || substr ($header, 263, 2) ne '00') {
539 fail "$archive: corrupt ustar header\n";
543 my ($chksum) = oct (unpack ("Z*", substr ($header, 148, 8, ' ' x 8)));
544 my ($correct_chksum) = unpack ("%32a*", $header);
545 fail "$archive: bad header checksum\n" if $chksum != $correct_chksum;
548 my ($name) = unpack ("Z100", $header);
549 my ($prefix) = unpack ("Z*", substr ($header, 345));
550 $name = "$prefix/$name" if $prefix ne '';
551 fail "$archive: contains file with empty name" if $name eq '';
554 my ($typeflag) = substr ($header, 156, 1);
555 $typeflag = '0' if $typeflag eq "\0";
556 fail "unknown file type '$typeflag'\n" if $typeflag !~ /[05]/;
559 my ($size) = oct (unpack ("Z*", substr ($header, 124, 12)));
560 fail "bad size $size\n" if $size < 0;
561 $size = 0 if $typeflag eq '5';
564 $name =~ s%^(/|\./|\.\./)*%%; # Strip leading "/", "./", "../".
565 $name = '' if $name eq '.' || $name eq '..';
566 if (exists $content{$name}) {
567 fail "$archive: contains multiple entries for $name\n";
569 if ($typeflag eq '5') {
570 $content{$name} = 'directory' if $name ne '';
572 fail "$archive: contains file with empty name\n" if $name eq '';
573 my ($position) = sysseek (ARCHIVE, 0, SEEK_CUR);
574 $content{$name} = [$archive, $position, $size];
575 sysseek (ARCHIVE, int (($size + 511) / 512) * 512, SEEK_CUR);
593 my ($verdict, @messages) = @_;
595 seek ($msg_file, 0, 0);
596 push (@messages, <$msg_file>);
600 my ($result_fn) = "$test.result";
601 open (RESULT, '>', $result_fn) or die "$result_fn: create: $!\n";
602 print RESULT "$verdict\n";
603 print RESULT "$_\n" foreach @messages;
606 if ($verdict eq 'PASS') {
607 print STDOUT "pass $test\n";
609 print STDOUT "FAIL $test\n";
611 print STDOUT "$_\n" foreach @messages;
617 my ($file_name) = @_;
618 open (FILE, '<', $file_name) or die "$file_name: open: $!\n";
619 my (@content) = <FILE>;