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