WAIT/Document/Tar.pm

#!/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;
1	ulpfr	10	#!/app/unido-i06/magic/perl
2			# -- Mode: Perl --
3			# Tar.pm --
4			# ITIID : $ITI$ $Header $__Header$
5			# Author : Ulrich Pfeifer
6			# Created On : Sat Jan 4 12:34:52 1997
7			# Last Modified By: Ulrich Pfeifer
8			# Last Modified On: Sun Nov 22 18:44:47 1998
9			# Language : CPerl
10			# Update Count : 15
11			# Status : Unknown, Use with caution!
12			#
13			# Copyright (c) 1996-1997, Ulrich Pfeifer
14			#
15
16			package WAIT::Document::Tar;
17			@ISA = qw(WAIT::Document::Base);
18			require WAIT::Document::Base;
19
20			use FileHandle;
21			use strict;
22			use Carp;
23
24			my $DEBUG;
25
26			sub TIEHASH {
27			my $type = shift;
28			my $pred = shift;
29			my @files = @_;
30
31			unless (ref($pred) =~ /CODE/) {
32			croak "USAGE: tie %HASH, WAIT::Document::Find, coderef, file, ...";
33			}
34
35			my $self = {
36			Pred => $pred,
37			Files => \@files
38			};
39			bless $self, ref($type) \|\| $type;
40			}
41
42			sub close_file {
43			my $self = shift;
44
45			if ($self->{_fh}) {
46			delete $self->{_fh}; # implies close?
47			delete $self->{_file};
48			}
49			}
50
51
52			sub open_file {
53			my $self = shift;
54			my $file = shift;
55
56			$self->close_file if $self->{_fh};
57
58			unless (-f $file) {
59			for (qw(.gz .Z)) {
60			if (-f "$file$_") {
61			$file .= $_;
62			last;
63			}
64			}
65			}
66			return unless -f $file;
67
68			if ($file =~ s/\.gz$//) {
69			$self->{_fh} = new IO::File "gzip -cd $file\|";
70			} elsif ($file =~ s/\.Z$//) {
71			$self->{_fh} = new IO::File "compress -cd $file\|";
72			} else {
73			$self->{_fh} = new IO::File "< $file";
74			}
75			$self->{_file} = $file;
76			$self->{_fh};
77			}
78
79			sub next_file {
80			my $self = shift;
81
82			$self->close_file;
83			return unless $self->{Pending} and @{$self->{Pending}};
84			$self->open_file(shift @{$self->{Pending}}) \|\| $self->next_file;
85			}
86
87			# sub DESTROY {shift->close;}
88
89			sub FIRSTKEY {
90			my $self = shift;
91			$self->{Pending} = [@{$self->{Files}}];
92			$self->NEXTKEY;
93			}
94
95			sub NEXTKEY {
96			my $self = shift;
97
98			$self->{_fh} or $self->next_file or return;
99			my ($key, $val) = next_archive_file($self->{_fh});
100			unless ($key) { # tar archive completed
101			$self->close_file;
102			return $self->NEXTKEY;
103			}
104			return $self->NEXTKEY unless &{$self->{Pred}}($key);
105			$self->{_val} = $val;
106			$self->{_key} = $self->{_file} . $; . $key;
107			}
108
109			sub FETCH {
110			my $self = shift;
111			my $key = shift;
112
113			if ($key ne $self->{_key}) {
114			# Random access; breaks keys, values, each
115			my ($tar, $file) = split $;, $key;
116
117			$self->close_file; # We could read the rest of the
118			# current file first.
119			$self->open_file($tar) or croak "Could not open '$tar': $!\n";
120			while (1) {
121			my ($tkey, $val) = next_archive_file($self->{_fh});
122			unless ($tkey) { # tar archive completed
123			$self->close_file;
124			return;
125			}
126			# Check the key, will not work at quiery time :-(
127			# next unless &{$self->{Pred}}($tkey);
128			$self->{_val} = $val;
129			$self->{_key} = $self->{_file} . $; . $tkey;
130			last if $key eq $self->{_key};
131			}
132			}
133			$self->{_val};
134			}
135
136			sub close {
137			my $self = shift;
138
139			$self->close_file;
140			delete $self->{Pending};
141			delete $self->{Files}; # no need at query time
142			delete $self->{_key};
143			delete $self->{_val};
144			}
145
146			sub read_bytes {
147			my ($fh, $bytes) = @_;
148			my ($buf, $read) = ('', 0); # perl -w IO/Handle.pm line 403 :-(
149
150			if (($read = $fh->read($buf, $bytes)) != $bytes) {
151			carp "Read $read instead of $bytes bytes";
152			}
153			$buf;
154			}
155
156			sub next_archive_file {
157			my $fh = shift;
158			my $buf = read_bytes($fh, 512);
159
160			my ($arch_name, $mode, $uid, $gid, $size, $mtime, $chksum,
161			$linkflag, $arch_linkname , $magic, $uname, $gname, $devmajor,
162			$devminor) =
163			unpack 'a100 a8 a8 a8 a12 a12 a8 C a100 a8 a32 a32 a8 a8', $buf;
164			print "
165			arch_name = $arch_name
166			mode = $mode
167			uid = $uid
168			gid = $gid
169			size = $size
170			mtime = $mtime
171			chksum = $chksum
172			linkflag = $linkflag
173			arch_linkname = $arch_linkname
174			magic = $magic
175			uname = $uname
176			gname = $gname
177			devmajor = $devmajor
178			devminor = $devminor
179			" if $DEBUG;
180			$size = oct $size;
181			my $file = read_bytes($fh, $size);
182			$size = $size % 512;
183			read_bytes($fh, 512 - $size) if $size;
184			$arch_name =~ s/\000.*//;
185			return($arch_name, $file);
186			}
187
188			1;