pintos-os.org Git - pintos-anon/blob - 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;