|
|
@@ -1,4 +1,4 @@
|
|
|
-# Copyright © 2008 Raphaël Hertzog <hertzog@debian.org>
|
|
|
+# 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
|
|
|
@@ -22,20 +22,112 @@ use Dpkg::Compression;
|
|
|
use Dpkg::Compression::Compressor;
|
|
|
use Dpkg::Gettext;
|
|
|
use Dpkg::ErrorHandling;
|
|
|
-use POSIX;
|
|
|
+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
|
|
|
+
|
|
|
+=head1 NAME
|
|
|
+
|
|
|
+Dpkg::Compression::CompressedFile - object dealing transparently with file compression
|
|
|
+
|
|
|
+=head1 SYNOPSIS
|
|
|
+
|
|
|
+ use Dpkg::Compression::CompressedFile;
|
|
|
+
|
|
|
+ $fh = Dpkg::Compression::CompressedFile->new(filename=>"sample.gz");
|
|
|
+ print $fh "Something\n";
|
|
|
+ close $fh;
|
|
|
+
|
|
|
+ $fh = Dpkg::Compression::CompressedFile->new();
|
|
|
+ open($fh, ">", "sample.bz2");
|
|
|
+ print $fh "Something\n";
|
|
|
+ close $fh;
|
|
|
+
|
|
|
+ $fh = Dpkg::Compression::CompressedFile->new();
|
|
|
+ $fh->open("sample.xz", "w");
|
|
|
+ $fh->print("Something\n");
|
|
|
+ $fh->close();
|
|
|
+
|
|
|
+ $fh = Dpkg::Compression::CompressedFile->new(filename=>"sample.gz");
|
|
|
+ my @lines = <$fh>;
|
|
|
+ close $fh;
|
|
|
+
|
|
|
+ $fh = Dpkg::Compression::CompressedFile->new();
|
|
|
+ open($fh, "<", "sample.bz2");
|
|
|
+ my @lines = <$fh>;
|
|
|
+ close $fh;
|
|
|
+
|
|
|
+ $fh = Dpkg::Compression::CompressedFile->new();
|
|
|
+ $fh->open("sample.xz", "r");
|
|
|
+ my @lines = $fh->getlines();
|
|
|
+ $fh->close();
|
|
|
+
|
|
|
+=head1 DESCRIPTION
|
|
|
+
|
|
|
+Dpkg::Compression::CompressedFile 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 explicitely, 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::CompressedFile 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::CompressedFile too. There
|
|
|
+may be exceptions though.
|
|
|
+
|
|
|
+=head1 PUBLIC METHODS
|
|
|
+
|
|
|
+=over 4
|
|
|
+
|
|
|
+=item my $fh = Dpkg::Compression::CompressedFile->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 = {
|
|
|
- "compression" => "auto"
|
|
|
- };
|
|
|
+ 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;
|
|
|
- $self->{"compressor"} = Dpkg::Compression::Compressor->new();
|
|
|
- $self->{"add_comp_ext"} = $args{"add_compression_extension"} ||
|
|
|
+ # Initializations
|
|
|
+ *$self->{"compression"} = "auto";
|
|
|
+ *$self->{"compressor"} = Dpkg::Compression::Compressor->new();
|
|
|
+ *$self->{"add_comp_ext"} = $args{"add_compression_extension"} ||
|
|
|
$args{"add_comp_ext"} || 0;
|
|
|
- $self->{"allow_sigpipe"} = 0;
|
|
|
+ *$self->{"allow_sigpipe"} = 0;
|
|
|
if (exists $args{"filename"}) {
|
|
|
$self->set_filename($args{"filename"});
|
|
|
}
|
|
|
@@ -48,102 +140,291 @@ sub new {
|
|
|
return $self;
|
|
|
}
|
|
|
|
|
|
-sub reset {
|
|
|
- my ($self) = @_;
|
|
|
- %{$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::CompressedFile: $mode");
|
|
|
+ }
|
|
|
+ } else {
|
|
|
+ internerr("Dpkg::Compression::CompressedFile only supports open() with 3 parameters");
|
|
|
+ }
|
|
|
+ return 1; # Always works (otherwise errors out)
|
|
|
+}
|
|
|
+
|
|
|
+sub CLOSE {
|
|
|
+ my ($self) = shift;
|
|
|
+ my $ret = 1;
|
|
|
+ $ret = *$self->{'file'}->close(@_) if *$self->{'file'}->opened();
|
|
|
+ $self->cleanup();
|
|
|
+ return $ret;
|
|
|
+}
|
|
|
+
|
|
|
+sub FILENO {
|
|
|
+ my ($self) = shift;
|
|
|
+ return *$self->{"file"}->fileno(@_);
|
|
|
+}
|
|
|
+
|
|
|
+sub EOF {
|
|
|
+ my ($self) = shift;
|
|
|
+ return *$self->{"file"}->eof(@_);
|
|
|
+}
|
|
|
+
|
|
|
+sub SEEK {
|
|
|
+ my ($self) = shift;
|
|
|
+ return *$self->{"file"}->seek(@_);
|
|
|
+}
|
|
|
+
|
|
|
+sub TELL {
|
|
|
+ my ($self) = shift;
|
|
|
+ return *$self->{"file"}->tell(@_);
|
|
|
}
|
|
|
|
|
|
+sub BINMODE {
|
|
|
+ my ($self) = shift;
|
|
|
+ return *$self->{"file"}->binmode(@_);
|
|
|
+}
|
|
|
+
|
|
|
+##
|
|
|
+## NORMAL METHODS
|
|
|
+##
|
|
|
+
|
|
|
+=item $fh->set_compression($comp)
|
|
|
+
|
|
|
+Defines the compression method used. $comp should one of the methods supported by
|
|
|
+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->{"compressor"}->set_compression($method);
|
|
|
}
|
|
|
- $self->{"compression"} = $method;
|
|
|
+ *$self->{"compression"} = $method;
|
|
|
}
|
|
|
|
|
|
+=item $fh->set_compression_level($level)
|
|
|
+
|
|
|
+Indicate the desired compression level. It should a value supported by
|
|
|
+the B<set_compression_level> method of B<Dpkg::Compression::Compressor>.
|
|
|
+
|
|
|
+=cut
|
|
|
+
|
|
|
sub set_compression_level {
|
|
|
my ($self, $level) = @_;
|
|
|
- $self->{"compressor"}->set_compression_level($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;
|
|
|
+ *$self->{"filename"} = $filename;
|
|
|
# Automatically add compression extension to filename
|
|
|
if (defined($add_comp_ext)) {
|
|
|
- $self->{"add_comp_ext"} = $add_comp_ext;
|
|
|
+ *$self->{"add_comp_ext"} = $add_comp_ext;
|
|
|
}
|
|
|
- if ($self->{"add_comp_ext"} and $filename =~ /\.$comp_regex$/) {
|
|
|
+ if (*$self->{"add_comp_ext"} and $filename =~ /\.$comp_regex$/) {
|
|
|
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'}) {
|
|
|
+ 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"};
|
|
|
+ return *$self->{"filename"};
|
|
|
} else {
|
|
|
- return $self->{"filename"} . "." . $comp_ext{$comp};
|
|
|
+ return *$self->{"filename"} . "." . $comp_ext{$comp};
|
|
|
}
|
|
|
} else {
|
|
|
- return $self->{"filename"};
|
|
|
+ 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, $update) = @_;
|
|
|
- my $comp = $self->{"compression"};
|
|
|
+ my ($self) = @_;
|
|
|
+ my $comp = *$self->{"compression"};
|
|
|
if ($comp eq "none") {
|
|
|
return 0;
|
|
|
} elsif ($comp eq "auto") {
|
|
|
$comp = get_compression_from_filename($self->get_filename());
|
|
|
- $self->{"compressor"}->set_compression($comp) if $comp;
|
|
|
+ *$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) = @_;
|
|
|
- my $handle;
|
|
|
+ error("Can't reopen an already opened compressed file") if exists *$self->{"mode"};
|
|
|
+ my $filehandle;
|
|
|
if ($self->use_compression()) {
|
|
|
- $self->{'compressor'}->compress(from_pipe => \$handle,
|
|
|
+ *$self->{'compressor'}->compress(from_pipe => \$filehandle,
|
|
|
to_file => $self->get_filename());
|
|
|
} else {
|
|
|
- open($handle, '>', $self->get_filename()) ||
|
|
|
+ CORE::open($filehandle, ">", $self->get_filename) ||
|
|
|
syserr(_g("cannot write %s"), $self->get_filename());
|
|
|
}
|
|
|
- return $handle;
|
|
|
+ *$self->{"mode"} = "w";
|
|
|
+ *$self->{"file"} = $filehandle;
|
|
|
}
|
|
|
|
|
|
sub open_for_read {
|
|
|
my ($self) = @_;
|
|
|
- my $handle;
|
|
|
+ error("Can't reopen an already opened compressed file") if exists *$self->{"mode"};
|
|
|
+ my $filehandle;
|
|
|
if ($self->use_compression()) {
|
|
|
- $self->{'compressor'}->uncompress(to_pipe => \$handle,
|
|
|
+ *$self->{'compressor'}->uncompress(to_pipe => \$filehandle,
|
|
|
from_file => $self->get_filename());
|
|
|
- $self->{'allow_sigpipe'} = 1;
|
|
|
+ *$self->{'allow_sigpipe'} = 1;
|
|
|
} else {
|
|
|
- open($handle, '<', $self->get_filename()) ||
|
|
|
+ CORE::open($filehandle, "<", $self->get_filename) ||
|
|
|
syserr(_g("cannot read %s"), $self->get_filename());
|
|
|
}
|
|
|
- return $handle;
|
|
|
+ *$self->{"mode"} = "r";
|
|
|
+ *$self->{"file"} = $filehandle;
|
|
|
}
|
|
|
|
|
|
-sub cleanup_after_open {
|
|
|
+sub cleanup {
|
|
|
my ($self) = @_;
|
|
|
- my $cmdline = $self->{"compressor"}{"cmdline"} || "";
|
|
|
- $self->{"compressor"}->wait_end_process(nocheck => $self->{'allow_sigpipe'});
|
|
|
- if ($self->{'allow_sigpipe'}) {
|
|
|
+ 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::CompressedFile 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;
|