/[wait]/trunk/lib/WAIT/Document/Tar.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/lib/WAIT/Document/Tar.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 119 - (show annotations)
Fri Sep 16 22:49:35 2005 UTC (14 years, 1 month ago) by dpavlin
File size: 4344 byte(s)
support for .tgz

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;

Properties

Name Value
cvs2svn:cvs-rev 1.1

  ViewVC Help
Powered by ViewVC 1.1.26