I wrote this script somewhere around 1995-97 and it was the first from my pen that was more than a few lines long. I can't find it on disk at the moment but I posted it here in response to this question so I will drag it back from the Monastery in case the original remains elusive.
#!/usr/local/bin/perl -w
#
# Script requires two arguments, the name of the tar archive and the
# name of the directory into which the archive should be restored.
#
if($#ARGV != 1) {die "Usage: $0 tar-file dest-dir\n"}
$tar_file = shift @ARGV;
$dest_dir = shift @ARGV;
#
# Check that we can open the archive and that the directory is valid.
+Open
# a log file to record events.
#
use FileHandle;
open(TAR, "$tar_file") || die "Can't open tar archive\n";
die "$dest_dir is not a directory\n" unless(-d $dest_dir);
open(LOG, ">extract_log") || die "Can't open log file\n";
LOG->autoflush(1);
#
# Unset flags 'cos we haven't got to end of archive yet and we haven't
# found a bad checksum. Set up string values to check that we have
# reached the end of data for each file in the archive.
#
$eot = 0;
$bad_checksum = 0;
$eodata_str1 = pack "CC", 0, 128;
$eodata_str2 = pack "CC", 128, 128;
$eodata_str3 = pack "C", 0;
$eodata_str4 = pack "C", 128;
#
# Set flag so we look for a header at beginning of archive, initialise
# hash of objects in archive with duplicate names (because the utility
# on the Prime mini that produced the archives truncated filenames
# after 14 characters). Archive written in blocks of 512 bytes so
# read each block into a buffer. Fatal error if unable to read 512 byt
+es.
#
$need_hdr = 1;
%dups = ();
while(($len = read TAR, $buf, 512) && ! $bad_checksum)
{
die "Error reading archive\n" if $len != 512;
#
# Looking for header?
#
if($need_hdr)
{
#
# Archive terminates with two blocks of Ascii NULLs, wind up
# if second consecutive NULL block found when a header block i
+s
# expected, set flag if first block. Blocks of NULLs in data d
+o
# not matter as the data is copied out until the byte count in
# the header is satisfied.
#
unless(unpack "C512", $buf)
{
if($eot)
{
print LOG "\nEnd of archive reached\n\n";
last; # Finished reading block
+s.
}
else
{
$eot = 1;
next; # Get next block.
}
}
#
# Name of object in archive is held as a C-style NULL terminat
+ed
# string in the first 100 bytes of the header. Strip NULL onwa
+rds
# and strip any trailing "/" because, unlike UNIX tar files, t
+he
# Prime version does not seem to have separate entries for
# directories.
#
$object = substr($buf, 0, 100);
$object =~ s/\x00.*//;
$object =~ s/\/$//;
#
# Size of file held as octal value.
#
$size = oct(substr($buf, 124, 11));
#
# Header checksum held as octal vaue. Calculated as sum of Asc
+ii
# values of all bytes in the header assuming that the checksum
# field is all blanks (spaces). Save checksum and replace with
# spaces. Initialse calculated checksum, split header into
# individual characters and sum their ordinal values.
#
$chksum = substr($buf, 147, 8);
substr($buf, 147, 8) = " ";
$calc_chksum = 0;
@hdr_chars = split('', $buf);
foreach $char (@hdr_chars)
{
$calc_chksum += ord($char);
}
#
# Print name and size of object to log file, print indication
# of whether checksum was OK or not. If it was bad we don't
# want to carry on because data could also be corrupt.
#
print LOG "$object <-> $size ";
if($calc_chksum == oct($chksum))
{
print LOG "CHKOK ";
}
else
{
print LOG "CHKNO \n";
$bad_checksum = 1;
last;
}
#
# Initialise target directory from destination directory given
+ as
# an argument. Split object into path elements on '/', pop fil
+e
# name off end as last element.
#
$target_dir = $dest_dir;
@tree = split('/', $object);
$file = pop(@tree);
#
# Check that file name is not "." or "..", apparently legal in
# Primos, since we found one. Change to "__dot" or "__dotdot"
# which are less significant under Unix. Hopefully, there will
# not be any genuine files called either of those.
#
if($file eq ".")
{
$file = "__dot";
print LOG "ill-> $file ";
}
if($file eq "..")
{
$file = "__dotdot";
print LOG "ill-> $file ";
}
#
# Get directory elements one at a time concatenating them to t
+he
# target directory, make non-existent directories if necessary
+.
#
while($dir = shift(@tree))
{
$target_dir .= "/";
$target_dir .= $dir;
mkdir("$target_dir", 0755) unless(-x "$target_dir");
}
#
# Because of the Prime filename truncation problem, check if t
+he
# object we are about to restore already exists (the target
# directory specified in the arguments should always be empty
# as a precaution). If it does exist, increment the value in
# the hash indexed by object; use value to differentiate names
+.
#
if(-e "$target_dir/$file")
{
$dups{"$object"}++;
$file .= "__dup";
$file .= $dups{"$object"};
print LOG "dup-> $file ";
}
#
# Open file to be extracted from archive (will create). If the
# size field in header indicates that data will follow, unset
# the flag because next block should no be a header. If size i
+s
# zero however, file was empty so print message and close file
# again, leaving flag alone.
#
open(OUT, ">$target_dir/$file") || die "Couldn't open output\n
+";
if($size)
{
$need_hdr = 0;
}
else
{
print LOG "EMPTY\n";
close(OUT) || die "Couldn't close output\n";
}
}
else
{
#
# This is a data block.
#
if($size < 512)
{
#
# Are there less than 512 bytes of data remaining to be
# extracted from archive? Print only required bytes to
# file using "substr". Check that next pair of bytes (or
# single byte if 511 bytes were written) match possible
# strings defined above. Message either way, close file.
# Set header needed flag.
#
print OUT substr($buf, 0, $size);
if((index $buf, $eodata_str1, $size) == $size ||
(index $buf, $eodata_str2, $size) == $size ||
($size == 511 &&
((pack "C", ord(substr($buf, 511, 1))) eq $eodata_str3
+||
(pack "C", ord(substr($buf, 511, 1))) eq $eodata_str4))
+ ||
$size == 0)
{
print LOG "OK\n";
}
else
{
print LOG "NO\n";
}
close(OUT) || die "Couldn't close output\n";
$need_hdr = 1;
}
else
{
#
# Print the whole of the buffer to the extracted file. If
# bytes remaining after being decremented is zero this was
# last block and was all data. Print message, close file
# and set header needed flag.
#
print OUT $buf;
$size -= 512;
unless($size)
{
print LOG "OK\n";
close(OUT) || die "Couldn't close output\n";
$need_hdr = 1;
}
}
}
}
#
# If there are no more blocks to read but the last file being restored
# was not completed, put out error message.
#
unless($need_hdr)
{
print LOG "FAILED - $size bytes lost\n\n",
"ERROR - tar archive terminated abnormally\n\n";
print "ERROR - tar archive terminated abnormally\n",
"$object truncated, $size bytes lost\n";
}
#
# If the checksum of the last header processed was bad, print some
# indication of the fact.
#
if($bad_checksum)
{
print LOG "\nERROR - header checksum failed, aborting\n\n";
print "ERROR - header checksum failed, $object\n";
}
#
# Close tar archive, examine hash containing the objects that had
# duplicate names. Second and subsequent duplicate objects had "__dup1
+",
# "__dup2" etc. appended. Now rename the original with "__dup0" append
+ed.
# Print some stats
#
close(TAR) || die "Can't close tar archive\n";
foreach $orig (sort keys %dups)
{
$new = $orig . "__dup0";
print LOG "$orig had $dups{\"$orig\"} duplicate names, renaming to
+ $new ";
if(rename "$dest_dir/$orig", "$dest_dir/$new")
{
print LOG "OK\n";
}
else
{
print LOG "FAILED: $!\n";
}
}
close(LOG);
The platform was SPARC/Solaris, probably 2.5-ish, and maybe run against perl 5.005 if memory serves. There is no use strict and I think the script predated the introduction of the 4-argument form of substr. Package file handles are also in evidence although I'm not sure if lexical file handles were available then. It uses underscores in variables whereas my preference these days is to use camelCase :-)
