1 |
#!/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 |
require WAIT::Document::Base; |
18 |
@ISA = qw(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 .tgz)) { |
60 |
if (-f "$file$_") { |
61 |
$file .= $_; |
62 |
last; |
63 |
} |
64 |
} |
65 |
} |
66 |
return unless -f $file; |
67 |
|
68 |
if ($file =~ s/\.(gz|tgz)$//) { |
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; |