Rearrange ext/IO-Zlib to the same layout as the CPAN distribution.
[perl.git] / ext / IO-Zlib / Zlib.pm
1 # IO::Zlib.pm
2 #
3 # Copyright (c) 1998-2004 Tom Hughes <tom@compton.nu>.
4 # All rights reserved. This program is free software; you can redistribute
5 # it and/or modify it under the same terms as Perl itself.
6
7 package IO::Zlib;
8
9 $VERSION = "1.10";
10
11 =head1 NAME
12
13 IO::Zlib - IO:: style interface to L<Compress::Zlib>
14
15 =head1 SYNOPSIS
16
17 With any version of Perl 5 you can use the basic OO interface:
18
19     use IO::Zlib;
20
21     $fh = new IO::Zlib;
22     if ($fh->open("file.gz", "rb")) {
23         print <$fh>;
24         $fh->close;
25     }
26
27     $fh = IO::Zlib->new("file.gz", "wb9");
28     if (defined $fh) {
29         print $fh "bar\n";
30         $fh->close;
31     }
32
33     $fh = IO::Zlib->new("file.gz", "rb");
34     if (defined $fh) {
35         print <$fh>;
36         undef $fh;       # automatically closes the file
37     }
38
39 With Perl 5.004 you can also use the TIEHANDLE interface to access
40 compressed files just like ordinary files:
41
42     use IO::Zlib;
43
44     tie *FILE, 'IO::Zlib', "file.gz", "wb";
45     print FILE "line 1\nline2\n";
46
47     tie *FILE, 'IO::Zlib', "file.gz", "rb";
48     while (<FILE>) { print "LINE: ", $_ };
49
50 =head1 DESCRIPTION
51
52 C<IO::Zlib> provides an IO:: style interface to L<Compress::Zlib> and
53 hence to gzip/zlib compressed files. It provides many of the same methods
54 as the L<IO::Handle> interface.
55
56 Starting from IO::Zlib version 1.02, IO::Zlib can also use an
57 external F<gzip> command.  The default behaviour is to try to use
58 an external F<gzip> if no C<Compress::Zlib> can be loaded, unless
59 explicitly disabled by
60
61     use IO::Zlib qw(:gzip_external 0);
62
63 If explicitly enabled by
64
65     use IO::Zlib qw(:gzip_external 1);
66
67 then the external F<gzip> is used B<instead> of C<Compress::Zlib>.
68
69 =head1 CONSTRUCTOR
70
71 =over 4
72
73 =item new ( [ARGS] )
74
75 Creates an C<IO::Zlib> object. If it receives any parameters, they are
76 passed to the method C<open>; if the open fails, the object is destroyed.
77 Otherwise, it is returned to the caller.
78
79 =back
80
81 =head1 OBJECT METHODS
82
83 =over 4
84
85 =item open ( FILENAME, MODE )
86
87 C<open> takes two arguments. The first is the name of the file to open
88 and the second is the open mode. The mode can be anything acceptable to
89 L<Compress::Zlib> and by extension anything acceptable to I<zlib> (that
90 basically means POSIX fopen() style mode strings plus an optional number
91 to indicate the compression level).
92
93 =item opened
94
95 Returns true if the object currently refers to a opened file.
96
97 =item close
98
99 Close the file associated with the object and disassociate
100 the file from the handle.
101 Done automatically on destroy.
102
103 =item getc
104
105 Return the next character from the file, or undef if none remain.
106
107 =item getline
108
109 Return the next line from the file, or undef on end of string.
110 Can safely be called in an array context.
111 Currently ignores $/ ($INPUT_RECORD_SEPARATOR or $RS when L<English>
112 is in use) and treats lines as delimited by "\n".
113
114 =item getlines
115
116 Get all remaining lines from the file.
117 It will croak() if accidentally called in a scalar context.
118
119 =item print ( ARGS... )
120
121 Print ARGS to the  file.
122
123 =item read ( BUF, NBYTES, [OFFSET] )
124
125 Read some bytes from the file.
126 Returns the number of bytes actually read, 0 on end-of-file, undef on error.
127
128 =item eof
129
130 Returns true if the handle is currently positioned at end of file?
131
132 =item seek ( OFFSET, WHENCE )
133
134 Seek to a given position in the stream.
135 Not yet supported.
136
137 =item tell
138
139 Return the current position in the stream, as a numeric offset.
140 Not yet supported.
141
142 =item setpos ( POS )
143
144 Set the current position, using the opaque value returned by C<getpos()>.
145 Not yet supported.
146
147 =item getpos ( POS )
148
149 Return the current position in the string, as an opaque object.
150 Not yet supported.
151
152 =back
153
154 =head1 USING THE EXTERNAL GZIP
155
156 If the external F<gzip> is used, the following C<open>s are used:
157
158     open(FH, "gzip -dc $filename |")  # for read opens
159     open(FH, " | gzip > $filename")   # for write opens
160
161 You can modify the 'commands' for example to hardwire
162 an absolute path by e.g.
163
164     use IO::Zlib ':gzip_read_open'  => '/some/where/gunzip -c %s |';
165     use IO::Zlib ':gzip_write_open' => '| /some/where/gzip.exe > %s';
166
167 The C<%s> is expanded to be the filename (C<sprintf> is used, so be
168 careful to escape any other C<%> signs).  The 'commands' are checked
169 for sanity - they must contain the C<%s>, and the read open must end
170 with the pipe sign, and the write open must begin with the pipe sign.
171
172 =head1 CLASS METHODS
173
174 =over 4
175
176 =item has_Compress_Zlib
177
178 Returns true if C<Compress::Zlib> is available.  Note that this does
179 not mean that C<Compress::Zlib> is being used: see L</gzip_external>
180 and L<gzip_used>.
181
182 =item gzip_external
183
184 Undef if an external F<gzip> B<can> be used if C<Compress::Zlib> is
185 not available (see L</has_Compress_Zlib>), true if an external F<gzip>
186 is explicitly used, false if an external F<gzip> must not be used.
187 See L</gzip_used>.
188
189 =item gzip_used
190
191 True if an external F<gzip> is being used, false if not.
192
193 =item gzip_read_open
194
195 Return the 'command' being used for opening a file for reading using an
196 external F<gzip>.
197
198 =item gzip_write_open
199
200 Return the 'command' being used for opening a file for writing using an
201 external F<gzip>.
202
203 =back
204
205 =head1 DIAGNOSTICS
206
207 =over 4
208
209 =item IO::Zlib::getlines: must be called in list context
210
211 If you want read lines, you must read in list context.
212
213 =item IO::Zlib::gzopen_external: mode '...' is illegal
214
215 Use only modes 'rb' or 'wb' or /wb[1-9]/.
216
217 =item IO::Zlib::import: '...' is illegal
218
219 The known import symbols are the C<:gzip_external>, C<:gzip_read_open>,
220 and C<:gzip_write_open>.  Anything else is not recognized.
221
222 =item IO::Zlib::import: ':gzip_external' requires an argument
223
224 The C<:gzip_external> requires one boolean argument.
225
226 =item IO::Zlib::import: 'gzip_read_open' requires an argument
227
228 The C<:gzip_external> requires one string argument.
229
230 =item IO::Zlib::import: 'gzip_read' '...' is illegal
231
232 The C<:gzip_read_open> argument must end with the pipe sign (|)
233 and have the C<%s> for the filename.  See L</"USING THE EXTERNAL GZIP">.
234
235 =item IO::Zlib::import: 'gzip_write_open' requires an argument
236
237 The C<:gzip_external> requires one string argument.
238
239 =item IO::Zlib::import: 'gzip_write_open' '...' is illegal
240
241 The C<:gzip_write_open> argument must begin with the pipe sign (|)
242 and have the C<%s> for the filename.  An output redirect (>) is also
243 often a good idea, depending on your operating system shell syntax.
244 See L</"USING THE EXTERNAL GZIP">.
245
246 =item IO::Zlib::import: no Compress::Zlib and no external gzip
247
248 Given that we failed to load C<Compress::Zlib> and that the use of
249  an external F<gzip> was disabled, IO::Zlib has not much chance of working.
250
251 =item IO::Zlib::open: needs a filename
252
253 No filename, no open.
254
255 =item IO::Zlib::READ: NBYTES must be specified
256
257 We must know how much to read.
258
259 =item IO::Zlib::WRITE: too long LENGTH
260
261 The LENGTH must be less than or equal to the buffer size.
262
263 =back
264
265 =head1 SEE ALSO
266
267 L<perlfunc>,
268 L<perlop/"I/O Operators">,
269 L<IO::Handle>,
270 L<Compress::Zlib>
271
272 =head1 HISTORY
273
274 Created by Tom Hughes E<lt>F<tom@compton.nu>E<gt>.
275
276 Support for external gzip added by Jarkko Hietaniemi E<lt>F<jhi@iki.fi>E<gt>.
277
278 =head1 COPYRIGHT
279
280 Copyright (c) 1998-2004 Tom Hughes E<lt>F<tom@compton.nu>E<gt>.
281 All rights reserved. This program is free software; you can redistribute
282 it and/or modify it under the same terms as Perl itself.
283
284 =cut
285
286 require 5.006;
287
288 use strict;
289 use vars qw($VERSION $AUTOLOAD @ISA);
290
291 use Carp;
292 use Fcntl qw(SEEK_SET);
293
294 my $has_Compress_Zlib;
295 my $aliased;
296
297 sub has_Compress_Zlib {
298     $has_Compress_Zlib;
299 }
300
301 BEGIN {
302     eval { require Compress::Zlib };
303     $has_Compress_Zlib = $@ || $Compress::Zlib::VERSION < 2.000 ? 0 : 1;
304 }
305
306 use Symbol;
307 use Tie::Handle;
308
309 # These might use some $^O logic.
310 my $gzip_read_open   = "gzip -dc %s |";
311 my $gzip_write_open  = "| gzip > %s";
312
313 my $gzip_external;
314 my $gzip_used;
315
316 sub gzip_read_open {
317     $gzip_read_open;
318 }
319
320 sub gzip_write_open {
321     $gzip_write_open;
322 }
323
324 sub gzip_external {
325     $gzip_external;
326 }
327
328 sub gzip_used {
329     $gzip_used;
330 }
331
332 sub can_gunzip {
333     $has_Compress_Zlib || $gzip_external;
334 }
335
336 sub _import {
337     my $import = shift;
338     while (@_) {
339         if ($_[0] eq ':gzip_external') {
340             shift;
341             if (@_) {
342                 $gzip_external = shift;
343             } else {
344                 croak "$import: ':gzip_external' requires an argument";
345             }
346         }
347         elsif ($_[0] eq ':gzip_read_open') {
348             shift;
349             if (@_) {
350                 $gzip_read_open = shift;
351                 croak "$import: ':gzip_read_open' '$gzip_read_open' is illegal"
352                     unless $gzip_read_open =~ /^.+%s.+\|\s*$/;
353             } else {
354                 croak "$import: ':gzip_read_open' requires an argument";
355             }
356         }
357         elsif ($_[0] eq ':gzip_write_open') {
358             shift;
359             if (@_) {
360                 $gzip_write_open = shift;
361                 croak "$import: ':gzip_write_open' '$gzip_read_open' is illegal"
362                     unless $gzip_write_open =~ /^\s*\|.+%s.*$/;
363             } else {
364                 croak "$import: ':gzip_write_open' requires an argument";
365             }
366         }
367         else {
368             last;
369         }
370     }
371     return @_;
372 }
373
374 sub _alias {
375     my $import = shift;
376     if ((!$has_Compress_Zlib && !defined $gzip_external) || $gzip_external) {
377         # The undef *gzopen is really needed only during
378         # testing where we eval several 'use IO::Zlib's.
379         undef *gzopen;
380         *gzopen                 = \&gzopen_external;
381         *IO::Handle::gzread     = \&gzread_external;
382         *IO::Handle::gzwrite    = \&gzwrite_external;
383         *IO::Handle::gzreadline = \&gzreadline_external;
384         *IO::Handle::gzeof      = \&gzeof_external;
385         *IO::Handle::gzclose    = \&gzclose_external;
386         $gzip_used = 1;
387     } else {
388         croak "$import: no Compress::Zlib and no external gzip"
389             unless $has_Compress_Zlib;
390         *gzopen     = \&Compress::Zlib::gzopen;
391         *gzread     = \&Compress::Zlib::gzread;
392         *gzwrite    = \&Compress::Zlib::gzwrite;
393         *gzreadline = \&Compress::Zlib::gzreadline;
394         *gzeof      = \&Compress::Zlib::gzeof;
395     }
396     $aliased = 1;
397 }
398
399 sub import {
400     shift;
401     my $import = "IO::Zlib::import";
402     if (@_) {
403         if (_import($import, @_)) {
404             croak "$import: '@_' is illegal";
405         }
406     }
407     _alias($import);
408 }
409
410 @ISA = qw(Tie::Handle);
411
412 sub TIEHANDLE
413 {
414     my $class = shift;
415     my @args = @_;
416
417     my $self = bless {}, $class;
418
419     return @args ? $self->OPEN(@args) : $self;
420 }
421
422 sub DESTROY
423 {
424 }
425
426 sub OPEN
427 {
428     my $self = shift;
429     my $filename = shift;
430     my $mode = shift;
431
432     croak "IO::Zlib::open: needs a filename" unless defined($filename);
433
434     $self->{'file'} = gzopen($filename,$mode);
435
436     return defined($self->{'file'}) ? $self : undef;
437 }
438
439 sub CLOSE
440 {
441     my $self = shift;
442
443     return undef unless defined($self->{'file'});
444
445     my $status = $self->{'file'}->gzclose();
446
447     delete $self->{'file'};
448
449     return ($status == 0) ? 1 : undef;
450 }
451
452 sub READ
453 {
454     my $self = shift;
455     my $bufref = \$_[0];
456     my $nbytes = $_[1];
457     my $offset = $_[2] || 0;
458
459     croak "IO::Zlib::READ: NBYTES must be specified" unless defined($nbytes);
460
461     $$bufref = "" unless defined($$bufref);
462
463     my $bytesread = $self->{'file'}->gzread(substr($$bufref,$offset),$nbytes);
464
465     return undef if $bytesread < 0;
466
467     return $bytesread;
468 }
469
470 sub READLINE
471 {
472     my $self = shift;
473
474     my $line;
475
476     return () if $self->{'file'}->gzreadline($line) <= 0;
477
478     return $line unless wantarray;
479
480     my @lines = $line;
481
482     while ($self->{'file'}->gzreadline($line) > 0)
483     {
484         push @lines, $line;
485     }
486
487     return @lines;
488 }
489
490 sub WRITE
491 {
492     my $self = shift;
493     my $buf = shift;
494     my $length = shift;
495     my $offset = shift;
496
497     croak "IO::Zlib::WRITE: too long LENGTH" unless $offset + $length <= length($buf);
498
499     return $self->{'file'}->gzwrite(substr($buf,$offset,$length));
500 }
501
502 sub EOF
503 {
504     my $self = shift;
505
506     return $self->{'file'}->gzeof();
507 }
508
509 sub FILENO
510 {
511     return undef;
512 }
513
514 sub new
515 {
516     my $class = shift;
517     my @args = @_;
518
519     _alias("new", @_) unless $aliased; # Some call new IO::Zlib directly...
520
521     my $self = gensym();
522
523     tie *{$self}, $class, @args;
524
525     return tied(${$self}) ? bless $self, $class : undef;
526 }
527
528 sub getline
529 {
530     my $self = shift;
531
532     return scalar tied(*{$self})->READLINE();
533 }
534
535 sub getlines
536 {
537     my $self = shift;
538
539     croak "IO::Zlib::getlines: must be called in list context"
540         unless wantarray;
541
542     return tied(*{$self})->READLINE();
543 }
544
545 sub opened
546 {
547     my $self = shift;
548
549     return defined tied(*{$self})->{'file'};
550 }
551
552 sub AUTOLOAD
553 {
554     my $self = shift;
555
556     $AUTOLOAD =~ s/.*:://;
557     $AUTOLOAD =~ tr/a-z/A-Z/;
558
559     return tied(*{$self})->$AUTOLOAD(@_);
560 }
561
562 sub gzopen_external {
563     my ($filename, $mode) = @_;
564     require IO::Handle;
565     my $fh = IO::Handle->new();
566     if ($mode =~ /r/) {
567         # Because someone will try to read ungzipped files
568         # with this we peek and verify the signature.  Yes,
569         # this means that we open the file twice (if it is
570         # gzipped).
571         # Plenty of race conditions exist in this code, but
572         # the alternative would be to capture the stderr of
573         # gzip and parse it, which would be a portability nightmare.
574         if (-e $filename && open($fh, $filename)) {
575             binmode $fh;
576             my $sig;
577             my $rdb = read($fh, $sig, 2);
578             if ($rdb == 2 && $sig eq "\x1F\x8B") {
579                 my $ropen = sprintf $gzip_read_open, $filename;
580                 if (open($fh, $ropen)) {
581                     binmode $fh;
582                     return $fh;
583                 } else {
584                     return undef;
585                 }
586             }
587             seek($fh, 0, SEEK_SET) or
588                 die "IO::Zlib: open('$filename', 'r'): seek: $!";
589             return $fh;
590         } else {
591             return undef;
592         }
593     } elsif ($mode =~ /w/) {
594         my $level = '';
595         $level = "-$1" if $mode =~ /([1-9])/;
596         # To maximize portability we would need to open
597         # two filehandles here, one for "| gzip $level"
598         # and another for "> $filename", and then when
599         # writing copy bytes from the first to the second.
600         # We are using IO::Handle objects for now, however,
601         # and they can only contain one stream at a time.
602         my $wopen = sprintf $gzip_write_open, $filename;
603         if (open($fh, $wopen)) {
604             $fh->autoflush(1);
605             binmode $fh;
606             return $fh;
607         } else {
608             return undef;
609         }
610     } else {
611         croak "IO::Zlib::gzopen_external: mode '$mode' is illegal";
612     }
613     return undef;
614 }
615
616 sub gzread_external {
617     # Use read() instead of syswrite() because people may
618     # mix reads and readlines, and we don't want to mess
619     # the stdio buffering.  See also gzreadline_external()
620     # and gzwrite_external().
621     my $nread = read($_[0], $_[1], @_ == 3 ? $_[2] : 4096);
622     defined $nread ? $nread : -1;
623 }
624
625 sub gzwrite_external {
626     # Using syswrite() is okay (cf. gzread_external())
627     # since the bytes leave this process and buffering
628     # is therefore not an issue.
629     my $nwrote = syswrite($_[0], $_[1]);
630     defined $nwrote ? $nwrote : -1;
631 }
632
633 sub gzreadline_external {
634     # See the comment in gzread_external().
635     $_[1] = readline($_[0]);
636     return defined $_[1] ? length($_[1]) : -1;
637 }
638
639 sub gzeof_external {
640     return eof($_[0]);
641 }
642
643 sub gzclose_external {
644     close($_[0]);
645     # I am not entirely certain why this is needed but it seems
646     # the above close() always fails (as if the stream would have
647     # been already closed - something to do with using external
648     # processes via pipes?)
649     return 0;
650 }
651
652 1;