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 my ($msg_file) = tempfile ();
  14 select ($msg_file);
  15 \f
  16 # Generic testing.
  17
  18 sub check_expected {
  19     my ($expected) = pop @_;
  20     my (@options) = @_;
  21     my (@output) = read_text_file ("$test.output");
  22     common_checks ("run", @output);
  23     compare_output ("run", @options, \@output, $expected);
  24 }
  25
  26 sub common_checks {
  27     my ($run, @output) = @_;
  28
  29     fail "\u$run produced no output at all\n" if @output == 0;
  30
  31     check_for_panic ($run, @output);
  32     check_for_keyword ($run, "FAIL", @output);
  33     check_for_triple_fault ($run, @output);
  34     check_for_keyword ($run, "TIMEOUT", @output);
  35
  36     fail "\u$run didn't start up properly: no \"Pintos booting\" message\n"
  37       if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
  38     fail "\u$run didn't start up properly: no \"Boot complete\" message\n"
  39       if !grep (/Boot complete/, @output);
  40     fail "\u$run didn't shut down properly: no \"Timer: # ticks\" message\n"
  41       if !grep (/Timer: \d+ ticks/, @output);
  42     fail "\u$run didn't shut down properly: no \"Powering off\" message\n"
  43       if !grep (/Powering off/, @output);
  44 }
  45
  46 sub check_for_panic {
  47     my ($run, @output) = @_;
  48
  49     my ($panic) = grep (/PANIC/, @output);
  50     return unless defined $panic;
  51
  52     print "Kernel panic in $run: ", substr ($panic, index ($panic, "PANIC")),
  53       "\n";
  54
  55     my (@stack_line) = grep (/Call stack:/, @output);
  56     if (@stack_line != 0) {
  57         my ($addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
  58
  59         # Find a user program to translate user virtual addresses.
  60         my ($userprog) = "";
  61         $userprog = "$test"
  62           if grep (hex ($_) < 0xc0000000, split (' ', $addrs)) > 0 && -e $test;
  63
  64         # Get and print the backtrace.
  65         my ($trace) = scalar (`backtrace kernel.o $userprog $addrs`);
  66         print "Call stack:$addrs\n";
  67         print "Translation of call stack:\n";
  68         print $trace;
  69
  70         # Print disclaimer.
  71         if ($userprog ne '' && index ($trace, $userprog) >= 0) {
  72             print <<EOF;
  73 Translations of user virtual addresses above are based on a guess at
  74 the binary to use.  If this guess is incorrect, then those
  75 translations will be misleading.
  76 EOF
  77         }
  78     }
  79
  80     if ($panic =~ /sec_no \< d-\>capacity/) {
  81         print <<EOF;
  82 \nThis assertion commonly fails when accessing a file via an inode that
  83 has been closed and freed.  Freeing an inode clears all its sector
  84 indexes to 0xcccccccc, which is not a valid sector number for disks
  85 smaller than about 1.6 TB.
  86 EOF
  87     }
  88
  89     fail;
  90 }
  91
  92 sub check_for_keyword {
  93     my ($run, $keyword, @output) = @_;
  94
  95     my ($kw_line) = grep (/$keyword/, @output);
  96     return unless defined $kw_line;
  97
  98     # Most output lines are prefixed by (test-name).  Eliminate this
  99     # from our message for brevity.
 100     $kw_line =~ s/^\([^\)]+\)\s+//;
 101     print "$run: $kw_line\n";
 102
 103     fail;
 104 }
 105
 106 sub check_for_triple_fault {
 107     my ($run, @output) = @_;
 108
 109     my ($reboots) = grep (/Pintos booting/, @output) - 1;
 110     return unless $reboots > 0;
 111
 112     print <<EOF;
 113 \u$run spontaneously rebooted $reboots times.
 114 This is most often caused by unhandled page faults.
 115 Read the Triple Faults section in the Debugging chapter
 116 of the Pintos manual for more information.
 117 EOF
 118
 119     fail;
 120 }
 121
 122 # Get @output without header or trailer.
 123 sub get_core_output {
 124     my ($run, @output) = @_;
 125     my ($p);
 126
 127     my ($process);
 128     my ($start);
 129     for my $i (0...$#_) {
 130         $start = $i + 1, last
 131           if ($process) = $output[$i] =~ /^Executing '(\S+).*':$/;
 132     }
 133
 134     my ($end);
 135     for my $i ($start...$#output) {
 136         $end = $i - 1, last if $output[$i] =~ /^Execution of '.*' complete.$/;
 137     }
 138
 139     fail "\u$run didn't start a thread or process\n" if !defined $start;
 140     fail "\u$run started '$process' but it never finished\n" if !defined $end;
 141
 142     return @output[$start...$end];
 143 }
 144
 145 sub compare_output {
 146     my ($run) = shift @_;
 147     my ($expected) = pop @_;
 148     my ($output) = pop @_;
 149     my (%options) = @_;
 150
 151     my (@output) = get_core_output ($run, @$output);
 152     fail "\u$run didn't produce any output" if !@output;
 153
 154     my $ignore_exit_codes = exists $options{IGNORE_EXIT_CODES};
 155     if ($ignore_exit_codes) {
 156         delete $options{IGNORE_EXIT_CODES};
 157         @output = grep (!/^[a-zA-Z0-9-_]+: exit\(\-?\d+\)$/, @output);
 158     }
 159     my $ignore_user_faults = exists $options{IGNORE_USER_FAULTS};
 160     if ($ignore_user_faults) {
 161         delete $options{IGNORE_USER_FAULTS};
 162         @output = grep (!/^Page fault at.*in user context\.$/
 163                         && !/: dying due to interrupt 0x0e \(.*\).$/
 164                         && !/^Interrupt 0x0e \(.*\) at eip=/
 165                         && !/^ cr2=.* error=.*/
 166                         && !/^ eax=.* ebx=.* ecx=.* edx=.*/
 167                         && !/^ esi=.* edi=.* esp=.* ebp=.*/
 168                         && !/^ cs=.* ds=.* es=.* ss=.*/, @output);
 169     }
 170     die "unknown option " . (keys (%options))[0] . "\n" if %options;
 171
 172     my ($msg);
 173
 174     # Compare actual output against each allowed output.
 175     if (ref ($expected) eq 'ARRAY') {
 176         my ($i) = 0;
 177         $expected = {map ((++$i => $_), @$expected)};
 178     }
 179     foreach my $key (keys %$expected) {
 180         my (@expected) = split ("\n", $expected->{$key});
 181
 182         $msg .= "Acceptable output:\n";
 183         $msg .= join ('', map ("  $_\n", @expected));
 184
 185         # Check whether actual and expected match.
 186         # If it's a perfect match, we're done.
 187         if ($#output == $#expected) {
 188             my ($eq) = 1;
 189             for (my ($i) = 0; $i <= $#expected; $i++) {
 190                 $eq = 0 if $output[$i] ne $expected[$i];
 191             }
 192             return $key if $eq;
 193         }
 194
 195         # They differ.  Output a diff.
 196         my (@diff) = "";
 197         my ($d) = Algorithm::Diff->new (\@expected, \@output);
 198         while ($d->Next ()) {
 199             my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
 200             if ($d->Same ()) {
 201                 push (@diff, map ("  $_\n", $d->Items (1)));
 202             } else {
 203                 push (@diff, map ("- $_\n", $d->Items (1))) if $d->Items (1);
 204                 push (@diff, map ("+ $_\n", $d->Items (2))) if $d->Items (2);
 205             }
 206         }
 207
 208         $msg .= "Differences in `diff -u' format:\n";
 209         $msg .= join ('', @diff);
 210     }
 211
 212     # Failed to match.  Report failure.
 213     $msg .= "\n(Process exit codes are excluded for matching purposes.)\n"
 214       if $ignore_exit_codes;
 215     $msg .= "\n(User fault messages are excluded for matching purposes.)\n"
 216       if $ignore_user_faults;
 217     fail "Test output failed to match any acceptable form.\n\n$msg";
 218 }
 219 \f
 220 # File system extraction.
 221
 222 # check_archive (\%CONTENTS)
 223 #
 224 # Checks that the extracted file system's contents match \%CONTENTS.
 225 # Each key in the hash is a file name.  Each value may be:
 226 #
 227 #       - $FILE: Name of a host file containing the expected contents.
 228 #
 229 #       - [$FILE, $OFFSET, $LENGTH]: An excerpt of host file $FILE
 230 #         comprising the $LENGTH bytes starting at $OFFSET.
 231 #
 232 #       - [$CONTENTS]: The literal expected file contents, as a string.
 233 #
 234 #       - {SUBDIR}: A subdirectory, in the same form described here,
 235 #         recursively.
 236 sub check_archive {
 237     my ($expected_hier) = @_;
 238     my (@output) = read_text_file ("$test.get-output");
 239     common_checks ("file system extraction run", @output);
 240
 241     @output = get_core_output ("file system extraction run", @output);
 242     @output = grep (!/^[a-zA-Z0-9-_]+: exit\(\d+\)$/, @output);
 243     fail join ("\n", "Error extracting file system:", @output) if @output;
 244
 245     my ($test_base_name) = $test;
 246     $test_base_name =~ s%.*/%%;
 247     $expected_hier->{$test_base_name} = $test;
 248     $expected_hier->{'tar'} = 'tests/filesys/extended/tar';
 249
 250     my (%expected) = normalize_fs (flatten_hierarchy ($expected_hier, ""));
 251     my (%actual) = read_tar ("$test.tar");
 252
 253     my ($errors) = 0;
 254     foreach my $name (sort keys %expected) {
 255         if (exists $actual{$name}) {
 256             if (is_dir ($actual{$name}) && !is_dir ($expected{$name})) {
 257                 print "$name is a directory but should be an ordinary file.\n";
 258                 $errors++;
 259             } elsif (!is_dir ($actual{$name}) && is_dir ($expected{$name})) {
 260                 print "$name is an ordinary file but should be a directory.\n";
 261                 $errors++;
 262             }
 263         } else {
 264             print "$name is missing from the file system.\n";
 265             $errors++;
 266         }
 267     }
 268     foreach my $name (sort keys %actual) {
 269         if (!exists $expected{$name}) {
 270             if ($name =~ /^[[:print:]]+$/) {
 271                 print "$name exists in the file system but it should not.\n";
 272             } else {
 273                 my ($esc_name) = $name;
 274                 $esc_name =~ s/[^[:print:]]/./g;
 275                 print <<EOF;
 276 $esc_name exists in the file system but should not.  (The expected name
 277 of this file contains unusual characters that were printed as `.'.)
 278 EOF
 279             }
 280             $errors++;
 281         }
 282     }
 283     if ($errors) {
 284         print "\nActual contents of file system:\n";
 285         print_fs (%actual);
 286         print "\nExpected contents of file system:\n";
 287         print_fs (%expected);
 288     } else {
 289         foreach my $name (sort keys %expected) {
 290             if (!is_dir ($expected{$name})) {
 291                 my ($exp_file, $exp_length) = open_file ($expected{$name});
 292                 my ($act_file, $act_length) = open_file ($actual{$name});
 293                 $errors += !compare_files ($exp_file, $exp_length,
 294                                            $act_file, $act_length, $name,
 295                                            !$errors);
 296                 close ($exp_file);
 297                 close ($act_file);
 298             }
 299         }
 300     }
 301     fail "Extracted file system contents are not correct.\n" if $errors;
 302 }
 303
 304 # open_file ([$FILE, $OFFSET, $LENGTH])
 305 # open_file ([$CONTENTS])
 306 #
 307 # Opens a file for the contents passed in, which must be in one of
 308 # the two above forms that correspond to check_archive() arguments.
 309 #
 310 # Returns ($HANDLE, $LENGTH), where $HANDLE is the file's handle and
 311 # $LENGTH is the number of bytes in the file's content.
 312 sub open_file {
 313     my ($value) = @_;
 314     die if ref ($value) ne 'ARRAY';
 315
 316     my ($file) = tempfile ();
 317     my ($length);
 318     if (@$value == 1) {
 319         $length = length ($value->[0]);
 320         $file = tempfile ();
 321         syswrite ($file, $value->[0]) == $length
 322           or die "writing temporary file: $!\n";
 323         sysseek ($file, 0, SEEK_SET);
 324     } elsif (@$value == 3) {
 325         $length = $value->[2];
 326         open ($file, '<', $value->[0]) or die "$value->[0]: open: $!\n";
 327         die "$value->[0]: file is smaller than expected\n"
 328           if -s $file < $value->[1] + $length;
 329         sysseek ($file, $value->[1], SEEK_SET);
 330     } else {
 331         die;
 332     }
 333     return ($file, $length);
 334 }
 335
 336 # compare_files ($A, $A_SIZE, $B, $B_SIZE, $NAME, $VERBOSE)
 337 #
 338 # Compares $A_SIZE bytes in $A to $B_SIZE bytes in $B.
 339 # ($A and $B are handles.)
 340 # If their contents differ, prints a brief message describing
 341 # the differences, using $NAME to identify the file.
 342 # The message contains more detail if $VERBOSE is nonzero.
 343 # Returns 1 if the contents are identical, 0 otherwise.
 344 sub compare_files {
 345     my ($a, $a_size, $b, $b_size, $name, $verbose) = @_;
 346     my ($ofs) = 0;
 347     select(STDOUT);
 348     for (;;) {
 349         my ($a_amt) = $a_size >= 1024 ? 1024 : $a_size;
 350         my ($b_amt) = $b_size >= 1024 ? 1024 : $b_size;
 351         my ($a_data, $b_data);
 352         if (!defined (sysread ($a, $a_data, $a_amt))
 353             || !defined (sysread ($b, $b_data, $b_amt))) {
 354             die "reading $name: $!\n";
 355         }
 356
 357         my ($a_len) = length $a_data;
 358         my ($b_len) = length $b_data;
 359         last if $a_len == 0 && $b_len == 0;
 360
 361         if ($a_data ne $b_data) {
 362             my ($min_len) = $a_len < $b_len ? $a_len : $b_len;
 363             my ($diff_ofs);
 364             for ($diff_ofs = 0; $diff_ofs < $min_len; $diff_ofs++) {
 365                 last if (substr ($a_data, $diff_ofs, 1)
 366                          ne substr ($b_data, $diff_ofs, 1));
 367             }
 368
 369             printf "\nFile $name differs from expected "
 370               . "starting at offset 0x%x.\n", $ofs + $diff_ofs;
 371             if ($verbose ) {
 372                 print "Expected contents:\n";
 373                 hex_dump (substr ($a_data, $diff_ofs, 64), $ofs + $diff_ofs);
 374                 print "Actual contents:\n";
 375                 hex_dump (substr ($b_data, $diff_ofs, 64), $ofs + $diff_ofs);
 376             }
 377             return 0;
 378         }
 379
 380         $ofs += $a_len;
 381         $a_size -= $a_len;
 382         $b_size -= $b_len;
 383     }
 384     return 1;
 385 }
 386
 387 # hex_dump ($DATA, $OFS)
 388 #
 389 # Prints $DATA in hex and text formats.
 390 # The first byte of $DATA corresponds to logical offset $OFS
 391 # in whatever file the data comes from.
 392 sub hex_dump {
 393     my ($data, $ofs) = @_;
 394
 395     if ($data eq '') {
 396         printf "  (File ends at offset %08x.)\n", $ofs;
 397         return;
 398     }
 399
 400     my ($per_line) = 16;
 401     while ((my $size = length ($data)) > 0) {
 402         my ($start) = $ofs % $per_line;
 403         my ($end) = $per_line;
 404         $end = $start + $size if $end - $start > $size;
 405         my ($n) = $end - $start;
 406
 407         printf "0x%08x  ", int ($ofs / $per_line) * $per_line;
 408
 409         # Hex version.
 410         print "   " x $start;
 411         for my $i ($start...$end - 1) {
 412             printf "%02x", ord (substr ($data, $i - $start, 1));
 413             print $i == $per_line / 2 - 1 ? '-' : ' ';
 414         }
 415         print "   " x ($per_line - $end);
 416
 417         # Character version.
 418         my ($esc_data) = substr ($data, 0, $n);
 419         $esc_data =~ s/[^[:print:]]/./g;
 420         print "|", " " x $start, $esc_data, " " x ($per_line - $end), "|";
 421
 422         print "\n";
 423
 424         $data = substr ($data, $n);
 425         $ofs += $n;
 426     }
 427 }
 428
 429 # print_fs (%FS)
 430 #
 431 # Prints a list of files in %FS, which must be a file system
 432 # as flattened by flatten_hierarchy() and normalized by
 433 # normalize_fs().
 434 sub print_fs {
 435     my (%fs) = @_;
 436     foreach my $name (sort keys %fs) {
 437         my ($esc_name) = $name;
 438         $esc_name =~ s/[^[:print:]]/./g;
 439         print "$esc_name: ";
 440         if (!is_dir ($fs{$name})) {
 441             print +file_size ($fs{$name}), "-byte file";
 442         } else {
 443             print "directory";
 444         }
 445         print "\n";
 446     }
 447     print "(empty)\n" if !@_;
 448 }
 449
 450 # normalize_fs (%FS)
 451 #
 452 # Takes a file system as flattened by flatten_hierarchy().
 453 # Returns a similar file system in which values of the form $FILE
 454 # are replaced by those of the form [$FILE, $OFFSET, $LENGTH].
 455 sub normalize_fs {
 456     my (%fs) = @_;
 457     foreach my $name (keys %fs) {
 458         my ($value) = $fs{$name};
 459         next if is_dir ($value) || ref ($value) ne '';
 460         die "can't open $value\n" if !stat $value;
 461         $fs{$name} = [$value, 0, -s _];
 462     }
 463     return %fs;
 464 }
 465
 466 # is_dir ($VALUE)
 467 #
 468 # Takes a value like one in the hash returned by flatten_hierarchy()
 469 # and returns 1 if it represents a directory, 0 otherwise.
 470 sub is_dir {
 471     my ($value) = @_;
 472     return ref ($value) eq '' && $value eq 'directory';
 473 }
 474
 475 # file_size ($VALUE)
 476 #
 477 # Takes a value like one in the hash returned by flatten_hierarchy()
 478 # and returns the size of the file it represents.
 479 sub file_size {
 480     my ($value) = @_;
 481     die if is_dir ($value);
 482     die if ref ($value) ne 'ARRAY';
 483     return @$value > 1 ? $value->[2] : length ($value->[0]);
 484 }
 485
 486 # flatten_hierarchy ($HIER_FS, $PREFIX)
 487 #
 488 # Takes a file system in the format expected by check_archive() and
 489 # returns a "flattened" version in which file names include all parent
 490 # directory names and the value of directories is just "directory".
 491 sub flatten_hierarchy {
 492     my (%hier_fs) = %{$_[0]};
 493     my ($prefix) = $_[1];
 494     my (%flat_fs);
 495     for my $name (keys %hier_fs) {
 496         my ($value) = $hier_fs{$name};
 497         if (ref $value eq 'HASH') {
 498             %flat_fs = (%flat_fs, flatten_hierarchy ($value, "$prefix$name/"));
 499             $flat_fs{"$prefix$name"} = 'directory';
 500         } else {
 501             $flat_fs{"$prefix$name"} = $value;
 502         }
 503     }
 504     return %flat_fs;
 505 }
 506
 507 # read_tar ($ARCHIVE)
 508 #
 509 # Reads the ustar-format tar file in $ARCHIVE
 510 # and returns a flattened file system for it.
 511 sub read_tar {
 512     my ($archive) = @_;
 513     my (%content);
 514     open (ARCHIVE, '<', $archive) or fail "$archive: open: $!\n";
 515     for (;;) {
 516         my ($header);
 517         if ((my $retval = sysread (ARCHIVE, $header, 512)) != 512) {
 518             fail "$archive: unexpected end of file\n" if $retval >= 0;
 519             fail "$archive: read: $!\n";
 520         }
 521
 522         last if $header eq "\0" x 512;
 523
 524         # Verify magic numbers.
 525         if (substr ($header, 257, 6) ne "ustar\0"
 526             || substr ($header, 263, 2) ne '00') {
 527             fail "$archive: corrupt ustar header\n";
 528         }
 529
 530         # Verify checksum.
 531         my ($chksum) = oct (unpack ("Z*", substr ($header, 148, 8, ' ' x 8)));
 532         my ($correct_chksum) = unpack ("%32a*", $header);
 533         fail "$archive: bad header checksum\n" if $chksum != $correct_chksum;
 534
 535         # Get file name.
 536         my ($name) = unpack ("Z100", $header);
 537         my ($prefix) = unpack ("Z*", substr ($header, 345));
 538         $name = "$prefix/$name" if $prefix ne '';
 539         fail "$archive: contains file with empty name" if $name eq '';
 540
 541         # Get type.
 542         my ($typeflag) = substr ($header, 156, 1);
 543         $typeflag = '0' if $typeflag eq "\0";
 544         fail "unknown file type '$typeflag'\n" if $typeflag !~ /[05]/;
 545
 546         # Get size.
 547         my ($size) = oct (unpack ("Z*", substr ($header, 124, 12)));
 548         fail "bad size $size\n" if $size < 0;
 549         $size = 0 if $typeflag eq '5';
 550
 551         # Store content.
 552         if (exists $content{$name}) {
 553             fail "$archive: contains multiple entries for $name\n";
 554         }
 555         if ($typeflag eq '5') {
 556             $content{$name} = 'directory';
 557         } else {
 558             my ($position) = sysseek (ARCHIVE, 0, SEEK_CUR);
 559             $content{$name} = [$archive, $position, $size];
 560             sysseek (ARCHIVE, int (($size + 511) / 512) * 512, SEEK_CUR);
 561         }
 562     }
 563     close (ARCHIVE);
 564     return %content;
 565 }
 566 \f
 567 # Utilities.
 568
 569 sub fail {
 570     finish ("FAIL", @_);
 571 }
 572
 573 sub pass {
 574     finish ("PASS", @_);
 575 }
 576
 577 sub finish {
 578     my ($verdict, @messages) = @_;
 579
 580     seek ($msg_file, 0, 0);
 581     push (@messages, <$msg_file>);
 582     close ($msg_file);
 583     chomp (@messages);
 584
 585     my ($result_fn) = "$test.result";
 586     open (RESULT, '>', $result_fn) or die "$result_fn: create: $!\n";
 587     print RESULT "$verdict\n";
 588     print RESULT "$_\n" foreach @messages;
 589     close (RESULT);
 590
 591     if ($verdict eq 'PASS') {
 592         print STDOUT "pass $test\n";
 593     } else {
 594         print STDOUT "FAIL $test\n";
 595     }
 596     print STDOUT "$_\n" foreach @messages;
 597
 598     exit 0;
 599 }
 600
 601 sub read_text_file {
 602     my ($file_name) = @_;
 603     open (FILE, '<', $file_name) or die "$file_name: open: $!\n";
 604     my (@content) = <FILE>;
 605     chomp (@content);
 606     close (FILE);
 607     return @content;
 608 }
 609
 610 1;