# -*- perl -*-
#
# $Id: Tarfile.pm,v 1.9 1997/12/20 20:43:08 ejb Exp $
# $Source: /home/ejb/source/perl/modules/RCS/Tarfile.pm,v $
# $Author: ejb $
#

package Tarfile;

require TarHeader;

require 5.000;
use strict;

my $package = "Tarfile";

# Field names
my $f_filename = "filename";
my $f_blockf = "blockf";
my $f_mode = "mode";
my $f_filehandle = "filehandle";
my $f_buffer = "buffer";

# Static Variables
# blocksize is the size of one block in bytes
my $blocksize = 512;
# blockfactor is the number of blocks written out at once.
my $def_blockfactor = 20;
my $tar_namelen = 100;
my $tar_header = 'a100 a8 a8 a8 a12 a12 a8 a1 a100 a6 a2 a32 a32 a8 a8 a155';
my $chksum_start = 148;
my $chksum_end = $chksum_start + 7;

my $mode_read = 1;
my $mode_write = 2;

my $ftype_file = '0';
my $ftype_hardlink = '1';
my $ftype_symlink = '2';
my $ftype_chardev = '3';
my $ftype_blockdev = '4';
my $ftype_dir = '5';
my $ftype_pipe = '6';

#
# Constructors and destructors
#

sub p_new
{
    my $class = shift;
    my $rep = +{$package => {} };

    if ((@_ < 1) || (@_ > 2))
    {
	die "$package: p_new $package(filename[, blockf])\n";
    }

    my ($filename, $blockf) = (@_, $def_blockfactor);

    $rep->{$package}{$f_filename} = $filename;
    $rep->{$package}{$f_blockf} = $blockf;
    $rep->{$package}{$f_mode} = 0;
    $rep->{$package}{$f_filehandle} = undef;
    $rep->{$package}{$f_buffer} = "";

    bless $rep, $class;
}

sub new_create
{
    my $class = shift;
    my $rep = &p_new($class, @_);
    my $filename = $rep->p_filename();
    local(*FH);
    open(FH, ">$filename") or
	die "$package: can't create $filename: $!\n";
    binmode FH;

    $rep->{$package}{$f_mode} = $mode_write;
    $rep->{$package}{$f_filehandle} = *FH;

    $rep;
}

sub new_read
{
    my $class = shift;
    my $rep = &p_new($class, @_);
    my $filename = $rep->p_filename();
    local(*FH);
    open(FH, "<$filename") or
	die "$package: can't open $filename to read: $!\n";
    binmode FH;

    $rep->{$package}{$f_mode} = $mode_read;
    $rep->{$package}{$f_filehandle} = *FH;

    $rep;
}

sub new_read_fh
{
    my $class = shift;
    my @args = (@_);
    local(*FH) = $args[0];
    $args[0] = "fileno " . fileno(FH);
    my $rep = &p_new($class, @args);

    $rep->{$package}{$f_mode} = $mode_read;
    $rep->{$package}{$f_filehandle} = *FH;

    $rep;
}

sub DESTROY
{
    my $rep = shift;
    $rep->close();
}

#
# Accessors
#

sub p_filename
{
    my $rep = shift;
    $rep->{$package}{$f_filename};
}

sub p_blockf
{
    my $rep = shift;
    $rep->{$package}{$f_blockf};
}

sub p_mode
{
    my $rep = shift;
    $rep->{$package}{$f_mode} = $_[0] if @_;
    $rep->{$package}{$f_mode};
}

sub p_filehandle
{
    my $rep = shift;
    $rep->{$package}{$f_filehandle} = $_[0] if @_;
    $rep->{$package}{$f_filehandle};
}

sub p_buffer_ref
{
    my $rep = shift;
    \$rep->{$package}{$f_buffer};
}

#
# Utilties
#

sub p_octal_to_decimal
{
    my $num = shift;
    $num =~ s/\D//g;
    oct("0$num");
}

sub p_parse_header
{
    my ($hdr) = shift;
    die "$package: hdr must be $blocksize bytes\n"
	if (length($hdr) != $blocksize);
    my (@hdr) = (unpack("c$blocksize", $hdr));
    my ($name, $mode, $uid, $gid, $size, $mtime, $chksum,
	$typeflag, $linkname, $magic, $version, $uname,
	$gname, $devmajor, $devminor, $prefix) = unpack($tar_header, $hdr);
    $magic = $version = $uname = $gname = $devmajor = $devminor = "";
    $name =~ s/\000.*//;
    $mode =~ s/\D//g;
    $uid = &p_octal_to_decimal($uid);
    $gid = &p_octal_to_decimal($gid);
    $size = &p_octal_to_decimal($size);
    $mtime = &p_octal_to_decimal($mtime);
    $chksum = &p_octal_to_decimal($chksum);
    $prefix =~ s/\000.*//;
    $name = $prefix . $name;

    @hdr[$chksum_start..$chksum_end] = unpack('c8', ' ' x 8);
    my $sum = 0;
    map { $sum += $_ } @hdr;

    if ($sum != $chksum)
    {
	warn "$package: checksum mismatch (actual $sum, recorded $chksum)\n";
    }

    new TarHeader($name, $mode, $uid, $gid,
		  $size, $mtime, $typeflag, $linkname);     
}

sub p_unparse_header
{
    my $tarheader = shift;
    my ($name, $mode, $uid, $gid, $size, $mtime, $typeflag, $linkname) =
	($tarheader->name(),
	 $tarheader->mode(),
	 $tarheader->uid(),
	 $tarheader->gid(),
	 $tarheader->size(),
	 $tarheader->mtime(),
	 $tarheader->typeflag(),
	 $tarheader->linkname());
    if (length($name) > $tar_namelen)
    {
	$name = substr($name, 0, $tar_namelen);
    }
    if (length($linkname) > $tar_namelen)
    {
	$name = substr($linkname, 0, $tar_namelen);
    }
    $name .= "\000" x ($tar_namelen - length($name));
    $linkname .= "\000" x ($tar_namelen - length($linkname));
    $size = (($typeflag eq $ftype_file) ? $size :
	     ($typeflag eq $ftype_symlink) ? length($linkname) :
	     0);
    my $hdr;
    $hdr = $name;
    $hdr .= sprintf("%-8o", $mode);
    $hdr .= sprintf("%-8o", $uid);
    $hdr .= sprintf("%-8o", $gid);
    $hdr .= sprintf("%-12o", $size);
    $hdr .= sprintf("%-12o", $mtime);
    $hdr .= (' ' x 8);
    $hdr .= $typeflag;
    $hdr .= $linkname;
    $hdr .= ("\000" x ($blocksize - length($hdr)));
    my @hdr = unpack('c512', $hdr);
    my $sum = 0;
    map { $sum += $_ } @hdr;
    my $chksum = sprintf("%-8o", $sum);
    @hdr[$chksum_start..$chksum_end] = unpack('c8', $chksum);
    pack('c512', @hdr);
}

sub p_assert_write_mode
{
    my $rep = shift;
    $rep->p_mode() == $mode_write or
	die "$package: write_mode assertion failed.\n";
}

sub p_append
{
    my $rep = shift;

    $rep->p_assert_write_mode();

    my $buf = $rep->p_buffer_ref();
    my $data = shift;
    $$buf .= $data;
    $rep->p_flush();
}

sub p_flush
{
    my $rep = shift;
    my $blockf = $rep->p_blockf();
    my $buf = $rep->p_buffer_ref();
    local(*FH) = $rep->p_filehandle();
    my $size = $blockf * $blocksize;

    while (length($$buf) >= $size)
    {
	my $chunk = substr($$buf, 0, $size);
	$$buf = substr($$buf, $size);
	print FH $chunk;
    }
}

sub p_filetype
{
    my $file = shift;
    ((-l $file) ? '2' :
     (-f $file) ? '0' :
     (-c $file) ? '3' :
     (-b $file) ? '4' :
     (-d $file) ? '5' :
     (-p $file) ? '6' :
     '0');
}

sub p_get_blocks
{
    my $rep = shift;
    my $blocks = shift;
    local(*FH) = $rep->p_filehandle();
    my $buf = "";
    # XXX better error handling needed here
    if ($blocks)
    {
	read(FH, $buf, $blocksize * $blocks) or
	    die "$package: failed to read $blocksize * $blocks bytes: $!\n";
    }
    $buf;
}

#
# Public interface (except constructors)
#

sub write_header_from_file
{
    my $rep = shift;
    my $file = shift;

    my @stat = lstat($file);
    my $typeflag = &p_filetype($file);
    my $linkname = ((-l $file) ? readlink($file) : "");
    my $hdr = new TarHeader($file, @stat[2,4,5,7,9], $typeflag, $linkname);
    my $hdrdata = &p_unparse_header($hdr);

    $rep->p_append($hdrdata);
    $hdr;
}

sub append_file_contents
{
    my $rep = shift;
    my $file = shift;

    # XXX need better error checking here
    local(*FH);
    open(FH, "<$file");
    binmode FH;
    my $buf = "";
    my $len;
    my $readsize = 200 * $blocksize;
    while ($len = read(FH, $buf, $readsize))
    {
	if ($len % $blocksize)
	{
	    $buf .= ("\000" x ($blocksize - ($len % $blocksize)));
	}
	$rep->p_append($buf);
    }
    close(FH);
}

sub append_file
{
    my $rep = shift;
    my $file = shift;
    my $hdr = $rep->write_header_from_file($file);
    if ($hdr->typeflag() eq $ftype_file)
    {
	$rep->append_file_contents($file);
    }
}

sub skip_file
{
    my $rep = shift;
    my $buf = $rep->p_get_blocks(1);
    return 0 if ($buf eq ("\000" x $blocksize));
    my $hdr = &p_parse_header($buf);
    print $hdr->unparse();
    my $blocks = int(($hdr->size() + $blocksize - 1) / $blocksize);
    printf("skipping $blocks block%s\n", ($blocks == 1 ? "" : "s"));
    print "------\n";
    $rep->p_get_blocks($blocks);
    1;
}

sub next_file_info
{
    my $rep = shift;
    my $blockp = shift;
    my $buf = $rep->p_get_blocks(1);
    return undef if ($buf eq ("\000" x $blocksize));
    my $hdr = &p_parse_header($buf);
    $$blockp = $buf;
    $hdr;
}

sub file_data
{
    my $rep = shift;
    my $hdr = shift;
    my $blocks = int(($hdr->size() + $blocksize - 1) / $blocksize);
    $rep->p_get_blocks($blocks);
}

sub close
{
    my $rep = shift;
    my $mode = $rep->p_mode();
    my $t = $rep->p_filehandle();

    if (defined($t))
    {
	local(*FH) = $t;
	if ($mode == $mode_write)
	{
	    # tarfile ends with two blocks of nulls
	    $rep->p_append("\000" x (2 * $blocksize));
	    $rep->p_flush();

	    my $buf = $rep->p_buffer_ref();
	    my $length = length($$buf);
	    my $size = $rep->p_blockf() * $blocksize;
	    if ($length % $size)
	    {
		$rep->p_append("\000" x ($size - ($length % $size)));
	    }
	}

	close(FH);
	$rep->p_filehandle(undef);
	$rep->p_mode(0);
    }
}


#
# Test routines
# 

sub test
{
    shift;
    my $op = shift;
    if ($op eq "read")
    {
	my $tarfilename = shift;
	my $tarfile = new_read Tarfile($tarfilename);
	while ($tarfile->skip_file())
	{
	    # do nothing
	}
    }
    else
    {
	my $tarfilename = shift;
	my $tarfile = new_create Tarfile($tarfilename);
	for (@_)
	{
	    print "appending $_ to $tarfilename\n";
	    $tarfile->append_file($_);
	}
    }
}

1;

#
# END OF Tarfile
#