Fix inconstiency in recent_cpu update description.
[pintos-anon] / src / tests / tests.pm
1 use strict;
2 use warnings;
3 use tests::Algorithm::Diff;
4 use File::Temp 'tempfile';
5 use Fcntl qw(SEEK_SET SEEK_CUR);
6
7 sub fail;
8 sub pass;
9
10 die if @ARGV != 2;
11 our ($test, $src_dir) = @ARGV;
12
13 our (@prereq_tests) = ();
14 if ($test =~ /^(.*)-persistence$/) {
15     push (@prereq_tests, $1);
16 }
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';
20 }
21
22 my ($msg_file) = tempfile ();
23 select ($msg_file);
24 \f
25 # Generic testing.
26
27 sub check_expected {
28     my ($expected) = pop @_;
29     my (@options) = @_;
30     my (@output) = read_text_file ("$test.output");
31     common_checks ("run", @output);
32     compare_output ("run", @options, \@output, $expected);
33 }
34
35 sub common_checks {
36     my ($run, @output) = @_;
37
38     fail "\u$run produced no output at all\n" if @output == 0;
39
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);
44
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);
53 }
54
55 sub check_for_panic {
56     my ($run, @output) = @_;
57
58     my ($panic) = grep (/PANIC/, @output);
59     return unless defined $panic;
60
61     print "Kernel panic in $run: ", substr ($panic, index ($panic, "PANIC")),
62       "\n";
63
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]+)+)/;
67
68         # Find a user program to translate user virtual addresses.
69         my ($userprog) = "";
70         $userprog = "$test"
71           if grep (hex ($_) < 0xc0000000, split (' ', $addrs)) > 0 && -e $test;
72
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";
77         print $trace;
78
79         # Print disclaimer.
80         if ($userprog ne '' && index ($trace, $userprog) >= 0) {
81             print <<EOF;
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.
85 EOF
86         }
87     }
88
89     if ($panic =~ /sec_no \< d-\>capacity/) {
90         print <<EOF;
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.
95 EOF
96     }
97
98     fail;
99 }
100
101 sub check_for_keyword {
102     my ($run, $keyword, @output) = @_;
103     
104     my ($kw_line) = grep (/$keyword/, @output);
105     return unless defined $kw_line;
106
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";
111
112     fail;
113 }
114
115 sub check_for_triple_fault {
116     my ($run, @output) = @_;
117
118     my ($reboots) = grep (/Pintos booting/, @output) - 1;
119     return unless $reboots > 0;
120
121     print <<EOF;
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.
126 EOF
127
128     fail;
129 }
130
131 # Get @output without header or trailer.
132 sub get_core_output {
133     my ($run, @output) = @_;
134     my ($p);
135
136     my ($process);
137     my ($start);
138     for my $i (0...$#_) {
139         $start = $i + 1, last
140           if ($process) = $output[$i] =~ /^Executing '(\S+).*':$/;
141     }
142
143     my ($end);
144     for my $i ($start...$#output) {
145         $end = $i - 1, last if $output[$i] =~ /^Execution of '.*' complete.$/;
146     }
147
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;
150
151     return @output[$start...$end];
152 }
153
154 sub compare_output {
155     my ($run) = shift @_;
156     my ($expected) = pop @_;
157     my ($output) = pop @_;
158     my (%options) = @_;
159
160     my (@output) = get_core_output ($run, @$output);
161     fail "\u$run didn't produce any output" if !@output;
162
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);
167     }
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);
178     }
179     die "unknown option " . (keys (%options))[0] . "\n" if %options;
180
181     my ($msg);
182
183     # Compare actual output against each allowed output.
184     if (ref ($expected) eq 'ARRAY') {
185         my ($i) = 0;
186         $expected = {map ((++$i => $_), @$expected)};
187     }
188     foreach my $key (keys %$expected) {
189         my (@expected) = split ("\n", $expected->{$key});
190
191         $msg .= "Acceptable output:\n";
192         $msg .= join ('', map ("  $_\n", @expected));
193
194         # Check whether actual and expected match.
195         # If it's a perfect match, we're done.
196         if ($#output == $#expected) {
197             my ($eq) = 1;
198             for (my ($i) = 0; $i <= $#expected; $i++) {
199                 $eq = 0 if $output[$i] ne $expected[$i];
200             }
201             return $key if $eq;
202         }
203
204         # They differ.  Output a diff.
205         my (@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));
209             if ($d->Same ()) {
210                 push (@diff, map ("  $_\n", $d->Items (1)));
211             } else {
212                 push (@diff, map ("- $_\n", $d->Items (1))) if $d->Items (1);
213                 push (@diff, map ("+ $_\n", $d->Items (2))) if $d->Items (2);
214             }
215         }
216
217         $msg .= "Differences in `diff -u' format:\n";
218         $msg .= join ('', @diff);
219     }
220
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";
227 }
228 \f
229 # File system extraction.
230
231 # check_archive (\%CONTENTS)
232 #
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:
235 #
236 #       - $FILE: Name of a host file containing the expected contents.
237 #
238 #       - [$FILE, $OFFSET, $LENGTH]: An excerpt of host file $FILE
239 #         comprising the $LENGTH bytes starting at $OFFSET.
240 #
241 #       - [$CONTENTS]: The literal expected file contents, as a string.
242 #
243 #       - {SUBDIR}: A subdirectory, in the same form described here,
244 #         recursively.
245 sub check_archive {
246     my ($expected_hier) = @_;
247
248     my (@output) = read_text_file ("$test.output");
249     common_checks ("file system extraction run", @output);
250
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;
254
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';
260
261     my (%expected) = normalize_fs (flatten_hierarchy ($expected_hier, ""));
262     my (%actual) = read_tar ("$prereq_tests[0].tar");
263
264     my ($errors) = 0;
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";
269                 $errors++;
270             } elsif (!is_dir ($actual{$name}) && is_dir ($expected{$name})) {
271                 print "$name is an ordinary file but should be a directory.\n";
272                 $errors++;
273             }
274         } else {
275             print "$name is missing from the file system.\n";
276             $errors++;
277         }
278     }
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";
283             } else {
284                 my ($esc_name) = $name;
285                 $esc_name =~ s/[^[:print:]]/./g;
286                 print <<EOF;
287 $esc_name exists in the file system but should not.  (The name
288 of this file contains unusual characters that were printed as `.'.)
289 EOF
290             }
291             $errors++;
292         }
293     }
294     if ($errors) {
295         print "\nActual contents of file system:\n";
296         print_fs (%actual);
297         print "\nExpected contents of file system:\n";
298         print_fs (%expected);
299     } else {
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,
306                                            !$errors);
307                 close ($exp_file);
308                 close ($act_file);
309             }
310         }
311     }
312     fail "Extracted file system contents are not correct.\n" if $errors;
313 }
314
315 # open_file ([$FILE, $OFFSET, $LENGTH])
316 # open_file ([$CONTENTS])
317 #
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.
320 #
321 # Returns ($HANDLE, $LENGTH), where $HANDLE is the file's handle and
322 # $LENGTH is the number of bytes in the file's content.
323 sub open_file {
324     my ($value) = @_;
325     die if ref ($value) ne 'ARRAY';
326
327     my ($file) = tempfile ();
328     my ($length);
329     if (@$value == 1) {
330         $length = length ($value->[0]);
331         $file = tempfile ();
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);
341     } else {
342         die;
343     }
344     return ($file, $length);
345 }
346
347 # compare_files ($A, $A_SIZE, $B, $B_SIZE, $NAME, $VERBOSE)
348 #
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.
355 sub compare_files {
356     my ($a, $a_size, $b, $b_size, $name, $verbose) = @_;
357     my ($ofs) = 0;
358     select(STDOUT);
359     for (;;) {
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";
366         }
367
368         my ($a_len) = length $a_data;
369         my ($b_len) = length $b_data;
370         last if $a_len == 0 && $b_len == 0;
371
372         if ($a_data ne $b_data) {
373             my ($min_len) = $a_len < $b_len ? $a_len : $b_len;
374             my ($diff_ofs);
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));
378             }
379
380             printf "\nFile $name differs from expected "
381               . "starting at offset 0x%x.\n", $ofs + $diff_ofs;
382             if ($verbose ) {
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);
387             }
388             return 0;
389         }
390
391         $ofs += $a_len;
392         $a_size -= $a_len;
393         $b_size -= $b_len;
394     }
395     return 1;
396 }
397
398 # hex_dump ($DATA, $OFS)
399 #
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.
403 sub hex_dump {
404     my ($data, $ofs) = @_;
405
406     if ($data eq '') {
407         printf "  (File ends at offset %08x.)\n", $ofs;
408         return;
409     }
410
411     my ($per_line) = 16;
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;
417
418         printf "0x%08x  ", int ($ofs / $per_line) * $per_line;
419
420         # Hex version.
421         print "   " x $start;
422         for my $i ($start...$end - 1) {
423             printf "%02x", ord (substr ($data, $i - $start, 1));
424             print $i == $per_line / 2 - 1 ? '-' : ' ';
425         }
426         print "   " x ($per_line - $end);
427
428         # Character version.
429         my ($esc_data) = substr ($data, 0, $n);
430         $esc_data =~ s/[^[:print:]]/./g;
431         print "|", " " x $start, $esc_data, " " x ($per_line - $end), "|";
432
433         print "\n";
434
435         $data = substr ($data, $n);
436         $ofs += $n;
437     }
438 }
439
440 # print_fs (%FS)
441 #
442 # Prints a list of files in %FS, which must be a file system
443 # as flattened by flatten_hierarchy() and normalized by
444 # normalize_fs().
445 sub print_fs {
446     my (%fs) = @_;
447     foreach my $name (sort keys %fs) {
448         my ($esc_name) = $name;
449         $esc_name =~ s/[^[:print:]]/./g;
450         print "$esc_name: ";
451         if (!is_dir ($fs{$name})) {
452             print +file_size ($fs{$name}), "-byte file";
453         } else {
454             print "directory";
455         }
456         print "\n";
457     }
458     print "(empty)\n" if !@_;
459 }
460
461 # normalize_fs (%FS)
462 #
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].
466 sub normalize_fs {
467     my (%fs) = @_;
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 _];
473     }
474     return %fs;
475 }
476
477 # is_dir ($VALUE)
478 #
479 # Takes a value like one in the hash returned by flatten_hierarchy()
480 # and returns 1 if it represents a directory, 0 otherwise.
481 sub is_dir {
482     my ($value) = @_;
483     return ref ($value) eq '' && $value eq 'directory';
484 }
485
486 # file_size ($VALUE)
487 #
488 # Takes a value like one in the hash returned by flatten_hierarchy()
489 # and returns the size of the file it represents.
490 sub file_size {
491     my ($value) = @_;
492     die if is_dir ($value);
493     die if ref ($value) ne 'ARRAY';
494     return @$value > 1 ? $value->[2] : length ($value->[0]);
495 }
496
497 # flatten_hierarchy ($HIER_FS, $PREFIX)
498 #
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];
505     my (%flat_fs);
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';
511         } else {
512             $flat_fs{"$prefix$name"} = $value;
513         }
514     }
515     return %flat_fs;
516 }
517
518 # read_tar ($ARCHIVE)
519 #
520 # Reads the ustar-format tar file in $ARCHIVE
521 # and returns a flattened file system for it.
522 sub read_tar {
523     my ($archive) = @_;
524     my (%content);
525     open (ARCHIVE, '<', $archive) or fail "$archive: open: $!\n";
526     for (;;) {
527         my ($header);
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";
531         }
532
533         last if $header eq "\0" x 512;
534
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";
539         }
540
541         # Verify checksum.
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;
545
546         # Get file name.
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 '';
551
552         # Get type.
553         my ($typeflag) = substr ($header, 156, 1);
554         $typeflag = '0' if $typeflag eq "\0";
555         fail "unknown file type '$typeflag'\n" if $typeflag !~ /[05]/;
556
557         # Get size.
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';
561
562         # Store content.
563         if (exists $content{$name}) {
564             fail "$archive: contains multiple entries for $name\n";
565         }
566         if ($typeflag eq '5') {
567             $content{$name} = 'directory';
568         } else {
569             my ($position) = sysseek (ARCHIVE, 0, SEEK_CUR);
570             $content{$name} = [$archive, $position, $size];
571             sysseek (ARCHIVE, int (($size + 511) / 512) * 512, SEEK_CUR);
572         }
573     }
574     close (ARCHIVE);
575     return %content;
576 }
577 \f
578 # Utilities.
579
580 sub fail {
581     finish ("FAIL", @_);
582 }
583
584 sub pass {
585     finish ("PASS", @_);
586 }
587
588 sub finish {
589     my ($verdict, @messages) = @_;
590
591     seek ($msg_file, 0, 0);
592     push (@messages, <$msg_file>);
593     close ($msg_file);
594     chomp (@messages);
595
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;
600     close (RESULT);
601
602     if ($verdict eq 'PASS') {
603         print STDOUT "pass $test\n";
604     } else {
605         print STDOUT "FAIL $test\n";
606     }
607     print STDOUT "$_\n" foreach @messages;
608
609     exit 0;
610 }
611
612 sub read_text_file {
613     my ($file_name) = @_;
614     open (FILE, '<', $file_name) or die "$file_name: open: $!\n";
615     my (@content) = <FILE>;
616     chomp (@content);
617     close (FILE);
618     return @content;
619 }
620
621 1;