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