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 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 }
 448
 449 # normalize_fs (%FS)
 450 #
 451 # Takes a file system as flattened by flatten_hierarchy().
 452 # Returns a similar file system in which values of the form $FILE
 453 # are replaced by those of the form [$FILE, $OFFSET, $LENGTH].
 454 sub normalize_fs {
 455     my (%fs) = @_;
 456     foreach my $name (keys %fs) {
 457         my ($value) = $fs{$name};
 458         next if is_dir ($value) || ref ($value) ne '';
 459         die "can't open $value\n" if !stat $value;
 460         $fs{$name} = [$value, 0, -s _];
 461     }
 462     return %fs;
 463 }
 464
 465 # is_dir ($VALUE)
 466 #
 467 # Takes a value like one in the hash returned by flatten_hierarchy()
 468 # and returns 1 if it represents a directory, 0 otherwise.
 469 sub is_dir {
 470     my ($value) = @_;
 471     return ref ($value) eq '' && $value eq 'directory';
 472 }
 473
 474 # file_size ($VALUE)
 475 #
 476 # Takes a value like one in the hash returned by flatten_hierarchy()
 477 # and returns the size of the file it represents.
 478 sub file_size {
 479     my ($value) = @_;
 480     die if is_dir ($value);
 481     die if ref ($value) ne 'ARRAY';
 482     return @$value > 1 ? $value->[2] : length ($value->[0]);
 483 }
 484
 485 # flatten_hierarchy ($HIER_FS, $PREFIX)
 486 #
 487 # Takes a file system in the format expected by check_archive() and
 488 # returns a "flattened" version in which file names include all parent
 489 # directory names and the value of directories is just "directory".
 490 sub flatten_hierarchy {
 491     my (%hier_fs) = %{$_[0]};
 492     my ($prefix) = $_[1];
 493     my (%flat_fs);
 494     for my $name (keys %hier_fs) {
 495         my ($value) = $hier_fs{$name};
 496         if (ref $value eq 'HASH') {
 497             %flat_fs = (%flat_fs, flatten_hierarchy ($value, "$prefix$name/"));
 498             $flat_fs{"$prefix$name"} = 'directory';
 499         } else {
 500             $flat_fs{"$prefix$name"} = $value;
 501         }
 502     }
 503     return %flat_fs;
 504 }
 505
 506 # read_tar ($ARCHIVE)
 507 #
 508 # Reads the ustar-format tar file in $ARCHIVE
 509 # and returns a flattened file system for it.
 510 sub read_tar {
 511     my ($archive) = @_;
 512     my (%content);
 513     open (ARCHIVE, '<', $archive) or fail "$archive: open: $!\n";
 514     for (;;) {
 515         my ($header);
 516         if ((my $retval = sysread (ARCHIVE, $header, 512)) != 512) {
 517             fail "$archive: unexpected end of file\n" if $retval >= 0;
 518             fail "$archive: read: $!\n";
 519         }
 520
 521         last if $header eq "\0" x 512;
 522
 523         # Verify magic numbers.
 524         if (substr ($header, 257, 6) ne "ustar\0"
 525             || substr ($header, 263, 2) ne '00') {
 526             fail "$archive: corrupt ustar header\n";
 527         }
 528
 529         # Verify checksum.
 530         my ($chksum) = oct (unpack ("Z*", substr ($header, 148, 8, ' ' x 8)));
 531         my ($correct_chksum) = unpack ("%32a*", $header);
 532         fail "$archive: bad header checksum\n" if $chksum != $correct_chksum;
 533
 534         # Get file name.
 535         my ($name) = unpack ("Z100", $header);
 536         my ($prefix) = unpack ("Z*", substr ($header, 345));
 537         $name = "$prefix/$name" if $prefix ne '';
 538         fail "$archive: contains file with empty name" if $name eq '';
 539
 540         # Get type.
 541         my ($typeflag) = substr ($header, 156, 1);
 542         $typeflag = '0' if $typeflag eq "\0";
 543         fail "unknown file type '$typeflag'\n" if $typeflag !~ /[05]/;
 544
 545         # Get size.
 546         my ($size) = oct (unpack ("Z*", substr ($header, 124, 12)));
 547         fail "bad size $size\n" if $size < 0;
 548         $size = 0 if $typeflag eq '5';
 549
 550         # Store content.
 551         if (exists $content{$name}) {
 552             fail "$archive: contains multiple entries for $name\n";
 553         }
 554         if ($typeflag eq '5') {
 555             $content{$name} = 'directory';
 556         } else {
 557             my ($position) = sysseek (ARCHIVE, 0, SEEK_CUR);
 558             $content{$name} = [$archive, $position, $size];
 559             sysseek (ARCHIVE, int (($size + 511) / 512) * 512, SEEK_CUR);
 560         }
 561     }
 562     close (ARCHIVE);
 563     return %content;
 564 }
 565 \f
 566 # Utilities.
 567
 568 sub fail {
 569     finish ("FAIL", @_);
 570 }
 571
 572 sub pass {
 573     finish ("PASS", @_);
 574 }
 575
 576 sub finish {
 577     my ($verdict, @messages) = @_;
 578
 579     seek ($msg_file, 0, 0);
 580     push (@messages, <$msg_file>);
 581     close ($msg_file);
 582     chomp (@messages);
 583
 584     my ($result_fn) = "$test.result";
 585     open (RESULT, '>', $result_fn) or die "$result_fn: create: $!\n";
 586     print RESULT "$verdict\n";
 587     print RESULT "$_\n" foreach @messages;
 588     close (RESULT);
 589
 590     if ($verdict eq 'PASS') {
 591         print STDOUT "pass $test\n";
 592     } else {
 593         print STDOUT "FAIL $test\n";
 594     }
 595     print STDOUT "$_\n" foreach @messages;
 596
 597     exit 0;
 598 }
 599
 600 sub read_text_file {
 601     my ($file_name) = @_;
 602     open (FILE, '<', $file_name) or die "$file_name: open: $!\n";
 603     my (@content) = <FILE>;
 604     chomp (@content);
 605     close (FILE);
 606     return @content;
 607 }
 608
 609 1;