1# $Id: Gunzip.pm,v 1.7 2010/04/24 12:28:22 crispygoth Exp $
2
3=pod
4
5=head1 NAME
6
7    XMLTV::Gunzip - Wrapper to Compress::Zlib or gzip(1)
8
9=head1 SYNOPSIS
10
11    use XMLTV::Gunzip;
12    my $decompressed = gunzip($gzdata);
13    my $fh = gunzip_open('file.gz') or die;
14    while (<$fh>) { print }
15
16Compress::Zlib will be used if installed, otherwise an external gzip
17will be spawned.  gunzip() returns the decompressed data and throws an
18exception if things go wrong; gunzip_open() returns a filehandle, or
19undef.
20
21=head1 AUTHOR
22
23Ed Avis, ed@membled.com.  Distributed as part of the xmltv package.
24
25=head1 SEE ALSO
26
27L<Compress::Zlib>, L<gzip(1)>, L<XMLTV>.
28
29=cut
30
31use warnings;
32use strict;
33
34package XMLTV::Gunzip;
35use base 'Exporter';
36our @EXPORT; @EXPORT = qw(gunzip gunzip_open);
37use File::Temp;
38
39# Implementations of gunzip().
40#
41sub zlib_gunzip( $ ) {
42    for (Compress::Zlib::memGunzip(shift)) {
43	die 'memGunzip() failed' if not defined;
44	return $_;
45    }
46}
47sub external_gunzip( $ ) {
48    my ($fh, $fname) = File::Temp::tempfile();
49    print $fh shift or die "cannot write to $fname: $!";
50    close $fh or die "cannot close $fname: $!";
51    open(GZIP, "gzip -d <$fname |") or die "cannot run gzip: $!";
52    local $/ = undef;
53    my $r = <GZIP>;
54    close GZIP or die "cannot close pipe from gzip: $!";
55    unlink $fname or die "cannot unlink $fname: $!";
56    return $r;
57}
58my $gunzip_f;
59sub gunzip( $ ) { return $gunzip_f->(shift) }
60
61
62# Implementations of gunzip_open().
63#
64sub perlio_gunzip_open( $ ) {
65    my $fname = shift;
66    # Use PerlIO::gzip.
67    local *FH;
68    open FH, '<:gzip', $fname
69      or die "cannot open $fname via PerlIO::gzip: $!";
70    return *FH;
71}
72sub zlib_gunzip_open( $ ) {
73    my $fname = shift;
74    # Use the XMLTV::Zlib_handle package defined later in this file.
75    local *FH;
76    tie *FH, 'XMLTV::Zlib_handle', $fname, 'r'
77      or die "cannot open $fname using XMLTV::Zlib_handle: $!";
78    return *FH;
79}
80sub external_gunzip_open( $ ) {
81    my $fname = shift;
82    local *FH;
83    if (not open(FH, "gzip -d <$fname |")) {
84	warn "cannot run gzip: $!";
85	return undef;
86    }
87    return *FH;
88}
89my $gunzip_open_f;
90sub gunzip_open( $ ) { return $gunzip_open_f->(shift) }
91
92
93# Switch between implementations depending on whether Compress::Zlib
94# is available.
95#
96BEGIN {
97    eval { require Compress::Zlib }; my $have_zlib = not $@;
98    eval { require PerlIO::gzip }; my $have_perlio = not $@;
99
100    if (not $have_zlib and not $have_perlio) {
101	$gunzip_f = \&external_gunzip;
102	$gunzip_open_f = \&external_gunzip_open;
103    }
104    elsif (not $have_zlib and $have_perlio) {
105	# Could gunzip by writing to a file and reading that with
106	# PerlIO, but won't bother yet.
107	#
108	$gunzip_f = \&external_gunzip;
109	$gunzip_open_f = \&perlio_gunzip_open;
110    }
111    elsif ($have_zlib and not $have_perlio) {
112	$gunzip_f = \&zlib_gunzip;
113	$gunzip_open_f = \&zlib_gunzip_open;
114    }
115    elsif ($have_zlib and $have_perlio) {
116	$gunzip_f = \&zlib_gunzip;
117	$gunzip_open_f = \&perlio_gunzip_open;
118    }
119    else { die }
120}
121
122
123####
124# This is a filehandle wrapper around Compress::Zlib, but supporting
125# only read at the moment.
126#
127package XMLTV::Zlib_handle;
128require Tie::Handle; use base 'Tie::Handle';
129use Carp;
130
131sub TIEHANDLE {
132    croak 'usage: package->TIEHANDLE(file, mode)' if @_ != 3;
133    my ($pkg, $file, $mode) = @_;
134
135    croak "only mode 'r' is supported" if $mode ne 'r';
136
137    # This object is a reference to a Compress::Zlib handle.  I did
138    # try to inherit directly from Compress::Zlib, but got weird
139    # errors of '(in cleanup) gzclose is not a valid Zlib macro'.
140    #
141    my $fh = Compress::Zlib::gzopen($file, $mode);
142    if (not $fh) {
143	warn "could not gzopen $file";
144	return undef;
145    }
146    return bless(\$fh, $pkg);
147}
148
149# Assuming that WRITE() is like print(), not like syswrite().
150sub WRITE {
151    my ($self, $scalar, $length, $offset) = @_;
152    return 1 if not $length;
153    my $r = $$self->gzwrite(substr($scalar, $offset, $length));
154    if ($r == 0) {
155	warn "gzwrite() failed";
156	return 0;
157    }
158    elsif (0 < $r and $r < $length) {
159	warn "gzwrite() wrote only $r of $length bytes";
160	return 0;
161    }
162    elsif ($r == $length) {
163	return 1;
164    }
165    else { die }
166}
167
168# PRINT(), PRINTF() inherited from Tie::Handle
169
170sub READ {
171    my ($self, $scalar, $length, $offset) = @_;
172    local $_;
173    my $n = $$self->gzread($_, $length);
174    if ($n == -1) {
175	warn 'gzread() failed';
176	return undef;
177    }
178    elsif ($n == 0) {
179	# EOF.
180	return 0;
181    }
182    elsif (0 < $n and $n <= $length) {
183	die if $n != length;
184	substr($scalar, $offset, $n) = $_;
185	return $n;
186    }
187    else { die }
188}
189
190sub READLINE {
191    my $self = shift;
192
193    # When gzreadline() uses $/, this can be removed.
194    die '$/ not supported' if $/ ne "\n";
195
196    local $_;
197    my $r = $$self->gzreadline($_);
198    if ($r == -1) {
199	warn 'gzreadline() failed';
200	return undef;
201    }
202    elsif ($r == 0) {
203	# EOF.
204	die if length;
205	return undef;
206    }
207    else {
208	# Number of bytes read.
209	die if $r != length;
210	return $_;
211    }
212}
213
214# GETC inherited from Tie::Handle
215
216# This seems to segfault in my perl installation.
217sub CLOSE {
218    my $self = shift;
219    gzclose $$self; # no meaningful return value?
220    return 1;
221}
222
223sub OPEN {
224    # Compress::Zlib doesn't support reopening.
225    my $self = shift;
226    die 'not yet implemented';
227}
228
229sub BINMODE {}
230
231sub EOF {
232    my $self = shift;
233    return $$self->gzeof();
234}
235
236sub TELL {
237    # Could track position manually.  But Compress::Zlib should do it.
238    die 'not implemented';
239}
240
241sub SEEK {
242    # Argh, fairly impossible.  Could simulate, but probably better to
243    # throw.
244    #
245    die 'not implemented';
246}
247
248sub DESTROY { &CLOSE }
249
2501;
251