+\f
+# File system extraction.
+
+# check_archive (\%CONTENTS)
+#
+# Checks that the extracted file system's contents match \%CONTENTS.
+# Each key in the hash is a file name. Each value may be:
+#
+# - $FILE: Name of a host file containing the expected contents.
+#
+# - [$FILE, $OFFSET, $LENGTH]: An excerpt of host file $FILE
+# comprising the $LENGTH bytes starting at $OFFSET.
+#
+# - [$CONTENTS]: The literal expected file contents, as a string.
+#
+# - {SUBDIR}: A subdirectory, in the same form described here,
+# recursively.
+sub check_archive {
+ my ($expected_hier) = @_;
+ my (@output) = read_text_file ("$test.get-output");
+ common_checks ("file system extraction run", @output);
+
+ @output = get_core_output ("file system extraction run", @output);
+ @output = grep (!/^[a-zA-Z0-9-_]+: exit\(\d+\)$/, @output);
+ fail join ("\n", "Error extracting file system:", @output) if @output;
+
+ my ($test_base_name) = $test;
+ $test_base_name =~ s%.*/%%;
+ $expected_hier->{$test_base_name} = $test;
+ $expected_hier->{'tar'} = 'tests/filesys/extended/tar';
+
+ my (%expected) = normalize_fs (flatten_hierarchy ($expected_hier, ""));
+ my (%actual) = read_tar ("$test.tar");
+
+ my ($errors) = 0;
+ foreach my $name (sort keys %expected) {
+ if (exists $actual{$name}) {
+ if (is_dir ($actual{$name}) && !is_dir ($expected{$name})) {
+ print "$name is a directory but should be an ordinary file.\n";
+ $errors++;
+ } elsif (!is_dir ($actual{$name}) && is_dir ($expected{$name})) {
+ print "$name is an ordinary file but should be a directory.\n";
+ $errors++;
+ }
+ } else {
+ print "$name is missing from the file system.\n";
+ $errors++;
+ }
+ }
+ foreach my $name (sort keys %actual) {
+ if (!exists $expected{$name}) {
+ if ($name =~ /^[[:print:]]+$/) {
+ print "$name exists in the file system but it should not.\n";
+ } else {
+ my ($esc_name) = $name;
+ $esc_name =~ s/[^[:print:]]/./g;
+ print <<EOF;
+$esc_name exists in the file system but should not. (The expected name
+of this file contains unusual characters that were printed as `.'.)
+EOF
+ }
+ $errors++;
+ }
+ }
+ if ($errors) {
+ print "\nActual contents of file system:\n";
+ print_fs (%actual);
+ print "\nExpected contents of file system:\n";
+ print_fs (%expected);
+ } else {
+ foreach my $name (sort keys %expected) {
+ if (!is_dir ($expected{$name})) {
+ my ($exp_file, $exp_length) = open_file ($expected{$name});
+ my ($act_file, $act_length) = open_file ($actual{$name});
+ $errors += !compare_files ($exp_file, $exp_length,
+ $act_file, $act_length, $name,
+ !$errors);
+ close ($exp_file);
+ close ($act_file);
+ }
+ }
+ }
+ fail "Extracted file system contents are not correct.\n" if $errors;
+}
+
+# open_file ([$FILE, $OFFSET, $LENGTH])
+# open_file ([$CONTENTS])
+#
+# Opens a file for the contents passed in, which must be in one of
+# the two above forms that correspond to check_archive() arguments.
+#
+# Returns ($HANDLE, $LENGTH), where $HANDLE is the file's handle and
+# $LENGTH is the number of bytes in the file's content.
+sub open_file {
+ my ($value) = @_;
+ die if ref ($value) ne 'ARRAY';
+
+ my ($file) = tempfile ();
+ my ($length);
+ if (@$value == 1) {
+ $length = length ($value->[0]);
+ $file = tempfile ();
+ syswrite ($file, $value->[0]) == $length
+ or die "writing temporary file: $!\n";
+ sysseek ($file, 0, SEEK_SET);
+ } elsif (@$value == 3) {
+ $length = $value->[2];
+ open ($file, '<', $value->[0]) or die "$value->[0]: open: $!\n";
+ die "$value->[0]: file is smaller than expected\n"
+ if -s $file < $value->[1] + $length;
+ sysseek ($file, $value->[1], SEEK_SET);
+ } else {
+ die;
+ }
+ return ($file, $length);
+}
+
+# compare_files ($A, $A_SIZE, $B, $B_SIZE, $NAME, $VERBOSE)
+#
+# Compares $A_SIZE bytes in $A to $B_SIZE bytes in $B.
+# ($A and $B are handles.)
+# If their contents differ, prints a brief message describing
+# the differences, using $NAME to identify the file.
+# The message contains more detail if $VERBOSE is nonzero.
+# Returns 1 if the contents are identical, 0 otherwise.
+sub compare_files {
+ my ($a, $a_size, $b, $b_size, $name, $verbose) = @_;
+ my ($ofs) = 0;
+ select(STDOUT);
+ for (;;) {
+ my ($a_amt) = $a_size >= 1024 ? 1024 : $a_size;
+ my ($b_amt) = $b_size >= 1024 ? 1024 : $b_size;
+ my ($a_data, $b_data);
+ if (!defined (sysread ($a, $a_data, $a_amt))
+ || !defined (sysread ($b, $b_data, $b_amt))) {
+ die "reading $name: $!\n";
+ }
+
+ my ($a_len) = length $a_data;
+ my ($b_len) = length $b_data;
+ last if $a_len == 0 && $b_len == 0;
+
+ if ($a_data ne $b_data) {
+ my ($min_len) = $a_len < $b_len ? $a_len : $b_len;
+ my ($diff_ofs);
+ for ($diff_ofs = 0; $diff_ofs < $min_len; $diff_ofs++) {
+ last if (substr ($a_data, $diff_ofs, 1)
+ ne substr ($b_data, $diff_ofs, 1));
+ }
+
+ printf "\nFile $name differs from expected "
+ . "starting at offset 0x%x.\n", $ofs + $diff_ofs;
+ if ($verbose ) {
+ print "Expected contents:\n";
+ hex_dump (substr ($a_data, $diff_ofs, 64), $ofs + $diff_ofs);
+ print "Actual contents:\n";
+ hex_dump (substr ($b_data, $diff_ofs, 64), $ofs + $diff_ofs);
+ }
+ return 0;
+ }
+
+ $ofs += $a_len;
+ $a_size -= $a_len;
+ $b_size -= $b_len;
+ }
+ return 1;
+}
+
+# hex_dump ($DATA, $OFS)
+#
+# Prints $DATA in hex and text formats.
+# The first byte of $DATA corresponds to logical offset $OFS
+# in whatever file the data comes from.
+sub hex_dump {
+ my ($data, $ofs) = @_;
+
+ if ($data eq '') {
+ printf " (File ends at offset %08x.)\n", $ofs;
+ return;
+ }
+
+ my ($per_line) = 16;
+ while ((my $size = length ($data)) > 0) {
+ my ($start) = $ofs % $per_line;
+ my ($end) = $per_line;
+ $end = $start + $size if $end - $start > $size;
+ my ($n) = $end - $start;
+
+ printf "0x%08x ", int ($ofs / $per_line) * $per_line;
+
+ # Hex version.
+ print " " x $start;
+ for my $i ($start...$end - 1) {
+ printf "%02x", ord (substr ($data, $i - $start, 1));
+ print $i == $per_line / 2 - 1 ? '-' : ' ';
+ }
+ print " " x ($per_line - $end);
+
+ # Character version.
+ my ($esc_data) = substr ($data, 0, $n);
+ $esc_data =~ s/[^[:print:]]/./g;
+ print "|", " " x $start, $esc_data, " " x ($per_line - $end), "|";
+
+ print "\n";
+
+ $data = substr ($data, $n);
+ $ofs += $n;
+ }
+}
+
+# print_fs (%FS)
+#
+# Prints a list of files in %FS, which must be a file system
+# as flattened by flatten_hierarchy() and normalized by
+# normalize_fs().
+sub print_fs {
+ my (%fs) = @_;
+ foreach my $name (sort keys %fs) {
+ my ($esc_name) = $name;
+ $esc_name =~ s/[^[:print:]]/./g;
+ print "$esc_name: ";
+ if (!is_dir ($fs{$name})) {
+ print +file_size ($fs{$name}), "-byte file";
+ } else {
+ print "directory";
+ }
+ print "\n";
+ }
+}
+
+# normalize_fs (%FS)
+#
+# Takes a file system as flattened by flatten_hierarchy().
+# Returns a similar file system in which values of the form $FILE
+# are replaced by those of the form [$FILE, $OFFSET, $LENGTH].
+sub normalize_fs {
+ my (%fs) = @_;
+ foreach my $name (keys %fs) {
+ my ($value) = $fs{$name};
+ next if is_dir ($value) || ref ($value) ne '';
+ die "can't open $value\n" if !stat $value;
+ $fs{$name} = [$value, 0, -s _];
+ }
+ return %fs;
+}
+
+# is_dir ($VALUE)
+#
+# Takes a value like one in the hash returned by flatten_hierarchy()
+# and returns 1 if it represents a directory, 0 otherwise.
+sub is_dir {
+ my ($value) = @_;
+ return ref ($value) eq '' && $value eq 'directory';
+}
+
+# file_size ($VALUE)
+#
+# Takes a value like one in the hash returned by flatten_hierarchy()
+# and returns the size of the file it represents.
+sub file_size {
+ my ($value) = @_;
+ die if is_dir ($value);
+ die if ref ($value) ne 'ARRAY';
+ return @$value > 1 ? $value->[2] : length ($value->[0]);
+}
+
+# flatten_hierarchy ($HIER_FS, $PREFIX)
+#
+# Takes a file system in the format expected by check_archive() and
+# returns a "flattened" version in which file names include all parent
+# directory names and the value of directories is just "directory".
+sub flatten_hierarchy {
+ my (%hier_fs) = %{$_[0]};
+ my ($prefix) = $_[1];
+ my (%flat_fs);
+ for my $name (keys %hier_fs) {
+ my ($value) = $hier_fs{$name};
+ if (ref $value eq 'HASH') {
+ %flat_fs = (%flat_fs, flatten_hierarchy ($value, "$prefix$name/"));
+ $flat_fs{"$prefix$name"} = 'directory';
+ } else {
+ $flat_fs{"$prefix$name"} = $value;
+ }
+ }
+ return %flat_fs;
+}
+
+# read_tar ($ARCHIVE)
+#
+# Reads the ustar-format tar file in $ARCHIVE
+# and returns a flattened file system for it.
+sub read_tar {
+ my ($archive) = @_;
+ my (%content);
+ open (ARCHIVE, '<', $archive) or fail "$archive: open: $1\n";
+ for (;;) {
+ my ($header);
+ if ((my $retval = sysread (ARCHIVE, $header, 512)) != 512) {
+ fail "$archive: unexpected end of file\n" if $retval >= 0;
+ fail "$archive: read: $!\n";
+ }
+
+ last if $header eq "\0" x 512;
+
+ # Verify magic numbers.
+ if (substr ($header, 257, 6) ne "ustar\0"
+ || substr ($header, 263, 2) ne '00') {
+ fail "$archive: corrupt ustar header\n";
+ }
+
+ # Verify checksum.
+ my ($chksum) = oct (unpack ("Z*", substr ($header, 148, 8, ' ' x 8)));
+ my ($correct_chksum) = unpack ("%32a*", $header);
+ fail "$archive: bad header checksum\n" if $chksum != $correct_chksum;
+
+ # Get file name.
+ my ($name) = unpack ("Z100", $header);
+ my ($prefix) = unpack ("Z*", substr ($header, 345));
+ $name = "$prefix/$name" if $prefix ne '';
+ fail "$archive: contains file with empty name" if $name eq '';
+
+ # Get type.
+ my ($typeflag) = substr ($header, 156, 1);
+ $typeflag = '0' if $typeflag eq "\0";
+ fail "unknown file type '$typeflag'\n" if $typeflag !~ /[05]/;
+
+ # Get size.
+ my ($size) = oct (unpack ("Z*", substr ($header, 124, 12)));
+ fail "bad size $size\n" if $size < 0;
+ $size = 0 if $typeflag eq '5';
+
+ # Store content.
+ if (exists $content{$name}) {
+ fail "$archive: contains multiple entries for $name\n";
+ }
+ if ($typeflag eq '5') {
+ $content{$name} = 'directory';
+ } else {
+ my ($position) = sysseek (ARCHIVE, 0, SEEK_CUR);
+ $content{$name} = [$archive, $position, $size];
+ sysseek (ARCHIVE, int (($size + 511) / 512) * 512, SEEK_CUR);
+ }
+ }
+ close (ARCHIVE);
+ return %content;
+}
+\f
+# Utilities.