chiark - git - mdw - dpkg/blob - scripts/Dpkg/Compression/FileHandle.pm

   1 # Copyright © 2008-2010 Raphaël Hertzog <hertzog@debian.org>
   2 # Copyright © 2012-2014 Guillem Jover <guillem@debian.org>
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  16
  17 package Dpkg::Compression::FileHandle;
  18
  19 use strict;
  20 use warnings;
  21
  22 our $VERSION = '1.01';
  23
  24 use POSIX qw(:signal_h :sys_wait_h);
  25 use Carp;
  26
  27 use Dpkg::Compression;
  28 use Dpkg::Compression::Process;
  29 use Dpkg::Gettext;
  30 use Dpkg::ErrorHandling;
  31
  32 use parent qw(IO::File Tie::Handle);
  33
  34 # Useful reference to understand some kludges required to
  35 # have the object behave like a filehandle
  36 # http://blog.woobling.org/2009/10/are-filehandles-objects.html
  37
  38 =encoding utf8
  39
  40 =head1 NAME
  41
  42 Dpkg::Compression::FileHandle - object dealing transparently with file compression
  43
  44 =head1 SYNOPSIS
  45
  46     use Dpkg::Compression::FileHandle;
  47
  48     my ($fh, @lines);
  49
  50     $fh = Dpkg::Compression::FileHandle->new(filename => 'sample.gz');
  51     print $fh "Something\n";
  52     close $fh;
  53
  54     $fh = Dpkg::Compression::FileHandle->new();
  55     open($fh, '>', 'sample.bz2');
  56     print $fh "Something\n";
  57     close $fh;
  58
  59     $fh = Dpkg::Compression::FileHandle->new();
  60     $fh->open('sample.xz', 'w');
  61     $fh->print("Something\n");
  62     $fh->close();
  63
  64     $fh = Dpkg::Compression::FileHandle->new(filename => 'sample.gz');
  65     @lines = <$fh>;
  66     close $fh;
  67
  68     $fh = Dpkg::Compression::FileHandle->new();
  69     open($fh, '<', 'sample.bz2');
  70     @lines = <$fh>;
  71     close $fh;
  72
  73     $fh = Dpkg::Compression::FileHandle->new();
  74     $fh->open('sample.xz', 'r');
  75     @lines = $fh->getlines();
  76     $fh->close();
  77
  78 =head1 DESCRIPTION
  79
  80 Dpkg::Compression::FileHandle is an object that can be used
  81 like any filehandle and that deals transparently with compressed
  82 files. By default, the compression scheme is guessed from the filename
  83 but you can override this behaviour with the method C<set_compression>.
  84
  85 If you don't open the file explicitly, it will be auto-opened on the
  86 first read or write operation based on the filename set at creation time
  87 (or later with the C<set_filename> method).
  88
  89 Once a file has been opened, the filehandle must be closed before being
  90 able to open another file.
  91
  92 =head1 STANDARD FUNCTIONS
  93
  94 The standard functions acting on filehandles should accept a
  95 Dpkg::Compression::FileHandle object transparently including
  96 C<open> (only when using the variant with 3 parameters), C<close>,
  97 C<binmode>, C<eof>, C<fileno>, C<getc>, C<print>, C<printf>, C<read>,
  98 C<sysread>, C<say>, C<write>, C<syswrite>, C<seek>, C<sysseek>, C<tell>.
  99
 100 Note however that C<seek> and C<sysseek> will only work on uncompressed
 101 files as compressed files are really pipes to the compressor programs
 102 and you can't seek on a pipe.
 103
 104 =head1 FileHandle METHODS
 105
 106 The object inherits from IO::File so all methods that work on this
 107 object should work for Dpkg::Compression::FileHandle too. There
 108 may be exceptions though.
 109
 110 =head1 PUBLIC METHODS
 111
 112 =over 4
 113
 114 =item $fh = Dpkg::Compression::FileHandle->new(%opts)
 115
 116 Creates a new filehandle supporting on-the-fly compression/decompression.
 117 Supported options are "filename", "compression", "compression_level" (see
 118 respective set_* functions) and "add_comp_ext". If "add_comp_ext"
 119 evaluates to true, then the extension corresponding to the selected
 120 compression scheme is automatically added to the recorded filename. It's
 121 obviously incompatible with automatic detection of the compression method.
 122
 123 =cut
 124
 125 # Object methods
 126 sub new {
 127     my ($this, %args) = @_;
 128     my $class = ref($this) || $this;
 129     my $self = IO::File->new();
 130     # Tying is required to overload the open functions and to auto-open
 131     # the file on first read/write operation
 132     tie *$self, $class, $self;
 133     bless $self, $class;
 134     # Initializations
 135     *$self->{compression} = 'auto';
 136     *$self->{compressor} = Dpkg::Compression::Process->new();
 137     *$self->{add_comp_ext} = $args{add_compression_extension} ||
 138             $args{add_comp_ext} || 0;
 139     *$self->{allow_sigpipe} = 0;
 140     if (exists $args{filename}) {
 141         $self->set_filename($args{filename});
 142     }
 143     if (exists $args{compression}) {
 144         $self->set_compression($args{compression});
 145     }
 146     if (exists $args{compression_level}) {
 147         $self->set_compression_level($args{compression_level});
 148     }
 149     return $self;
 150 }
 151
 152 =item $fh->ensure_open($mode, %opts)
 153
 154 Ensure the file is opened in the requested mode ("r" for read and "w" for
 155 write). The options are passed down to the compressor's spawn() call, if one
 156 is used. Opens the file with the recorded filename if needed. If the file
 157 is already open but not in the requested mode, then it errors out.
 158
 159 =cut
 160
 161 sub ensure_open {
 162     my ($self, $mode, %opts) = @_;
 163     if (exists *$self->{mode}) {
 164         return if *$self->{mode} eq $mode;
 165         croak "ensure_open requested incompatible mode: $mode";
 166     } else {
 167         # Sanitize options.
 168         delete $opts{from_pipe};
 169         delete $opts{from_file};
 170         delete $opts{to_pipe};
 171         delete $opts{to_file};
 172
 173         if ($mode eq 'w') {
 174             $self->_open_for_write(%opts);
 175         } elsif ($mode eq 'r') {
 176             $self->_open_for_read(%opts);
 177         } else {
 178             croak "invalid mode in ensure_open: $mode";
 179         }
 180     }
 181 }
 182
 183 ##
 184 ## METHODS FOR TIED HANDLE
 185 ##
 186 sub TIEHANDLE {
 187     my ($class, $self) = @_;
 188     return $self;
 189 }
 190
 191 sub WRITE {
 192     my ($self, $scalar, $length, $offset) = @_;
 193     $self->ensure_open('w');
 194     return *$self->{file}->write($scalar, $length, $offset);
 195 }
 196
 197 sub READ {
 198     my ($self, $scalar, $length, $offset) = @_;
 199     $self->ensure_open('r');
 200     return *$self->{file}->read($scalar, $length, $offset);
 201 }
 202
 203 sub READLINE {
 204     my ($self) = shift;
 205     $self->ensure_open('r');
 206     return *$self->{file}->getlines() if wantarray;
 207     return *$self->{file}->getline();
 208 }
 209
 210 sub OPEN {
 211     my ($self) = shift;
 212     if (scalar(@_) == 2) {
 213         my ($mode, $filename) = @_;
 214         $self->set_filename($filename);
 215         if ($mode eq '>') {
 216             $self->_open_for_write();
 217         } elsif ($mode eq '<') {
 218             $self->_open_for_read();
 219         } else {
 220             croak 'Dpkg::Compression::FileHandle does not support ' .
 221                   "open() mode $mode";
 222         }
 223     } else {
 224         croak 'Dpkg::Compression::FileHandle only supports open() ' .
 225               'with 3 parameters';
 226     }
 227     return 1; # Always works (otherwise errors out)
 228 }
 229
 230 sub CLOSE {
 231     my ($self) = shift;
 232     my $ret = 1;
 233     if (defined *$self->{file}) {
 234         $ret = *$self->{file}->close(@_) if *$self->{file}->opened();
 235     } else {
 236         $ret = 0;
 237     }
 238     $self->_cleanup();
 239     return $ret;
 240 }
 241
 242 sub FILENO {
 243     my ($self) = shift;
 244     return *$self->{file}->fileno(@_) if defined *$self->{file};
 245     return;
 246 }
 247
 248 sub EOF {
 249     # Since perl 5.12, an integer parameter is passed describing how the
 250     # function got called, just ignore it.
 251     my ($self, $param) = (shift, shift);
 252     return *$self->{file}->eof(@_) if defined *$self->{file};
 253     return 1;
 254 }
 255
 256 sub SEEK {
 257     my ($self) = shift;
 258     return *$self->{file}->seek(@_) if defined *$self->{file};
 259     return 0;
 260 }
 261
 262 sub TELL {
 263     my ($self) = shift;
 264     return *$self->{file}->tell(@_) if defined *$self->{file};
 265     return -1;
 266 }
 267
 268 sub BINMODE {
 269     my ($self) = shift;
 270     return *$self->{file}->binmode(@_) if defined *$self->{file};
 271     return;
 272 }
 273
 274 ##
 275 ## NORMAL METHODS
 276 ##
 277
 278 =item $fh->set_compression($comp)
 279
 280 Defines the compression method used. $comp should one of the methods supported by
 281 B<Dpkg::Compression> or "none" or "auto". "none" indicates that the file is
 282 uncompressed and "auto" indicates that the method must be guessed based
 283 on the filename extension used.
 284
 285 =cut
 286
 287 sub set_compression {
 288     my ($self, $method) = @_;
 289     if ($method ne 'none' and $method ne 'auto') {
 290         *$self->{compressor}->set_compression($method);
 291     }
 292     *$self->{compression} = $method;
 293 }
 294
 295 =item $fh->set_compression_level($level)
 296
 297 Indicate the desired compression level. It should be a value accepted
 298 by the function C<compression_is_valid_level> of B<Dpkg::Compression>.
 299
 300 =cut
 301
 302 sub set_compression_level {
 303     my ($self, $level) = @_;
 304     *$self->{compressor}->set_compression_level($level);
 305 }
 306
 307 =item $fh->set_filename($name, [$add_comp_ext])
 308
 309 Use $name as filename when the file must be opened/created. If
 310 $add_comp_ext is passed, it indicates whether the default extension
 311 of the compression method must be automatically added to the filename
 312 (or not).
 313
 314 =cut
 315
 316 sub set_filename {
 317     my ($self, $filename, $add_comp_ext) = @_;
 318     *$self->{filename} = $filename;
 319     # Automatically add compression extension to filename
 320     if (defined($add_comp_ext)) {
 321         *$self->{add_comp_ext} = $add_comp_ext;
 322     }
 323     my $comp_ext_regex = compression_get_file_extension_regex();
 324     if (*$self->{add_comp_ext} and $filename =~ /\.$comp_ext_regex$/) {
 325         warning('filename %s already has an extension of a compressed file ' .
 326                 'and add_comp_ext is active', $filename);
 327     }
 328 }
 329
 330 =item $file = $fh->get_filename()
 331
 332 Returns the filename that would be used when the filehandle must
 333 be opened (both in read and write mode). This function errors out
 334 if "add_comp_ext" is enabled while the compression method is set
 335 to "auto". The returned filename includes the extension of the compression
 336 method if "add_comp_ext" is enabled.
 337
 338 =cut
 339
 340 sub get_filename {
 341     my $self = shift;
 342     my $comp = *$self->{compression};
 343     if (*$self->{add_comp_ext}) {
 344         if ($comp eq 'auto') {
 345             croak 'automatic detection of compression is ' .
 346                   'incompatible with add_comp_ext';
 347         } elsif ($comp eq 'none') {
 348             return *$self->{filename};
 349         } else {
 350             return *$self->{filename} . '.' .
 351                    compression_get_property($comp, 'file_ext');
 352         }
 353     } else {
 354         return *$self->{filename};
 355     }
 356 }
 357
 358 =item $ret = $fh->use_compression()
 359
 360 Returns "0" if no compression is used and the compression method used
 361 otherwise. If the compression is set to "auto", the value returned
 362 depends on the extension of the filename obtained with the B<get_filename>
 363 method.
 364
 365 =cut
 366
 367 sub use_compression {
 368     my $self = shift;
 369     my $comp = *$self->{compression};
 370     if ($comp eq 'none') {
 371         return 0;
 372     } elsif ($comp eq 'auto') {
 373         $comp = compression_guess_from_filename($self->get_filename());
 374         *$self->{compressor}->set_compression($comp) if $comp;
 375     }
 376     return $comp;
 377 }
 378
 379 =item $real_fh = $fh->get_filehandle()
 380
 381 Returns the real underlying filehandle. Useful if you want to pass it
 382 along in a derived object.
 383
 384 =cut
 385
 386 sub get_filehandle {
 387     my $self = shift;
 388     return *$self->{file} if exists *$self->{file};
 389 }
 390
 391 ## INTERNAL METHODS
 392
 393 sub _open_for_write {
 394     my ($self, %opts) = @_;
 395     my $filehandle;
 396
 397     croak 'cannot reopen an already opened compressed file'
 398         if exists *$self->{mode};
 399
 400     if ($self->use_compression()) {
 401         *$self->{compressor}->compress(from_pipe => \$filehandle,
 402                 to_file => $self->get_filename(), %opts);
 403     } else {
 404         CORE::open($filehandle, '>', $self->get_filename)
 405             or syserr(g_('cannot write %s'), $self->get_filename());
 406     }
 407     *$self->{mode} = 'w';
 408     *$self->{file} = $filehandle;
 409 }
 410
 411 sub _open_for_read {
 412     my ($self, %opts) = @_;
 413     my $filehandle;
 414
 415     croak 'cannot reopen an already opened compressed file'
 416         if exists *$self->{mode};
 417
 418     if ($self->use_compression()) {
 419         *$self->{compressor}->uncompress(to_pipe => \$filehandle,
 420                 from_file => $self->get_filename(), %opts);
 421         *$self->{allow_sigpipe} = 1;
 422     } else {
 423         CORE::open($filehandle, '<', $self->get_filename)
 424             or syserr(g_('cannot read %s'), $self->get_filename());
 425     }
 426     *$self->{mode} = 'r';
 427     *$self->{file} = $filehandle;
 428 }
 429
 430 sub _cleanup {
 431     my $self = shift;
 432     my $cmdline = *$self->{compressor}{cmdline} // '';
 433     *$self->{compressor}->wait_end_process(nocheck => *$self->{allow_sigpipe});
 434     if (*$self->{allow_sigpipe}) {
 435         unless (($? == 0) || (WIFSIGNALED($?) && (WTERMSIG($?) == SIGPIPE))) {
 436             subprocerr($cmdline);
 437         }
 438         *$self->{allow_sigpipe} = 0;
 439     }
 440     delete *$self->{mode};
 441     delete *$self->{file};
 442 }
 443
 444 =back
 445
 446 =head1 DERIVED OBJECTS
 447
 448 If you want to create an object that inherits from
 449 Dpkg::Compression::FileHandle you must be aware that
 450 the object is a reference to a GLOB that is returned by Symbol::gensym()
 451 and as such it's not a HASH.
 452
 453 You can store internal data in a hash but you have to use
 454 C<*$self->{...}> to access the associated hash like in the example below:
 455
 456     sub set_option {
 457         my ($self, $value) = @_;
 458         *$self->{option} = $value;
 459     }
 460
 461 =head1 CHANGES
 462
 463 =head2 Version 1.01 (dpkg 1.17.11)
 464
 465 New argument: $fh->ensure_open() accepts an %opts argument.
 466
 467 =head2 Version 1.00 (dpkg 1.15.6)
 468
 469 Mark the module as public.
 470
 471 =cut
 472 1;