File Coverage

blib/lib/Tie/Gzip.pm
Criterion Covered Total %
statement 29 201 14.4
branch 3 96 3.1
condition 0 24 0.0
subroutine 9 21 42.8
pod n/a
total 41 342 11.9


line stmt bran cond sub pod time code
1             #!perl
2             #
3             # Documentation, copyright and license is at the end of this file.
4             #
5             package Tie::Gzip;
6            
7 1     1   4562 use 5.001;
  1         3  
  1         63  
8 1     1   6 use strict;
  1         1  
  1         35  
9 1     1   29 use warnings;
  1         2  
  1         26  
10 1     1   5 use warnings::register;
  1         2  
  1         154  
11            
12 1     1   5 use vars qw($VERSION $DATE $FILE);
  1         1  
  1         87  
13             $VERSION = '1.15';
14             $DATE = '2004/04/16';
15             $FILE = __FILE__;
16            
17 1     1   5 use File::Spec;
  1         2  
  1         153  
18            
19             ######
20             # Started with CPAN::Tarzip::TIEHANDLE which
21             # still retains a faint resemblence.
22             #
23             sub TIEHANDLE
24             {
25            
26 1     1   9939 my($class, @args) = @_;
27            
28             #########
29             # create new object of $class
30             #
31             # If there is ref($class) than $class
32             # is an object whose class is ref($class).
33             #
34 1 50       25 $class = ref($class) if ref($class);
35 1         11 my $self = bless {}, $class;
36            
37             ######
38             # Parse the last argument as options if it is a reference.
39             #
40 1         6 my $options = {};
41 1 50       5 if( ref($args[-1]) ) {
42 0         0 $options = pop @args;
43 0 0       0 if(ref($options) eq 'ARRAY') {
44 0         0 my %options = @{$options};
  0         0  
45 0         0 $options = \%options;
46             }
47             }
48 1         19 $self->{options} = $options;
49            
50            
51             #####################
52             # If the Compress::Zlib package is not defined,
53             # load it.
54             #
55 1         9 my $package = 'Compress::Zlib::';
56 1 0       109 File::Package->load_package('Compress::Zlib') unless(defined %$package);
57 0         0 $self->{gz_package} = defined %$package;
58            
59 0 0       0 if( $self->{gz_package} ) {
60 0         0 Compress::Zlib->import( qw(&gzopen $gzerrno Z_STREAM_END) );
61             }
62            
63             else {
64            
65 0 0       0 $options->{read_pipe} = 'gzip --decompress --stdout {}' unless $options->{read_pipe};
66 0 0       0 $options->{write_pipe} = 'gzip --stdout > {}' unless $options->{write_pipe};
67             }
68            
69 0 0 0     0 $options->{read_pipe} .= ' |' if $options->{read_pipe} && $options->{read_pipe} !~ /\|/;
70 0 0 0     0 $options->{write_pipe} = '| ' . $options->{write_pipe} if $options->{write_pipe} && $options->{write_pipe} !~ /\|/;
71            
72             ######
73             # Open the gzip file
74             #
75 0 0       0 return $self->OPEN( @args ) if( @args );
76            
77 0         0 $self;
78            
79             }
80            
81            
82             ######
83             # Lifted from CPAN::Tarzip::TIEHANDLE in the
84             # CPAN.pm module
85             #
86             # A tied object can be used to close current file
87             # and open another file.
88             #
89             sub OPEN
90             {
91            
92             ######
93             # Make a copy so change without impacting
94             # the using variables.
95             #
96 0     0   0 my ($self, $mode, $file) = @_;
97            
98 0         0 $self->CLOSE;
99            
100 0 0       0 unless (defined $file) {
101 0         0 $file = $mode;
102 0         0 $file =~ s/^\s*([<>+|]+)\s*//;
103 0         0 $mode = $1;
104             }
105 0         0 my $options = $self->{options};
106            
107 0 0       0 if( $mode eq '<' ) {
    0          
108            
109 0 0 0     0 if ($self->{gz_package} && !$options->{read_pipe}) {
110 0         0 my $gz = gzopen($file,'rb');
111 0 0       0 unless($gz) {
112 0         0 warn( "gzopen($file,'rb') failed\n") ;
113 0         0 $self->CLOSE;
114 0         0 return undef;
115             }
116 0         0 $self -> {GZ} = $gz;
117             }
118            
119             else {
120            
121 0         0 my $pipe = $options->{read_pipe};
122 0         0 $pipe =~ s/{}/$file/g;
123            
124             ###############
125             # Some perls will return a glob and a warning
126             # for certain pipe errors such as the command
127             # not a recognized command
128             #
129 0         0 my $success = open PIPE, $pipe;
130 0         0 $! = 0; ### MAS ###
131 0 0 0     0 if($! || !$success) {
132 0         0 warn "Could not pipe $pipe: $!\n";
133 0         0 $self->CLOSE;
134 0         0 return undef;
135             }
136 0         0 binmode PIPE;
137 0         0 $self-> {FH} = \*PIPE;
138            
139             }
140            
141             ######
142             # The existance of $self->{file} means the file is open
143             # for business.
144             #
145 0         0 $self->{eof} = 0;
146 0         0 $self->{file} = $file;
147 0         0 $self->{mode} = $mode;
148            
149             }
150            
151             elsif ($mode eq '>' ) {
152            
153 0 0 0     0 if ($self->{gz_package} && !$options->{write_pipe}) {
154 0         0 my $gz = gzopen($file,'wb');
155 0 0       0 unless($gz) {
156 0         0 warn( "gzopen($file,'rb') failed\n") ;
157 0         0 $self->CLOSE;
158 0         0 return undef;
159             }
160 0         0 $self -> {GZ} = $gz;
161             }
162            
163             else {
164 0         0 my $pipe = $options->{write_pipe};
165 0         0 $pipe =~ s/{}/$file/g;
166            
167             ###############
168             # Some perls will return a glob and a warning
169             # for certain pipe errors such as the command
170             # not a recognized command
171             #
172 0         0 my $success = open PIPE, $pipe;
173 0         0 $! = 0; ### MAS ###
174 0 0 0     0 if($! || !$success) {
175 0         0 warn "Could not pipe $pipe: $!\n";
176 0         0 $self->CLOSE;
177 0         0 return undef;
178             }
179 0         0 binmode PIPE;
180 0         0 $self-> {FH} = \*PIPE;
181             }
182 0         0 $self->{tell} = 0;
183 0         0 $self->{eof} = 0;
184 0         0 $self->{file} = $file;
185 0         0 $self->{mode} = $mode;
186            
187             }
188            
189             else {
190 0         0 warn( "Opening file $file with $mode not allowed\n");
191 0         0 return undef;
192             }
193 0 0       0 $self->{file_abs} = File::Spec->rel2abs( $self->{file} ) if $self->{file};
194            
195 0         0 $self;
196            
197             }
198            
199            
200            
201             #####
202             # Started with the CPAN::Tarzip::READLINE in the
203             # CPAN.pm module
204             #
205             sub READLINE
206             {
207 0     0   0 my($self) = @_;
208            
209 0         0 my $line = undef;
210 0         0 my $bytesread = -1;
211 0 0       0 if (defined $self->{GZ}) {
    0          
212 0         0 $bytesread = $self->{GZ}->gzreadline($line);
213             }
214            
215             elsif (defined $self->{FH}) {
216 0         0 my $fh = $self->{FH};
217 0         0 $line = <$fh>;
218 0 0       0 $bytesread = $line ? length($line) : 0;
219             }
220            
221 0 0       0 if ($bytesread <= 0) {
222 0         0 $self->{eof} = 1;
223 0         0 return undef;
224             }
225 0         0 $self->{tell} += $bytesread;
226            
227 0         0 $line;
228            
229             }
230            
231            
232             #####
233             # Started with the CPAN::Tarzip::READ in the
234             # CPAN.pm module
235             #
236             sub READ
237             {
238            
239 0     0   0 my($self, undef, $length, $offset) = @_;
240            
241 0 0       0 if(defined $offset) {
242 0         0 warn "read with offset not implemented\n";
243 0         0 return undef;
244             }
245            
246 0         0 my $bytes_read = 0;
247 0         0 my $bufref = \$_[1];
248 0 0       0 if (defined $self->{GZ}) {
    0          
249 0         0 $bytes_read = $self->{GZ}->gzread($$bufref,$length);
250             }
251            
252             elsif(defined $self->{FH}) {
253 0         0 my $fh = $self->{FH};
254 0         0 $bytes_read = read($fh,$$bufref,$length);
255             }
256            
257 0         0 $self->{tell} += $bytes_read;
258 0         0 $bytes_read;
259            
260             }
261            
262            
263            
264             #####
265             #
266             #
267             sub GETC
268             {
269            
270 0     0   0 my($self) = @_;
271            
272 0         0 my $c;
273            
274 0         0 my $bytes_read = 0;
275 0 0       0 if (defined $self->{GZ}) {
    0          
276 0         0 $bytes_read = $self->{GZ}->gzread($c, 1);
277             }
278            
279             elsif(defined $self->{FH}) {
280 0         0 my $fh = $self->{FH};
281 0         0 $c = getc($fh);
282 0         0 $bytes_read = length($c);
283             }
284            
285 0         0 $self->{tell} += $bytes_read;
286 0         0 $c;
287            
288             }
289            
290            
291            
292            
293             #####
294             #
295             #
296             sub PRINT
297             {
298 0     0   0 my $self = shift;
299            
300 0 0       0 my $buf = join(defined $, ? $, : '',@_);
301 0 0       0 $buf .= $\ if defined $\;
302            
303 0         0 my $bytes_written = 0;
304 0 0       0 if (defined $self->{GZ}) {
    0          
305 0         0 $bytes_written = $self->{GZ}->gzwrite($buf);
306             }
307            
308             elsif(defined $self->{FH}) {
309 0         0 my $fh = $self->{FH};
310 0 0       0 return undef unless $bytes_written = print $fh $buf;
311            
312             }
313            
314 0         0 $self->{tell} += $bytes_written;
315 0         0 $bytes_written;
316            
317             }
318            
319            
320            
321             #####
322             #
323             #
324             sub PRINTF
325             {
326 0     0   0 my $self = shift;
327 0         0 $self->PRINT (sprintf(shift,@_));
328             }
329            
330            
331            
332             #####
333             #
334             #
335             sub WRITE
336             {
337 0     0   0 my($self, $buf, $length, $offset) = @_;
338            
339 0 0       0 if(defined $offset) {
340 0         0 warn "read with offset not implemented\n";
341 0         0 return undef;
342             }
343            
344 0         0 my $bytes_written = 0;
345 0         0 $buf = substr($buf,0,$length);
346 0 0       0 if (defined $self->{GZ}) {
    0          
347 0         0 $bytes_written = $self->{GZ}->gzwrite($buf);
348             }
349            
350             elsif(defined $self->{FH}) {
351 0         0 my $fh = $self->{FH};
352 0         0 $bytes_written = print $fh $buf;
353             }
354            
355 0         0 $self->{tell} += $bytes_written;
356 0         0 $bytes_written;
357            
358             }
359            
360            
361            
362            
363            
364             #####
365             # Started with CPAN::Tarzip::DESTROY, CPAN::Tarzip::gtest
366             #
367             sub CLOSE
368             {
369            
370 1     1   2 my($self) = @_;
371            
372 1 50       160 return 1 unless $self->{file};
373            
374 0         0 my $success = 1;
375 0 0       0 if ($self->{GZ}) {
376 0         0 my $gz = $self->{GZ};
377 0         0 my $err = $gz->gzerror();
378 0         0 $gz->gzclose();
379 0 0       0 if ($self->{mode} eq '<' ) {
380 0   0     0 $success = !$err || $err == Z_STREAM_END();
381 0 0 0     0 if($success && $self->{tell} == -s $self->{file_abs}) {
382 0         0 $success = 0;
383 0         0 $err = "Uncompressed file\n";
384             }
385             }
386 0 0       0 warn("success: $success\n\terr: $err") unless $success;
387             }
388            
389             else {
390 0         0 my $fh = $self->{FH};
391 0 0       0 $success = close $fh if defined $fh;
392 0 0       0 warn("success: 0\n\terr: $!") unless $success;
393             }
394            
395 0         0 $self->{file} = '';
396 0         0 $self->{mode} = '';
397 0         0 $self->{FH} = undef;
398 0         0 $self->{GZ} = undef;
399 0         0 $self->{tell} = 0;
400 0         0 $self->{eof} = 0;
401            
402 0         0 $success;
403             }
404            
405            
406             #####
407             #
408             #
409             sub DESTROY
410             {
411 1     1   12 CLOSE( @_ );
412            
413             }
414            
415            
416             #####
417             #
418             #
419             sub SEEK
420             {
421 0     0     my ($self, $offset, $whence) = @_;
422            
423 0 0         if($whence ne 1) {
424 0           warn "Whence of $whence not allowed.\n";
425 0           return undef;
426             }
427 0 0         if($offset < 0) {
428 0           warn "Negative offset of $offset not allowed.\n";
429 0           return undef;
430             }
431            
432 0           my $buffer;
433 0           $self->READ( $buffer, $offset);
434            
435             }
436            
437            
438            
439             #####
440             #
441             #
442             sub TELL
443             {
444 0     0     my $self = shift;
445 0           $self->{tell};
446             }
447            
448            
449             #####
450             #
451             #
452             sub EOF
453             {
454 0     0     my $self = shift;
455 0           $self->{eof};
456             }
457            
458            
459             ######
460             #
461             #
462             sub BINMODE
463             {
464            
465 0     0     my ($self, $disc) = @_;
466            
467 0           my $binmode = ':raw';
468 0 0         if (exists $self->{FH}) {
469 0           my $fh = $self->{FH};
470 0           $binmode = binmode $fh;
471             }
472 0           $binmode;
473            
474             }
475            
476            
477             ######
478             #
479             #
480             sub FILENO
481             {
482 0     0     my $self = shift;
483            
484 0           my $fileno = undef;
485 0 0         if (exists $self->{FH}) {
486 0           my $fh = $self->{FH};
487 0           $fileno = fileno $fh;
488             }
489            
490 0           $fileno;
491             }
492            
493            
494             1
495            
496            
497             __END__