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