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 our (@prereq_tests) = ();
14 if ($test =~ /^(.*)-persistence$/) {
15 push (@prereq_tests, $1);
17 for my $prereq_test (@prereq_tests) {
18 my (@result) = read_text_file ("$prereq_test.result");
19 fail "Prerequisite test $prereq_test failed.\n" if $result[0] ne 'PASS';
22 my ($msg_file) = tempfile ();
28 my ($expected) = pop @_;
30 my (@output) = read_text_file ("$test.output");
31 common_checks ("run", @output);
32 compare_output ("run", @options, \@output, $expected);
36 my ($run, @output) = @_;
38 fail "\u$run produced no output at all\n" if @output == 0;
40 check_for_panic ($run, @output);
41 check_for_keyword ($run, "FAIL", @output);
42 check_for_triple_fault ($run, @output);
43 check_for_keyword ($run, "TIMEOUT", @output);
45 fail "\u$run didn't start up properly: no \"Pintos booting\" message\n"
46 if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
47 fail "\u$run didn't start up properly: no \"Boot complete\" message\n"
48 if !grep (/Boot complete/, @output);
49 fail "\u$run didn't shut down properly: no \"Timer: # ticks\" message\n"
50 if !grep (/Timer: \d+ ticks/, @output);
51 fail "\u$run didn't shut down properly: no \"Powering off\" message\n"
52 if !grep (/Powering off/, @output);
56 my ($run, @output) = @_;
58 my ($panic) = grep (/PANIC/, @output);
59 return unless defined $panic;
61 print "Kernel panic in $run: ", substr ($panic, index ($panic, "PANIC")),
64 my (@stack_line) = grep (/Call stack:/, @output);
65 if (@stack_line != 0) {
66 my ($addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
68 # Find a user program to translate user virtual addresses.
71 if grep (hex ($_) < 0xc0000000, split (' ', $addrs)) > 0 && -e $test;
73 # Get and print the backtrace.
74 my ($trace) = scalar (`backtrace kernel.o $userprog $addrs`);
75 print "Call stack:$addrs\n";
76 print "Translation of call stack:\n";
80 if ($userprog ne '' && index ($trace, $userprog) >= 0) {
82 Translations of user virtual addresses above are based on a guess at
83 the binary to use. If this guess is incorrect, then those
84 translations will be misleading.
89 if ($panic =~ /sec_no \< d-\>capacity/) {
91 \nThis assertion commonly fails when accessing a file via an inode that
92 has been closed and freed. Freeing an inode clears all its sector
93 indexes to 0xcccccccc, which is not a valid sector number for disks
94 smaller than about 1.6 TB.
101 sub check_for_keyword {
102 my ($run, $keyword, @output) = @_;
104 my ($kw_line) = grep (/$keyword/, @output);
105 return unless defined $kw_line;
107 # Most output lines are prefixed by (test-name). Eliminate this
108 # from our message for brevity.
109 $kw_line =~ s/^\([^\)]+\)\s+//;
110 print "$run: $kw_line\n";
115 sub check_for_triple_fault {
116 my ($run, @output) = @_;
118 my ($reboots) = grep (/Pintos booting/, @output) - 1;
119 return unless $reboots > 0;
122 \u$run spontaneously rebooted $reboots times.
123 This is most often caused by unhandled page faults.
124 Read the Triple Faults section in the Debugging chapter
125 of the Pintos manual for more information.
131 # Get @output without header or trailer.
132 sub get_core_output {
133 my ($run, @output) = @_;
138 for my $i (0...$#_) {
139 $start = $i + 1, last
140 if ($process) = $output[$i] =~ /^Executing '(\S+).*':$/;
144 for my $i ($start...$#output) {
145 $end = $i - 1, last if $output[$i] =~ /^Execution of '.*' complete.$/;
148 fail "\u$run didn't start a thread or process\n" if !defined $start;
149 fail "\u$run started '$process' but it never finished\n" if !defined $end;
151 return @output[$start...$end];
155 my ($run) = shift @_;
156 my ($expected) = pop @_;
157 my ($output) = pop @_;
160 my (@output) = get_core_output ($run, @$output);
161 fail "\u$run didn't produce any output" if !@output;
163 my $ignore_exit_codes = exists $options{IGNORE_EXIT_CODES};
164 if ($ignore_exit_codes) {
165 delete $options{IGNORE_EXIT_CODES};
166 @output = grep (!/^[a-zA-Z0-9-_]+: exit\(\-?\d+\)$/, @output);
168 my $ignore_user_faults = exists $options{IGNORE_USER_FAULTS};
169 if ($ignore_user_faults) {
170 delete $options{IGNORE_USER_FAULTS};
171 @output = grep (!/^Page fault at.*in user context\.$/
172 && !/: dying due to interrupt 0x0e \(.*\).$/
173 && !/^Interrupt 0x0e \(.*\) at eip=/
174 && !/^ cr2=.* error=.*/
175 && !/^ eax=.* ebx=.* ecx=.* edx=.*/
176 && !/^ esi=.* edi=.* esp=.* ebp=.*/
177 && !/^ cs=.* ds=.* es=.* ss=.*/, @output);
179 die "unknown option " . (keys (%options))[0] . "\n" if %options;
183 # Compare actual output against each allowed output.
184 if (ref ($expected) eq 'ARRAY') {
186 $expected = {map ((++$i => $_), @$expected)};
188 foreach my $key (keys %$expected) {
189 my (@expected) = split ("\n", $expected->{$key});
191 $msg .= "Acceptable output:\n";
192 $msg .= join ('', map (" $_\n", @expected));
194 # Check whether actual and expected match.
195 # If it's a perfect match, we're done.
196 if ($#output == $#expected) {
198 for (my ($i) = 0; $i <= $#expected; $i++) {
199 $eq = 0 if $output[$i] ne $expected[$i];
204 # They differ. Output a diff.
206 my ($d) = Algorithm::Diff->new (\@expected, \@output);
207 while ($d->Next ()) {
208 my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
210 push (@diff, map (" $_\n", $d->Items (1)));
212 push (@diff, map ("- $_\n", $d->Items (1))) if $d->Items (1);
213 push (@diff, map ("+ $_\n", $d->Items (2))) if $d->Items (2);
217 $msg .= "Differences in `diff -u' format:\n";
218 $msg .= join ('', @diff);
221 # Failed to match. Report failure.
222 $msg .= "\n(Process exit codes are excluded for matching purposes.)\n"
223 if $ignore_exit_codes;
224 $msg .= "\n(User fault messages are excluded for matching purposes.)\n"
225 if $ignore_user_faults;
226 fail "Test output failed to match any acceptable form.\n\n$msg";
229 # File system extraction.
231 # check_archive (\%CONTENTS)
233 # Checks that the extracted file system's contents match \%CONTENTS.
234 # Each key in the hash is a file name. Each value may be:
236 # - $FILE: Name of a host file containing the expected contents.
238 # - [$FILE, $OFFSET, $LENGTH]: An excerpt of host file $FILE
239 # comprising the $LENGTH bytes starting at $OFFSET.
241 # - [$CONTENTS]: The literal expected file contents, as a string.
243 # - {SUBDIR}: A subdirectory, in the same form described here,
246 my ($expected_hier) = @_;
248 my (@output) = read_text_file ("$test.output");
249 common_checks ("file system extraction run", @output);
251 @output = get_core_output ("file system extraction run", @output);
252 @output = grep (!/^[a-zA-Z0-9-_]+: exit\(\d+\)$/, @output);
253 fail join ("\n", "Error extracting file system:", @output) if @output;
255 my ($test_base_name) = $test;
256 $test_base_name =~ s%.*/%%;
257 $test_base_name =~ s%-persistence$%%;
258 $expected_hier->{$test_base_name} = $prereq_tests[0];
259 $expected_hier->{'tar'} = 'tests/filesys/extended/tar';
261 my (%expected) = normalize_fs (flatten_hierarchy ($expected_hier, ""));
262 my (%actual) = read_tar ("$prereq_tests[0].tar");
265 foreach my $name (sort keys %expected) {
266 if (exists $actual{$name}) {
267 if (is_dir ($actual{$name}) && !is_dir ($expected{$name})) {
268 print "$name is a directory but should be an ordinary file.\n";
270 } elsif (!is_dir ($actual{$name}) && is_dir ($expected{$name})) {
271 print "$name is an ordinary file but should be a directory.\n";
275 print "$name is missing from the file system.\n";
279 foreach my $name (sort keys %actual) {
280 if (!exists $expected{$name}) {
281 if ($name =~ /^[[:print:]]+$/) {
282 print "$name exists in the file system but it should not.\n";
284 my ($esc_name) = $name;
285 $esc_name =~ s/[^[:print:]]/./g;
287 $esc_name exists in the file system but should not. (The name
288 of this file contains unusual characters that were printed as `.'.)
295 print "\nActual contents of file system:\n";
297 print "\nExpected contents of file system:\n";
298 print_fs (%expected);
300 foreach my $name (sort keys %expected) {
301 if (!is_dir ($expected{$name})) {
302 my ($exp_file, $exp_length) = open_file ($expected{$name});
303 my ($act_file, $act_length) = open_file ($actual{$name});
304 $errors += !compare_files ($exp_file, $exp_length,
305 $act_file, $act_length, $name,
312 fail "Extracted file system contents are not correct.\n" if $errors;
315 # open_file ([$FILE, $OFFSET, $LENGTH])
316 # open_file ([$CONTENTS])
318 # Opens a file for the contents passed in, which must be in one of
319 # the two above forms that correspond to check_archive() arguments.
321 # Returns ($HANDLE, $LENGTH), where $HANDLE is the file's handle and
322 # $LENGTH is the number of bytes in the file's content.
325 die if ref ($value) ne 'ARRAY';
327 my ($file) = tempfile ();
330 $length = length ($value->[0]);
332 syswrite ($file, $value->[0]) == $length
333 or die "writing temporary file: $!\n";
334 sysseek ($file, 0, SEEK_SET);
335 } elsif (@$value == 3) {
336 $length = $value->[2];
337 open ($file, '<', $value->[0]) or die "$value->[0]: open: $!\n";
338 die "$value->[0]: file is smaller than expected\n"
339 if -s $file < $value->[1] + $length;
340 sysseek ($file, $value->[1], SEEK_SET);
344 return ($file, $length);
347 # compare_files ($A, $A_SIZE, $B, $B_SIZE, $NAME, $VERBOSE)
349 # Compares $A_SIZE bytes in $A to $B_SIZE bytes in $B.
350 # ($A and $B are handles.)
351 # If their contents differ, prints a brief message describing
352 # the differences, using $NAME to identify the file.
353 # The message contains more detail if $VERBOSE is nonzero.
354 # Returns 1 if the contents are identical, 0 otherwise.
356 my ($a, $a_size, $b, $b_size, $name, $verbose) = @_;
360 my ($a_amt) = $a_size >= 1024 ? 1024 : $a_size;
361 my ($b_amt) = $b_size >= 1024 ? 1024 : $b_size;
362 my ($a_data, $b_data);
363 if (!defined (sysread ($a, $a_data, $a_amt))
364 || !defined (sysread ($b, $b_data, $b_amt))) {
365 die "reading $name: $!\n";
368 my ($a_len) = length $a_data;
369 my ($b_len) = length $b_data;
370 last if $a_len == 0 && $b_len == 0;
372 if ($a_data ne $b_data) {
373 my ($min_len) = $a_len < $b_len ? $a_len : $b_len;
375 for ($diff_ofs = 0; $diff_ofs < $min_len; $diff_ofs++) {
376 last if (substr ($a_data, $diff_ofs, 1)
377 ne substr ($b_data, $diff_ofs, 1));
380 printf "\nFile $name differs from expected "
381 . "starting at offset 0x%x.\n", $ofs + $diff_ofs;
383 print "Expected contents:\n";
384 hex_dump (substr ($a_data, $diff_ofs, 64), $ofs + $diff_ofs);
385 print "Actual contents:\n";
386 hex_dump (substr ($b_data, $diff_ofs, 64), $ofs + $diff_ofs);
398 # hex_dump ($DATA, $OFS)
400 # Prints $DATA in hex and text formats.
401 # The first byte of $DATA corresponds to logical offset $OFS
402 # in whatever file the data comes from.
404 my ($data, $ofs) = @_;
407 printf " (File ends at offset %08x.)\n", $ofs;
412 while ((my $size = length ($data)) > 0) {
413 my ($start) = $ofs % $per_line;
414 my ($end) = $per_line;
415 $end = $start + $size if $end - $start > $size;
416 my ($n) = $end - $start;
418 printf "0x%08x ", int ($ofs / $per_line) * $per_line;
422 for my $i ($start...$end - 1) {
423 printf "%02x", ord (substr ($data, $i - $start, 1));
424 print $i == $per_line / 2 - 1 ? '-' : ' ';
426 print " " x ($per_line - $end);
429 my ($esc_data) = substr ($data, 0, $n);
430 $esc_data =~ s/[^[:print:]]/./g;
431 print "|", " " x $start, $esc_data, " " x ($per_line - $end), "|";
435 $data = substr ($data, $n);
442 # Prints a list of files in %FS, which must be a file system
443 # as flattened by flatten_hierarchy() and normalized by
447 foreach my $name (sort keys %fs) {
448 my ($esc_name) = $name;
449 $esc_name =~ s/[^[:print:]]/./g;
451 if (!is_dir ($fs{$name})) {
452 print +file_size ($fs{$name}), "-byte file";
458 print "(empty)\n" if !@_;
463 # Takes a file system as flattened by flatten_hierarchy().
464 # Returns a similar file system in which values of the form $FILE
465 # are replaced by those of the form [$FILE, $OFFSET, $LENGTH].
468 foreach my $name (keys %fs) {
469 my ($value) = $fs{$name};
470 next if is_dir ($value) || ref ($value) ne '';
471 die "can't open $value\n" if !stat $value;
472 $fs{$name} = [$value, 0, -s _];
479 # Takes a value like one in the hash returned by flatten_hierarchy()
480 # and returns 1 if it represents a directory, 0 otherwise.
483 return ref ($value) eq '' && $value eq 'directory';
488 # Takes a value like one in the hash returned by flatten_hierarchy()
489 # and returns the size of the file it represents.
492 die if is_dir ($value);
493 die if ref ($value) ne 'ARRAY';
494 return @$value > 1 ? $value->[2] : length ($value->[0]);
497 # flatten_hierarchy ($HIER_FS, $PREFIX)
499 # Takes a file system in the format expected by check_archive() and
500 # returns a "flattened" version in which file names include all parent
501 # directory names and the value of directories is just "directory".
502 sub flatten_hierarchy {
503 my (%hier_fs) = %{$_[0]};
504 my ($prefix) = $_[1];
506 for my $name (keys %hier_fs) {
507 my ($value) = $hier_fs{$name};
508 if (ref $value eq 'HASH') {
509 %flat_fs = (%flat_fs, flatten_hierarchy ($value, "$prefix$name/"));
510 $flat_fs{"$prefix$name"} = 'directory';
512 $flat_fs{"$prefix$name"} = $value;
518 # read_tar ($ARCHIVE)
520 # Reads the ustar-format tar file in $ARCHIVE
521 # and returns a flattened file system for it.
525 open (ARCHIVE, '<', $archive) or fail "$archive: open: $!\n";
528 if ((my $retval = sysread (ARCHIVE, $header, 512)) != 512) {
529 fail "$archive: unexpected end of file\n" if $retval >= 0;
530 fail "$archive: read: $!\n";
533 last if $header eq "\0" x 512;
535 # Verify magic numbers.
536 if (substr ($header, 257, 6) ne "ustar\0"
537 || substr ($header, 263, 2) ne '00') {
538 fail "$archive: corrupt ustar header\n";
542 my ($chksum) = oct (unpack ("Z*", substr ($header, 148, 8, ' ' x 8)));
543 my ($correct_chksum) = unpack ("%32a*", $header);
544 fail "$archive: bad header checksum\n" if $chksum != $correct_chksum;
547 my ($name) = unpack ("Z100", $header);
548 my ($prefix) = unpack ("Z*", substr ($header, 345));
549 $name = "$prefix/$name" if $prefix ne '';
550 fail "$archive: contains file with empty name" if $name eq '';
553 my ($typeflag) = substr ($header, 156, 1);
554 $typeflag = '0' if $typeflag eq "\0";
555 fail "unknown file type '$typeflag'\n" if $typeflag !~ /[05]/;
558 my ($size) = oct (unpack ("Z*", substr ($header, 124, 12)));
559 fail "bad size $size\n" if $size < 0;
560 $size = 0 if $typeflag eq '5';
563 if (exists $content{$name}) {
564 fail "$archive: contains multiple entries for $name\n";
566 if ($typeflag eq '5') {
567 $content{$name} = 'directory';
569 my ($position) = sysseek (ARCHIVE, 0, SEEK_CUR);
570 $content{$name} = [$archive, $position, $size];
571 sysseek (ARCHIVE, int (($size + 511) / 512) * 512, SEEK_CUR);
589 my ($verdict, @messages) = @_;
591 seek ($msg_file, 0, 0);
592 push (@messages, <$msg_file>);
596 my ($result_fn) = "$test.result";
597 open (RESULT, '>', $result_fn) or die "$result_fn: create: $!\n";
598 print RESULT "$verdict\n";
599 print RESULT "$_\n" foreach @messages;
602 if ($verdict eq 'PASS') {
603 print STDOUT "pass $test\n";
605 print STDOUT "FAIL $test\n";
607 print STDOUT "$_\n" foreach @messages;
613 my ($file_name) = @_;
614 open (FILE, '<', $file_name) or die "$file_name: open: $!\n";
615 my (@content) = <FILE>;