| # Copyright © 2008-2010 Raphaël Hertzog <hertzog@debian.org> |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # You should have received a copy of the GNU General Public License |
| # along with this program. If not, see <http://www.gnu.org/licenses/>. |
| |
| package Dpkg::Compression::FileHandle; |
| |
| use strict; |
| use warnings; |
| |
| our $VERSION = "1.00"; |
| |
| use Dpkg::Compression; |
| use Dpkg::Compression::Process; |
| use Dpkg::Gettext; |
| use Dpkg::ErrorHandling; |
| use POSIX qw(WIFSIGNALED WTERMSIG SIGPIPE); |
| |
| use base qw(FileHandle Tie::Handle); |
| |
| # Useful reference to understand some kludges required to |
| # have the object behave like a filehandle |
| # http://blog.woobling.org/2009/10/are-filehandles-objects.html |
| |
| =encoding utf8 |
| |
| =head1 NAME |
| |
| Dpkg::Compression::FileHandle - object dealing transparently with file compression |
| |
| =head1 SYNOPSIS |
| |
| use Dpkg::Compression::FileHandle; |
| |
| $fh = Dpkg::Compression::FileHandle->new(filename=>"sample.gz"); |
| print $fh "Something\n"; |
| close $fh; |
| |
| $fh = Dpkg::Compression::FileHandle->new(); |
| open($fh, ">", "sample.bz2"); |
| print $fh "Something\n"; |
| close $fh; |
| |
| $fh = Dpkg::Compression::FileHandle->new(); |
| $fh->open("sample.xz", "w"); |
| $fh->print("Something\n"); |
| $fh->close(); |
| |
| $fh = Dpkg::Compression::FileHandle->new(filename=>"sample.gz"); |
| my @lines = <$fh>; |
| close $fh; |
| |
| $fh = Dpkg::Compression::FileHandle->new(); |
| open($fh, "<", "sample.bz2"); |
| my @lines = <$fh>; |
| close $fh; |
| |
| $fh = Dpkg::Compression::FileHandle->new(); |
| $fh->open("sample.xz", "r"); |
| my @lines = $fh->getlines(); |
| $fh->close(); |
| |
| =head1 DESCRIPTION |
| |
| Dpkg::Compression::FileHandle is an object that can be used |
| like any filehandle and that deals transparently with compressed |
| files. By default, the compression scheme is guessed from the filename |
| but you can override this behaviour with the method C<set_compression>. |
| |
| If you don't open the file explicitly, it will be auto-opened on the |
| first read or write operation based on the filename set at creation time |
| (or later with the C<set_filename> method). |
| |
| Once a file has been opened, the filehandle must be closed before being |
| able to open another file. |
| |
| =head1 STANDARD FUNCTIONS |
| |
| The standard functions acting on filehandles should accept a |
| Dpkg::Compression::FileHandle object transparently including |
| C<open> (only when using the variant with 3 parameters), C<close>, |
| C<binmode>, C<eof>, C<fileno>, C<getc>, C<print>, C<printf>, C<read>, |
| C<sysread>, C<say>, C<write>, C<syswrite>, C<seek>, C<sysseek>, C<tell>. |
| |
| Note however that C<seek> and C<sysseek> will only work on uncompressed |
| files as compressed files are really pipes to the compressor programs |
| and you can't seek on a pipe. |
| |
| =head1 FileHandle METHODS |
| |
| The object inherits from FileHandle so all methods that work on this |
| object should work for Dpkg::Compression::FileHandle too. There |
| may be exceptions though. |
| |
| =head1 PUBLIC METHODS |
| |
| =over 4 |
| |
| =item my $fh = Dpkg::Compression::FileHandle->new(%opts) |
| |
| Creates a new filehandle supporting on-the-fly compression/decompression. |
| Supported options are "filename", "compression", "compression_level" (see |
| respective set_* functions) and "add_comp_ext". If "add_comp_ext" |
| evaluates to true, then the extension corresponding to the selected |
| compression scheme is automatically added to the recorded filename. It's |
| obviously incompatible with automatic detection of the compression method. |
| |
| =cut |
| |
| # Object methods |
| sub new { |
| my ($this, %args) = @_; |
| my $class = ref($this) || $this; |
| my $self = FileHandle->new(); |
| # Tying is required to overload the open functions and to auto-open |
| # the file on first read/write operation |
| tie *$self, $class, $self; |
| bless $self, $class; |
| # Initializations |
| *$self->{"compression"} = "auto"; |
| *$self->{"compressor"} = Dpkg::Compression::Process->new(); |
| *$self->{"add_comp_ext"} = $args{"add_compression_extension"} || |
| $args{"add_comp_ext"} || 0; |
| *$self->{"allow_sigpipe"} = 0; |
| if (exists $args{"filename"}) { |
| $self->set_filename($args{"filename"}); |
| } |
| if (exists $args{"compression"}) { |
| $self->set_compression($args{"compression"}); |
| } |
| if (exists $args{"compression_level"}) { |
| $self->set_compression_level($args{"compression_level"}); |
| } |
| return $self; |
| } |
| |
| =item $fh->ensure_open($mode) |
| |
| Ensure the file is opened in the requested mode ("r" for read and "w" for |
| write). Opens the file with the recorded filename if needed. If the file |
| is already open but not in the requested mode, then it errors out. |
| |
| =cut |
| |
| sub ensure_open { |
| my ($self, $mode) = @_; |
| if (exists *$self->{"mode"}) { |
| return if *$self->{"mode"} eq $mode; |
| internerr("ensure_open requested incompatible mode: $mode"); |
| } else { |
| if ($mode eq "w") { |
| $self->open_for_write(); |
| } elsif ($mode eq "r") { |
| $self->open_for_read(); |
| } else { |
| internerr("invalid mode in ensure_open: $mode"); |
| } |
| } |
| } |
| |
| ## |
| ## METHODS FOR TIED HANDLE |
| ## |
| sub TIEHANDLE { |
| my ($class, $self) = @_; |
| return $self; |
| } |
| |
| sub WRITE { |
| my ($self, $scalar, $length, $offset) = @_; |
| $self->ensure_open("w"); |
| return *$self->{'file'}->write($scalar, $length, $offset); |
| } |
| |
| sub READ { |
| my ($self, $scalar, $length, $offset) = @_; |
| $self->ensure_open("r"); |
| return *$self->{'file'}->read($scalar, $length, $offset); |
| } |
| |
| sub READLINE { |
| my ($self) = shift; |
| $self->ensure_open("r"); |
| return *$self->{"file"}->getlines() if wantarray; |
| return *$self->{"file"}->getline(); |
| } |
| |
| sub OPEN { |
| my ($self) = shift; |
| if (scalar(@_) == 2) { |
| my ($mode, $filename) = @_; |
| $self->set_filename($filename); |
| if ($mode eq ">") { |
| $self->open_for_write(); |
| } elsif ($mode eq "<") { |
| $self->open_for_read(); |
| } else { |
| internerr("Unsupported open mode on Dpkg::Compression::FileHandle: $mode"); |
| } |
| } else { |
| internerr("Dpkg::Compression::FileHandle only supports open() with 3 parameters"); |
| } |
| return 1; # Always works (otherwise errors out) |
| } |
| |
| sub CLOSE { |
| my ($self) = shift; |
| my $ret = 1; |
| if (defined *$self->{'file'}) { |
| $ret = *$self->{'file'}->close(@_) if *$self->{'file'}->opened(); |
| } else { |
| $ret = 0; |
| } |
| $self->cleanup(); |
| return $ret; |
| } |
| |
| sub FILENO { |
| my ($self) = shift; |
| return *$self->{"file"}->fileno(@_) if defined *$self->{"file"}; |
| return undef; |
| } |
| |
| sub EOF { |
| my ($self) = shift; |
| return *$self->{"file"}->eof(@_) if defined *$self->{"file"}; |
| return 1; |
| } |
| |
| sub SEEK { |
| my ($self) = shift; |
| return *$self->{"file"}->seek(@_) if defined *$self->{"file"}; |
| return 0; |
| } |
| |
| sub TELL { |
| my ($self) = shift; |
| return *$self->{"file"}->tell(@_) if defined *$self->{"file"}; |
| return -1; |
| } |
| |
| sub BINMODE { |
| my ($self) = shift; |
| return *$self->{"file"}->binmode(@_) if defined *$self->{"file"}; |
| return undef; |
| } |
| |
| ## |
| ## NORMAL METHODS |
| ## |
| |
| =item $fh->set_compression($comp) |
| |
| Defines the compression method used. $comp should one of the methods supported by |
| B<Dpkg::Compression> or "none" or "auto". "none" indicates that the file is |
| uncompressed and "auto" indicates that the method must be guessed based |
| on the filename extension used. |
| |
| =cut |
| |
| sub set_compression { |
| my ($self, $method) = @_; |
| if ($method ne "none" and $method ne "auto") { |
| *$self->{"compressor"}->set_compression($method); |
| } |
| *$self->{"compression"} = $method; |
| } |
| |
| =item $fh->set_compression_level($level) |
| |
| Indicate the desired compression level. It should be a value accepted |
| by the function C<compression_is_valid_level> of B<Dpkg::Compression>. |
| |
| =cut |
| |
| sub set_compression_level { |
| my ($self, $level) = @_; |
| *$self->{"compressor"}->set_compression_level($level); |
| } |
| |
| =item $fh->set_filename($name, [$add_comp_ext]) |
| |
| Use $name as filename when the file must be opened/created. If |
| $add_comp_ext is passed, it indicates whether the default extension |
| of the compression method must be automatically added to the filename |
| (or not). |
| |
| =cut |
| |
| sub set_filename { |
| my ($self, $filename, $add_comp_ext) = @_; |
| *$self->{"filename"} = $filename; |
| # Automatically add compression extension to filename |
| if (defined($add_comp_ext)) { |
| *$self->{"add_comp_ext"} = $add_comp_ext; |
| } |
| if (*$self->{"add_comp_ext"} and $filename =~ /\.$compression_re_file_ext$/) { |
| warning("filename %s already has an extension of a compressed file " . |
| "and add_comp_ext is active", $filename); |
| } |
| } |
| |
| =item my $file = $fh->get_filename() |
| |
| Returns the filename that would be used when the filehandle must |
| be opened (both in read and write mode). This function errors out |
| if "add_comp_ext" is enableactivated while the compression method is set |
| to "auto". The returned filename includes the extension of the compression |
| method if "add_comp_ext" is enabled. |
| |
| =cut |
| |
| sub get_filename { |
| my $self = shift; |
| my $comp = *$self->{"compression"}; |
| if (*$self->{'add_comp_ext'}) { |
| if ($comp eq "auto") { |
| internerr("automatic detection of compression is " . |
| "incompatible with add_comp_ext"); |
| } elsif ($comp eq "none") { |
| return *$self->{"filename"}; |
| } else { |
| return *$self->{"filename"} . "." . |
| compression_get_property($comp, "file_ext"); |
| } |
| } else { |
| return *$self->{"filename"}; |
| } |
| } |
| |
| =item $ret = $fh->use_compression() |
| |
| Returns "0" if no compression is used and the compression method used |
| otherwise. If the compression is set to "auto", the value returned |
| depends on the extension of the filename obtained with the B<get_filename> |
| method. |
| |
| =cut |
| |
| sub use_compression { |
| my ($self) = @_; |
| my $comp = *$self->{"compression"}; |
| if ($comp eq "none") { |
| return 0; |
| } elsif ($comp eq "auto") { |
| $comp = compression_guess_from_filename($self->get_filename()); |
| *$self->{"compressor"}->set_compression($comp) if $comp; |
| } |
| return $comp; |
| } |
| |
| =item my $real_fh = $fh->get_filehandle() |
| |
| Returns the real underlying filehandle. Useful if you want to pass it |
| along in a derived object. |
| |
| =cut |
| |
| sub get_filehandle { |
| my ($self) = @_; |
| return *$self->{"file"} if exists *$self->{"file"}; |
| } |
| |
| ## INTERNAL METHODS |
| |
| sub open_for_write { |
| my ($self) = @_; |
| error("Can't reopen an already opened compressed file") if exists *$self->{"mode"}; |
| my $filehandle; |
| if ($self->use_compression()) { |
| *$self->{'compressor'}->compress(from_pipe => \$filehandle, |
| to_file => $self->get_filename()); |
| } else { |
| CORE::open($filehandle, ">", $self->get_filename) || |
| syserr(_g("cannot write %s"), $self->get_filename()); |
| } |
| *$self->{"mode"} = "w"; |
| *$self->{"file"} = $filehandle; |
| } |
| |
| sub open_for_read { |
| my ($self) = @_; |
| error("Can't reopen an already opened compressed file") if exists *$self->{"mode"}; |
| my $filehandle; |
| if ($self->use_compression()) { |
| *$self->{'compressor'}->uncompress(to_pipe => \$filehandle, |
| from_file => $self->get_filename()); |
| *$self->{'allow_sigpipe'} = 1; |
| } else { |
| CORE::open($filehandle, "<", $self->get_filename) || |
| syserr(_g("cannot read %s"), $self->get_filename()); |
| } |
| *$self->{"mode"} = "r"; |
| *$self->{"file"} = $filehandle; |
| } |
| |
| sub cleanup { |
| my ($self) = @_; |
| my $cmdline = *$self->{"compressor"}{"cmdline"} || ""; |
| *$self->{"compressor"}->wait_end_process(nocheck => *$self->{'allow_sigpipe'}); |
| if (*$self->{'allow_sigpipe'}) { |
| unless (($? == 0) || (WIFSIGNALED($?) && (WTERMSIG($?) == SIGPIPE))) { |
| subprocerr($cmdline); |
| } |
| *$self->{'allow_sigpipe'} = 0; |
| } |
| delete *$self->{"mode"}; |
| delete *$self->{"file"}; |
| } |
| |
| =back |
| |
| =head1 DERIVED OBJECTS |
| |
| If you want to create an object that inherits from |
| Dpkg::Compression::FileHandle you must be aware that |
| the object is a reference to a GLOB that is returned by Symbol::gensym() |
| and as such it's not a HASH. |
| |
| You can store internal data in a hash but you have to use |
| C<*$self->{...}> to access the associated hash like in the example below: |
| |
| sub set_option { |
| my ($self, $value) = @_; |
| *$self->{"option"} = $value; |
| } |
| |
| |
| =head1 AUTHOR |
| |
| Raphaël Hertzog <hertzog@debian.org> |
| |
| =cut |
| 1; |