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