#!/app/unido-i06/magic/perl
#                              -*- Mode: Perl -*- 
# Tar.pm -- 
# ITIID           : $ITI$ $Header $__Header$
# Author          : Ulrich Pfeifer
# Created On      : Sat Jan  4 12:34:52 1997
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Sun Nov 22 18:44:47 1998
# Language        : CPerl
# Update Count    : 15
# Status          : Unknown, Use with caution!
# 
# Copyright (c) 1996-1997, Ulrich Pfeifer
# 

package WAIT::Document::Tar;
@ISA = qw(WAIT::Document::Base);
require WAIT::Document::Base;

use FileHandle;
use strict;
use Carp;

my $DEBUG;

sub TIEHASH {
  my $type    = shift;
  my $pred    = shift;
  my @files   = @_;

  unless (ref($pred) =~ /CODE/) {
    croak "USAGE: tie %HASH, WAIT::Document::Find, coderef, file, ...";
  }

  my $self   = {
                Pred   => $pred,
                Files  => \@files
               };
  bless $self, ref($type) || $type;
}

sub close_file {
  my $self = shift;

  if ($self->{_fh}) {
    delete $self->{_fh};        # implies close?
    delete $self->{_file};
  }
}


sub open_file {
  my $self = shift;
  my $file = shift;

  $self->close_file if $self->{_fh};

  unless (-f $file) {
    for (qw(.gz .Z)) {
      if (-f "$file$_") {
        $file .= $_;
        last;
      }
    }
  }
  return unless -f $file;

  if ($file =~ s/\.gz$//) {
    $self->{_fh}   = new IO::File "gzip -cd $file|";
  } elsif ($file =~ s/\.Z$//) {
    $self->{_fh}   = new IO::File "compress -cd $file|";
  } else {
    $self->{_fh}   = new IO::File "< $file";
  }
  $self->{_file} = $file;
  $self->{_fh};
}

sub next_file {
  my $self = shift;

  $self->close_file;
  return unless $self->{Pending} and @{$self->{Pending}};
  $self->open_file(shift  @{$self->{Pending}}) || $self->next_file;
}

# sub DESTROY {shift->close;}

sub FIRSTKEY {
  my $self = shift;
  $self->{Pending} = [@{$self->{Files}}];
  $self->NEXTKEY;
}

sub NEXTKEY {
  my $self = shift;

  $self->{_fh} or $self->next_file or return;
  my ($key, $val) = next_archive_file($self->{_fh});
  unless ($key) {               # tar archive completed
    $self->close_file;
    return $self->NEXTKEY;
  }
  return $self->NEXTKEY unless &{$self->{Pred}}($key);
  $self->{_val} = $val;
  $self->{_key} = $self->{_file} . $; . $key;
}

sub FETCH {
  my $self = shift;
  my $key  = shift;

  if ($key ne $self->{_key}) {
    # Random access; breaks keys, values, each
    my ($tar, $file) = split $;, $key;

    $self->close_file;          # We could read the rest of the
                                # current file first.
    $self->open_file($tar) or croak "Could not open '$tar': $!\n";
    while (1) {
      my ($tkey, $val) = next_archive_file($self->{_fh});
      unless ($tkey) {          # tar archive completed
        $self->close_file;
        return;
      }
      # Check the key, will not work at quiery time :-(
      # next unless &{$self->{Pred}}($tkey);
      $self->{_val} = $val;
      $self->{_key} = $self->{_file} . $; . $tkey;
      last if $key eq $self->{_key};
    }
  }
  $self->{_val};
}

sub close {
  my $self = shift;

  $self->close_file;
  delete $self->{Pending};
  delete $self->{Files};        # no need at query time
  delete $self->{_key};
  delete $self->{_val};
}

sub read_bytes {
  my ($fh, $bytes) = @_;
  my ($buf, $read) = ('', 0);   # perl -w IO/Handle.pm line 403 :-(

  if (($read = $fh->read($buf, $bytes)) != $bytes) {
    carp "Read $read instead of $bytes bytes";
  }
  $buf;
}

sub next_archive_file {
  my $fh  = shift;
  my $buf = read_bytes($fh, 512);
  
  my ($arch_name, $mode, $uid, $gid, $size, $mtime, $chksum,
      $linkflag, $arch_linkname , $magic, $uname, $gname, $devmajor,
      $devminor) =
        unpack 'a100 a8 a8 a8 a12 a12 a8 C a100 a8 a32 a32 a8 a8', $buf;
  print "
arch_name      = $arch_name
mode           = $mode
uid            = $uid
gid            = $gid
size           = $size
mtime          = $mtime
chksum         = $chksum
linkflag       = $linkflag
arch_linkname  = $arch_linkname 
magic          = $magic
uname          = $uname
gname          = $gname
devmajor       = $devmajor
devminor       = $devminor
" if $DEBUG;
  $size = oct $size;
  my $file = read_bytes($fh, $size);
  $size = $size % 512;
  read_bytes($fh, 512 - $size) if $size;
  $arch_name =~ s/\000.*//;
  return($arch_name, $file);
}

1;