diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/lib/IO |
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/IO')
38 files changed, 25012 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm new file mode 100644 index 0000000000..99773e8160 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm @@ -0,0 +1,154 @@ +package IO::Compress::Adapter::Bzip2 ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.074 qw(:Status); + +use Compress::Raw::Bzip2 2.074 ; + +our ($VERSION); +$VERSION = '2.074'; + +sub mkCompObject +{ + my $BlockSize100K = shift ; + my $WorkFactor = shift ; + my $Verbosity = shift ; + + $BlockSize100K = 1 if ! defined $BlockSize100K ; + $WorkFactor = 0 if ! defined $WorkFactor ; + $Verbosity = 0 if ! defined $Verbosity ; + + my ($def, $status) = new Compress::Raw::Bzip2(1, $BlockSize100K, + $WorkFactor, $Verbosity); + + return (undef, "Could not create Deflate object: $status", $status) + if $status != BZ_OK ; + + return bless {'Def' => $def, + 'Error' => '', + 'ErrorNo' => 0, + } ; +} + +sub compr +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->bzdeflate($_[0], $_[1]) ; + $self->{ErrorNo} = $status; + + if ($status != BZ_RUN_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; +} + +sub flush +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->bzflush($_[0]); + $self->{ErrorNo} = $status; + + if ($status != BZ_RUN_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; + +} + +sub close +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->bzclose($_[0]); + $self->{ErrorNo} = $status; + + if ($status != BZ_STREAM_END) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; + +} + + +sub reset +{ + my $self = shift ; + + my $outer = $self->{Outer}; + + my ($def, $status) = new Compress::Raw::Bzip2(); + $self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ; + + if ($status != BZ_OK) + { + $self->{Error} = "Cannot create Deflate object: $status"; + return STATUS_ERROR; + } + + $self->{Def} = $def; + + return STATUS_OK; +} + +sub compressedBytes +{ + my $self = shift ; + $self->{Def}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Def}->uncompressedBytes(); +} + +#sub total_out +#{ +# my $self = shift ; +# 0; +#} +# + +#sub total_in +#{ +# my $self = shift ; +# $self->{Def}->total_in(); +#} +# +#sub crc32 +#{ +# my $self = shift ; +# $self->{Def}->crc32(); +#} +# +#sub adler32 +#{ +# my $self = shift ; +# $self->{Def}->adler32(); +#} + + +1; + +__END__ + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm new file mode 100644 index 0000000000..1edd3fa62a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm @@ -0,0 +1,170 @@ +package IO::Compress::Adapter::Deflate ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.074 qw(:Status); +use Compress::Raw::Zlib 2.074 qw( !crc32 !adler32 ) ; + +require Exporter; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, @EXPORT, %DEFLATE_CONSTANTS); + +$VERSION = '2.074'; +@ISA = qw(Exporter); +@EXPORT_OK = @Compress::Raw::Zlib::DEFLATE_CONSTANTS; +%EXPORT_TAGS = %Compress::Raw::Zlib::DEFLATE_CONSTANTS; +@EXPORT = @EXPORT_OK; +%DEFLATE_CONSTANTS = %EXPORT_TAGS ; + +sub mkCompObject +{ + my $crc32 = shift ; + my $adler32 = shift ; + my $level = shift ; + my $strategy = shift ; + + my ($def, $status) = new Compress::Raw::Zlib::Deflate + -AppendOutput => 1, + -CRC32 => $crc32, + -ADLER32 => $adler32, + -Level => $level, + -Strategy => $strategy, + -WindowBits => - MAX_WBITS; + + return (undef, "Cannot create Deflate object: $status", $status) + if $status != Z_OK; + + return bless {'Def' => $def, + 'Error' => '', + } ; +} + +sub compr +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->deflate($_[0], $_[1]) ; + $self->{ErrorNo} = $status; + + if ($status != Z_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; +} + +sub flush +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $opt = $_[1] || Z_FINISH; + my $status = $def->flush($_[0], $opt); + $self->{ErrorNo} = $status; + + if ($status != Z_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; +} + +sub close +{ + my $self = shift ; + + my $def = $self->{Def}; + + $def->flush($_[0], Z_FINISH) + if defined $def ; +} + +sub reset +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->deflateReset() ; + $self->{ErrorNo} = $status; + if ($status != Z_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; +} + +sub deflateParams +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->deflateParams(@_); + $self->{ErrorNo} = $status; + if ($status != Z_OK) + { + $self->{Error} = "deflateParams Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK; +} + + + +#sub total_out +#{ +# my $self = shift ; +# $self->{Def}->total_out(); +#} +# +#sub total_in +#{ +# my $self = shift ; +# $self->{Def}->total_in(); +#} + +sub compressedBytes +{ + my $self = shift ; + + $self->{Def}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Def}->uncompressedBytes(); +} + + + + +sub crc32 +{ + my $self = shift ; + $self->{Def}->crc32(); +} + +sub adler32 +{ + my $self = shift ; + $self->{Def}->adler32(); +} + + +1; + +__END__ + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Adapter/Identity.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Adapter/Identity.pm new file mode 100644 index 0000000000..71dee011ff --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Adapter/Identity.pm @@ -0,0 +1,101 @@ +package IO::Compress::Adapter::Identity ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.074 qw(:Status); +our ($VERSION); + +$VERSION = '2.074'; + +sub mkCompObject +{ + my $level = shift ; + my $strategy = shift ; + + return bless { + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + 'ErrorNo' => 0, + } ; +} + +sub compr +{ + my $self = shift ; + + if (defined ${ $_[0] } && length ${ $_[0] }) { + $self->{CompSize} += length ${ $_[0] } ; + $self->{UnCompSize} = $self->{CompSize} ; + + if ( ref $_[1] ) + { ${ $_[1] } .= ${ $_[0] } } + else + { $_[1] .= ${ $_[0] } } + } + + return STATUS_OK ; +} + +sub flush +{ + my $self = shift ; + + return STATUS_OK; +} + +sub close +{ + my $self = shift ; + + return STATUS_OK; +} + +sub reset +{ + my $self = shift ; + + $self->{CompSize} = 0; + $self->{UnCompSize} = 0; + + return STATUS_OK; +} + +sub deflateParams +{ + my $self = shift ; + + return STATUS_OK; +} + +#sub total_out +#{ +# my $self = shift ; +# return $self->{UnCompSize} ; +#} +# +#sub total_in +#{ +# my $self = shift ; +# return $self->{UnCompSize} ; +#} + +sub compressedBytes +{ + my $self = shift ; + return $self->{UnCompSize} ; +} + +sub uncompressedBytes +{ + my $self = shift ; + return $self->{UnCompSize} ; +} + +1; + + +__END__ + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Base.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Base.pm new file mode 100644 index 0000000000..74eac6fba6 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Base.pm @@ -0,0 +1,1048 @@ + +package IO::Compress::Base ; + +require 5.006 ; + +use strict ; +use warnings; + +use IO::Compress::Base::Common 2.074 ; + +use IO::File (); ; +use Scalar::Util (); + +#use File::Glob; +#require Exporter ; +use Carp() ; +use Symbol(); +#use bytes; + +our (@ISA, $VERSION); +@ISA = qw(IO::File Exporter); + +$VERSION = '2.074'; + +#Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16. + +sub saveStatus +{ + my $self = shift ; + ${ *$self->{ErrorNo} } = shift() + 0 ; + ${ *$self->{Error} } = '' ; + + return ${ *$self->{ErrorNo} } ; +} + + +sub saveErrorString +{ + my $self = shift ; + my $retval = shift ; + ${ *$self->{Error} } = shift ; + ${ *$self->{ErrorNo} } = shift() + 0 if @_ ; + + return $retval; +} + +sub croakError +{ + my $self = shift ; + $self->saveErrorString(0, $_[0]); + Carp::croak $_[0]; +} + +sub closeError +{ + my $self = shift ; + my $retval = shift ; + + my $errno = *$self->{ErrorNo}; + my $error = ${ *$self->{Error} }; + + $self->close(); + + *$self->{ErrorNo} = $errno ; + ${ *$self->{Error} } = $error ; + + return $retval; +} + + + +sub error +{ + my $self = shift ; + return ${ *$self->{Error} } ; +} + +sub errorNo +{ + my $self = shift ; + return ${ *$self->{ErrorNo} } ; +} + + +sub writeAt +{ + my $self = shift ; + my $offset = shift; + my $data = shift; + + if (defined *$self->{FH}) { + my $here = tell(*$self->{FH}); + return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) + if $here < 0 ; + seek(*$self->{FH}, $offset, IO::Handle::SEEK_SET) + or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; + defined *$self->{FH}->write($data, length $data) + or return $self->saveErrorString(undef, $!, $!) ; + seek(*$self->{FH}, $here, IO::Handle::SEEK_SET) + or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; + } + else { + substr(${ *$self->{Buffer} }, $offset, length($data)) = $data ; + } + + return 1; +} + +sub outputPayload +{ + + my $self = shift ; + return $self->output(@_); +} + + +sub output +{ + my $self = shift ; + my $data = shift ; + my $last = shift ; + + return 1 + if length $data == 0 && ! $last ; + + if ( *$self->{FilterContainer} ) { + *_ = \$data; + &{ *$self->{FilterContainer} }(); + } + + if (length $data) { + if ( defined *$self->{FH} ) { + defined *$self->{FH}->write( $data, length $data ) + or return $self->saveErrorString(0, $!, $!); + } + else { + ${ *$self->{Buffer} } .= $data ; + } + } + + return 1; +} + +sub getOneShotParams +{ + return ( 'multistream' => [IO::Compress::Base::Common::Parse_boolean, 1], + ); +} + +our %PARAMS = ( + # Generic Parameters + 'autoclose' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'encode' => [IO::Compress::Base::Common::Parse_any, undef], + 'strict' => [IO::Compress::Base::Common::Parse_boolean, 1], + 'append' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'binmodein' => [IO::Compress::Base::Common::Parse_boolean, 0], + + 'filtercontainer' => [IO::Compress::Base::Common::Parse_code, undef], + ); + +sub checkParams +{ + my $self = shift ; + my $class = shift ; + + my $got = shift || IO::Compress::Base::Parameters::new(); + + $got->parse( + { + %PARAMS, + + + $self->getExtraParams(), + *$self->{OneShot} ? $self->getOneShotParams() + : (), + }, + @_) or $self->croakError("${class}: " . $got->getError()) ; + + return $got ; +} + +sub _create +{ + my $obj = shift; + my $got = shift; + + *$obj->{Closed} = 1 ; + + my $class = ref $obj; + $obj->croakError("$class: Missing Output parameter") + if ! @_ && ! $got ; + + my $outValue = shift ; + my $oneShot = 1 ; + + if (! $got) + { + $oneShot = 0 ; + $got = $obj->checkParams($class, undef, @_) + or return undef ; + } + + my $lax = ! $got->getValue('strict') ; + + my $outType = IO::Compress::Base::Common::whatIsOutput($outValue); + + $obj->ckOutputParam($class, $outValue) + or return undef ; + + if ($outType eq 'buffer') { + *$obj->{Buffer} = $outValue; + } + else { + my $buff = "" ; + *$obj->{Buffer} = \$buff ; + } + + # Merge implies Append + my $merge = $got->getValue('merge') ; + my $appendOutput = $got->getValue('append') || $merge ; + *$obj->{Append} = $appendOutput; + *$obj->{FilterContainer} = $got->getValue('filtercontainer') ; + + if ($merge) + { + # Switch off Merge mode if output file/buffer is empty/doesn't exist + if (($outType eq 'buffer' && length $$outValue == 0 ) || + ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) ) + { $merge = 0 } + } + + # If output is a file, check that it is writable + #no warnings; + #if ($outType eq 'filename' && -e $outValue && ! -w _) + # { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) } + + $obj->ckParams($got) + or $obj->croakError("${class}: " . $obj->error()); + + if ($got->getValue('encode')) { + my $want_encoding = $got->getValue('encode'); + *$obj->{Encoding} = IO::Compress::Base::Common::getEncoding($obj, $class, $want_encoding); + my $x = *$obj->{Encoding}; + } + else { + *$obj->{Encoding} = undef; + } + + $obj->saveStatus(STATUS_OK) ; + + my $status ; + if (! $merge) + { + *$obj->{Compress} = $obj->mkComp($got) + or return undef; + + *$obj->{UnCompSize} = new U64 ; + *$obj->{CompSize} = new U64 ; + + if ( $outType eq 'buffer') { + ${ *$obj->{Buffer} } = '' + unless $appendOutput ; + } + else { + if ($outType eq 'handle') { + *$obj->{FH} = $outValue ; + setBinModeOutput(*$obj->{FH}) ; + #$outValue->flush() ; + *$obj->{Handle} = 1 ; + if ($appendOutput) + { + seek(*$obj->{FH}, 0, IO::Handle::SEEK_END) + or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ; + + } + } + elsif ($outType eq 'filename') { + no warnings; + my $mode = '>' ; + $mode = '>>' + if $appendOutput; + *$obj->{FH} = new IO::File "$mode $outValue" + or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ; + *$obj->{StdIO} = ($outValue eq '-'); + setBinModeOutput(*$obj->{FH}) ; + } + } + + *$obj->{Header} = $obj->mkHeader($got) ; + $obj->output( *$obj->{Header} ) + or return undef; + $obj->beforePayload(); + } + else + { + *$obj->{Compress} = $obj->createMerge($outValue, $outType) + or return undef; + } + + *$obj->{Closed} = 0 ; + *$obj->{AutoClose} = $got->getValue('autoclose') ; + *$obj->{Output} = $outValue; + *$obj->{ClassName} = $class; + *$obj->{Got} = $got; + *$obj->{OneShot} = 0 ; + + return $obj ; +} + +sub ckOutputParam +{ + my $self = shift ; + my $from = shift ; + my $outType = IO::Compress::Base::Common::whatIsOutput($_[0]); + + $self->croakError("$from: output parameter not a filename, filehandle or scalar ref") + if ! $outType ; + + #$self->croakError("$from: output filename is undef or null string") + #if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ; + + $self->croakError("$from: output buffer is read-only") + if $outType eq 'buffer' && Scalar::Util::readonly(${ $_[0] }); + + return 1; +} + + +sub _def +{ + my $obj = shift ; + + my $class= (caller)[0] ; + my $name = (caller(1))[3] ; + + $obj->croakError("$name: expected at least 1 parameters\n") + unless @_ >= 1 ; + + my $input = shift ; + my $haveOut = @_ ; + my $output = shift ; + + my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output) + or return undef ; + + push @_, $output if $haveOut && $x->{Hash}; + + *$obj->{OneShot} = 1 ; + + my $got = $obj->checkParams($name, undef, @_) + or return undef ; + + $x->{Got} = $got ; + +# if ($x->{Hash}) +# { +# while (my($k, $v) = each %$input) +# { +# $v = \$input->{$k} +# unless defined $v ; +# +# $obj->_singleTarget($x, 1, $k, $v, @_) +# or return undef ; +# } +# +# return keys %$input ; +# } + + if ($x->{GlobMap}) + { + $x->{oneInput} = 1 ; + foreach my $pair (@{ $x->{Pairs} }) + { + my ($from, $to) = @$pair ; + $obj->_singleTarget($x, 1, $from, $to, @_) + or return undef ; + } + + return scalar @{ $x->{Pairs} } ; + } + + if (! $x->{oneOutput} ) + { + my $inFile = ($x->{inType} eq 'filenames' + || $x->{inType} eq 'filename'); + + $x->{inType} = $inFile ? 'filename' : 'buffer'; + + foreach my $in ($x->{oneInput} ? $input : @$input) + { + my $out ; + $x->{oneInput} = 1 ; + + $obj->_singleTarget($x, $inFile, $in, \$out, @_) + or return undef ; + + push @$output, \$out ; + #if ($x->{outType} eq 'array') + # { push @$output, \$out } + #else + # { $output->{$in} = \$out } + } + + return 1 ; + } + + # finally the 1 to 1 and n to 1 + return $obj->_singleTarget($x, 1, $input, $output, @_); + + Carp::croak "should not be here" ; +} + +sub _singleTarget +{ + my $obj = shift ; + my $x = shift ; + my $inputIsFilename = shift; + my $input = shift; + + if ($x->{oneInput}) + { + $obj->getFileInfo($x->{Got}, $input) + if isaScalar($input) || (isaFilename($input) and $inputIsFilename) ; + + my $z = $obj->_create($x->{Got}, @_) + or return undef ; + + + defined $z->_wr2($input, $inputIsFilename) + or return $z->closeError(undef) ; + + return $z->close() ; + } + else + { + my $afterFirst = 0 ; + my $inputIsFilename = ($x->{inType} ne 'array'); + my $keep = $x->{Got}->clone(); + + #for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) + for my $element ( @$input) + { + my $isFilename = isaFilename($element); + + if ( $afterFirst ++ ) + { + defined addInterStream($obj, $element, $isFilename) + or return $obj->closeError(undef) ; + } + else + { + $obj->getFileInfo($x->{Got}, $element) + if isaScalar($element) || $isFilename; + + $obj->_create($x->{Got}, @_) + or return undef ; + } + + defined $obj->_wr2($element, $isFilename) + or return $obj->closeError(undef) ; + + *$obj->{Got} = $keep->clone(); + } + return $obj->close() ; + } + +} + +sub _wr2 +{ + my $self = shift ; + + my $source = shift ; + my $inputIsFilename = shift; + + my $input = $source ; + if (! $inputIsFilename) + { + $input = \$source + if ! ref $source; + } + + if ( ref $input && ref $input eq 'SCALAR' ) + { + return $self->syswrite($input, @_) ; + } + + if ( ! ref $input || isaFilehandle($input)) + { + my $isFilehandle = isaFilehandle($input) ; + + my $fh = $input ; + + if ( ! $isFilehandle ) + { + $fh = new IO::File "<$input" + or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ; + } + binmode $fh if *$self->{Got}->valueOrDefault('binmodein') ; + + my $status ; + my $buff ; + my $count = 0 ; + while ($status = read($fh, $buff, 16 * 1024)) { + $count += length $buff; + defined $self->syswrite($buff, @_) + or return undef ; + } + + return $self->saveErrorString(undef, $!, $!) + if ! defined $status ; + + if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-') + { + $fh->close() + or return undef ; + } + + return $count ; + } + + Carp::croak "Should not be here"; + return undef; +} + +sub addInterStream +{ + my $self = shift ; + my $input = shift ; + my $inputIsFilename = shift ; + + if (*$self->{Got}->getValue('multistream')) + { + $self->getFileInfo(*$self->{Got}, $input) + #if isaFilename($input) and $inputIsFilename ; + if isaScalar($input) || isaFilename($input) ; + + # TODO -- newStream needs to allow gzip/zip header to be modified + return $self->newStream(); + } + elsif (*$self->{Got}->getValue('autoflush')) + { + #return $self->flush(Z_FULL_FLUSH); + } + + return 1 ; +} + +sub getFileInfo +{ +} + +sub TIEHANDLE +{ + return $_[0] if ref($_[0]); + die "OOPS\n" ; +} + +sub UNTIE +{ + my $self = shift ; +} + +sub DESTROY +{ + my $self = shift ; + local ($., $@, $!, $^E, $?); + + $self->close() ; + + # TODO - memory leak with 5.8.0 - this isn't called until + # global destruction + # + %{ *$self } = () ; + undef $self ; +} + + + +sub filterUncompressed +{ +} + +sub syswrite +{ + my $self = shift ; + + my $buffer ; + if (ref $_[0] ) { + $self->croakError( *$self->{ClassName} . "::write: not a scalar reference" ) + unless ref $_[0] eq 'SCALAR' ; + $buffer = $_[0] ; + } + else { + $buffer = \$_[0] ; + } + + if (@_ > 1) { + my $slen = defined $$buffer ? length($$buffer) : 0; + my $len = $slen; + my $offset = 0; + $len = $_[1] if $_[1] < $len; + + if (@_ > 2) { + $offset = $_[2] || 0; + $self->croakError(*$self->{ClassName} . "::write: offset outside string") + if $offset > $slen; + if ($offset < 0) { + $offset += $slen; + $self->croakError( *$self->{ClassName} . "::write: offset outside string") if $offset < 0; + } + my $rem = $slen - $offset; + $len = $rem if $rem < $len; + } + + $buffer = \substr($$buffer, $offset, $len) ; + } + + return 0 if (! defined $$buffer || length $$buffer == 0) && ! *$self->{FlushPending}; + +# *$self->{Pending} .= $$buffer ; +# +# return length $$buffer +# if (length *$self->{Pending} < 1024 * 16 && ! *$self->{FlushPending}) ; +# +# $$buffer = *$self->{Pending} ; +# *$self->{Pending} = ''; + + if (*$self->{Encoding}) { + $$buffer = *$self->{Encoding}->encode($$buffer); + } + else { + $] >= 5.008 and ( utf8::downgrade($$buffer, 1) + or Carp::croak "Wide character in " . *$self->{ClassName} . "::write:"); + } + + $self->filterUncompressed($buffer); + + my $buffer_length = defined $$buffer ? length($$buffer) : 0 ; + *$self->{UnCompSize}->add($buffer_length) ; + + my $outBuffer=''; + my $status = *$self->{Compress}->compr($buffer, $outBuffer) ; + + return $self->saveErrorString(undef, *$self->{Compress}{Error}, + *$self->{Compress}{ErrorNo}) + if $status == STATUS_ERROR; + + *$self->{CompSize}->add(length $outBuffer) ; + + $self->outputPayload($outBuffer) + or return undef; + + return $buffer_length; +} + +sub print +{ + my $self = shift; + + #if (ref $self) { + # $self = *$self{GLOB} ; + #} + + if (defined $\) { + if (defined $,) { + defined $self->syswrite(join($,, @_) . $\); + } else { + defined $self->syswrite(join("", @_) . $\); + } + } else { + if (defined $,) { + defined $self->syswrite(join($,, @_)); + } else { + defined $self->syswrite(join("", @_)); + } + } +} + +sub printf +{ + my $self = shift; + my $fmt = shift; + defined $self->syswrite(sprintf($fmt, @_)); +} + +sub _flushCompressed +{ + my $self = shift ; + + my $outBuffer=''; + my $status = *$self->{Compress}->flush($outBuffer, @_) ; + return $self->saveErrorString(0, *$self->{Compress}{Error}, + *$self->{Compress}{ErrorNo}) + if $status == STATUS_ERROR; + + if ( defined *$self->{FH} ) { + *$self->{FH}->clearerr(); + } + + *$self->{CompSize}->add(length $outBuffer) ; + + $self->outputPayload($outBuffer) + or return 0; + return 1; +} + +sub flush +{ + my $self = shift ; + + $self->_flushCompressed(@_) + or return 0; + + if ( defined *$self->{FH} ) { + defined *$self->{FH}->flush() + or return $self->saveErrorString(0, $!, $!); + } + + return 1; +} + +sub beforePayload +{ +} + +sub _newStream +{ + my $self = shift ; + my $got = shift; + + my $class = ref $self; + + $self->_writeTrailer() + or return 0 ; + + $self->ckParams($got) + or $self->croakError("newStream: $self->{Error}"); + + if ($got->getValue('encode')) { + my $want_encoding = $got->getValue('encode'); + *$self->{Encoding} = IO::Compress::Base::Common::getEncoding($self, $class, $want_encoding); + } + else { + *$self->{Encoding} = undef; + } + + *$self->{Compress} = $self->mkComp($got) + or return 0; + + *$self->{Header} = $self->mkHeader($got) ; + $self->output(*$self->{Header} ) + or return 0; + + *$self->{UnCompSize}->reset(); + *$self->{CompSize}->reset(); + + $self->beforePayload(); + + return 1 ; +} + +sub newStream +{ + my $self = shift ; + + my $got = $self->checkParams('newStream', *$self->{Got}, @_) + or return 0 ; + + $self->_newStream($got); + +# *$self->{Compress} = $self->mkComp($got) +# or return 0; +# +# *$self->{Header} = $self->mkHeader($got) ; +# $self->output(*$self->{Header} ) +# or return 0; +# +# *$self->{UnCompSize}->reset(); +# *$self->{CompSize}->reset(); +# +# $self->beforePayload(); +# +# return 1 ; +} + +sub reset +{ + my $self = shift ; + return *$self->{Compress}->reset() ; +} + +sub _writeTrailer +{ + my $self = shift ; + + my $trailer = ''; + + my $status = *$self->{Compress}->close($trailer) ; + return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) + if $status == STATUS_ERROR; + + *$self->{CompSize}->add(length $trailer) ; + + $trailer .= $self->mkTrailer(); + defined $trailer + or return 0; + + return $self->output($trailer); +} + +sub _writeFinalTrailer +{ + my $self = shift ; + + return $self->output($self->mkFinalTrailer()); +} + +sub close +{ + my $self = shift ; + return 1 if *$self->{Closed} || ! *$self->{Compress} ; + *$self->{Closed} = 1 ; + + untie *$self + if $] >= 5.008 ; + + *$self->{FlushPending} = 1 ; + $self->_writeTrailer() + or return 0 ; + + $self->_writeFinalTrailer() + or return 0 ; + + $self->output( "", 1 ) + or return 0; + + if (defined *$self->{FH}) { + + if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { + $! = 0 ; + *$self->{FH}->close() + or return $self->saveErrorString(0, $!, $!); + } + delete *$self->{FH} ; + # This delete can set $! in older Perls, so reset the errno + $! = 0 ; + } + + return 1; +} + + +#sub total_in +#sub total_out +#sub msg +# +#sub crc +#{ +# my $self = shift ; +# return *$self->{Compress}->crc32() ; +#} +# +#sub msg +#{ +# my $self = shift ; +# return *$self->{Compress}->msg() ; +#} +# +#sub dict_adler +#{ +# my $self = shift ; +# return *$self->{Compress}->dict_adler() ; +#} +# +#sub get_Level +#{ +# my $self = shift ; +# return *$self->{Compress}->get_Level() ; +#} +# +#sub get_Strategy +#{ +# my $self = shift ; +# return *$self->{Compress}->get_Strategy() ; +#} + + +sub tell +{ + my $self = shift ; + + return *$self->{UnCompSize}->get32bit() ; +} + +sub eof +{ + my $self = shift ; + + return *$self->{Closed} ; +} + + +sub seek +{ + my $self = shift ; + my $position = shift; + my $whence = shift ; + + my $here = $self->tell() ; + my $target = 0 ; + + #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); + use IO::Handle ; + + if ($whence == IO::Handle::SEEK_SET) { + $target = $position ; + } + elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) { + $target = $here + $position ; + } + else { + $self->croakError(*$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter"); + } + + # short circuit if seeking to current offset + return 1 if $target == $here ; + + # Outlaw any attempt to seek backwards + $self->croakError(*$self->{ClassName} . "::seek: cannot seek backwards") + if $target < $here ; + + # Walk the file to the new offset + my $offset = $target - $here ; + + my $buffer ; + defined $self->syswrite("\x00" x $offset) + or return 0; + + return 1 ; +} + +sub binmode +{ + 1; +# my $self = shift ; +# return defined *$self->{FH} +# ? binmode *$self->{FH} +# : 1 ; +} + +sub fileno +{ + my $self = shift ; + return defined *$self->{FH} + ? *$self->{FH}->fileno() + : undef ; +} + +sub opened +{ + my $self = shift ; + return ! *$self->{Closed} ; +} + +sub autoflush +{ + my $self = shift ; + return defined *$self->{FH} + ? *$self->{FH}->autoflush(@_) + : undef ; +} + +sub input_line_number +{ + return undef ; +} + + +sub _notAvailable +{ + my $name = shift ; + return sub { Carp::croak "$name Not Available: File opened only for output" ; } ; +} + +*read = _notAvailable('read'); +*READ = _notAvailable('read'); +*readline = _notAvailable('readline'); +*READLINE = _notAvailable('readline'); +*getc = _notAvailable('getc'); +*GETC = _notAvailable('getc'); + +*FILENO = \&fileno; +*PRINT = \&print; +*PRINTF = \&printf; +*WRITE = \&syswrite; +*write = \&syswrite; +*SEEK = \&seek; +*TELL = \&tell; +*EOF = \&eof; +*CLOSE = \&close; +*BINMODE = \&binmode; + +#*sysread = \&_notAvailable; +#*syswrite = \&_write; + +1; + +__END__ + +=head1 NAME + +IO::Compress::Base - Base Class for IO::Compress modules + +=head1 SYNOPSIS + + use IO::Compress::Base ; + +=head1 DESCRIPTION + +This module is not intended for direct use in application code. Its sole +purpose is to be sub-classed by IO::Compress modules. + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm new file mode 100644 index 0000000000..c82c99a441 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm @@ -0,0 +1,1045 @@ +package IO::Compress::Base::Common; + +use strict ; +use warnings; +use bytes; + +use Carp; +use Scalar::Util qw(blessed readonly); +use File::GlobMapper; + +require Exporter; +our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE); +@ISA = qw(Exporter); +$VERSION = '2.074'; + +@EXPORT = qw( isaFilehandle isaFilename isaScalar + whatIsInput whatIsOutput + isaFileGlobString cleanFileGlobString oneTarget + setBinModeInput setBinModeOutput + ckInOutParams + createSelfTiedObject + + isGeMax32 + + MAX32 + + WANT_CODE + WANT_EXT + WANT_UNDEF + WANT_HASH + + STATUS_OK + STATUS_ENDSTREAM + STATUS_EOF + STATUS_ERROR + ); + +%EXPORT_TAGS = ( Status => [qw( STATUS_OK + STATUS_ENDSTREAM + STATUS_EOF + STATUS_ERROR + )]); + + +use constant STATUS_OK => 0; +use constant STATUS_ENDSTREAM => 1; +use constant STATUS_EOF => 2; +use constant STATUS_ERROR => -1; +use constant MAX16 => 0xFFFF ; +use constant MAX32 => 0xFFFFFFFF ; +use constant MAX32cmp => 0xFFFFFFFF + 1 - 1; # for 5.6.x on 32-bit need to force an non-IV value + + +sub isGeMax32 +{ + return $_[0] >= MAX32cmp ; +} + +sub hasEncode() +{ + if (! defined $HAS_ENCODE) { + eval + { + require Encode; + Encode->import(); + }; + + $HAS_ENCODE = $@ ? 0 : 1 ; + } + + return $HAS_ENCODE; +} + +sub getEncoding($$$) +{ + my $obj = shift; + my $class = shift ; + my $want_encoding = shift ; + + $obj->croakError("$class: Encode module needed to use -Encode") + if ! hasEncode(); + + my $encoding = Encode::find_encoding($want_encoding); + + $obj->croakError("$class: Encoding '$want_encoding' is not available") + if ! $encoding; + + return $encoding; +} + +our ($needBinmode); +$needBinmode = ($^O eq 'MSWin32' || + ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} ')) + ? 1 : 1 ; + +sub setBinModeInput($) +{ + my $handle = shift ; + + binmode $handle + if $needBinmode; +} + +sub setBinModeOutput($) +{ + my $handle = shift ; + + binmode $handle + if $needBinmode; +} + +sub isaFilehandle($) +{ + use utf8; # Pragma needed to keep Perl 5.6.0 happy + return (defined $_[0] and + (UNIVERSAL::isa($_[0],'GLOB') or + UNIVERSAL::isa($_[0],'IO::Handle') or + UNIVERSAL::isa(\$_[0],'GLOB')) + ) +} + +sub isaScalar +{ + return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ; +} + +sub isaFilename($) +{ + return (defined $_[0] and + ! ref $_[0] and + UNIVERSAL::isa(\$_[0], 'SCALAR')); +} + +sub isaFileGlobString +{ + return defined $_[0] && $_[0] =~ /^<.*>$/; +} + +sub cleanFileGlobString +{ + my $string = shift ; + + $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; + + return $string; +} + +use constant WANT_CODE => 1 ; +use constant WANT_EXT => 2 ; +use constant WANT_UNDEF => 4 ; +#use constant WANT_HASH => 8 ; +use constant WANT_HASH => 0 ; + +sub whatIsInput($;$) +{ + my $got = whatIs(@_); + + if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') + { + #use IO::File; + $got = 'handle'; + $_[0] = *STDIN; + #$_[0] = new IO::File("<-"); + } + + return $got; +} + +sub whatIsOutput($;$) +{ + my $got = whatIs(@_); + + if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') + { + $got = 'handle'; + $_[0] = *STDOUT; + #$_[0] = new IO::File(">-"); + } + + return $got; +} + +sub whatIs ($;$) +{ + return 'handle' if isaFilehandle($_[0]); + + my $wantCode = defined $_[1] && $_[1] & WANT_CODE ; + my $extended = defined $_[1] && $_[1] & WANT_EXT ; + my $undef = defined $_[1] && $_[1] & WANT_UNDEF ; + my $hash = defined $_[1] && $_[1] & WANT_HASH ; + + return 'undef' if ! defined $_[0] && $undef ; + + if (ref $_[0]) { + return '' if blessed($_[0]); # is an object + #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object + return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR'); + return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ; + return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ; + return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ; + return ''; + } + + return 'fileglob' if $extended && isaFileGlobString($_[0]); + return 'filename'; +} + +sub oneTarget +{ + return $_[0] =~ /^(code|handle|buffer|filename)$/; +} + +sub IO::Compress::Base::Validator::new +{ + my $class = shift ; + + my $Class = shift ; + my $error_ref = shift ; + my $reportClass = shift ; + + my %data = (Class => $Class, + Error => $error_ref, + reportClass => $reportClass, + ) ; + + my $obj = bless \%data, $class ; + + local $Carp::CarpLevel = 1; + + my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH); + my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH); + + my $oneInput = $data{oneInput} = oneTarget($inType); + my $oneOutput = $data{oneOutput} = oneTarget($outType); + + if (! $inType) + { + $obj->croakError("$reportClass: illegal input parameter") ; + #return undef ; + } + +# if ($inType eq 'hash') +# { +# $obj->{Hash} = 1 ; +# $obj->{oneInput} = 1 ; +# return $obj->validateHash($_[0]); +# } + + if (! $outType) + { + $obj->croakError("$reportClass: illegal output parameter") ; + #return undef ; + } + + + if ($inType ne 'fileglob' && $outType eq 'fileglob') + { + $obj->croakError("Need input fileglob for outout fileglob"); + } + +# if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' ) +# { +# $obj->croakError("input must ne filename or fileglob when output is a hash"); +# } + + if ($inType eq 'fileglob' && $outType eq 'fileglob') + { + $data{GlobMap} = 1 ; + $data{inType} = $data{outType} = 'filename'; + my $mapper = new File::GlobMapper($_[0], $_[1]); + if ( ! $mapper ) + { + return $obj->saveErrorString($File::GlobMapper::Error) ; + } + $data{Pairs} = $mapper->getFileMap(); + + return $obj; + } + + $obj->croakError("$reportClass: input and output $inType are identical") + if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ; + + if ($inType eq 'fileglob') # && $outType ne 'fileglob' + { + my $glob = cleanFileGlobString($_[0]); + my @inputs = glob($glob); + + if (@inputs == 0) + { + # TODO -- legal or die? + die "globmap matched zero file -- legal or die???" ; + } + elsif (@inputs == 1) + { + $obj->validateInputFilenames($inputs[0]) + or return undef; + $_[0] = $inputs[0] ; + $data{inType} = 'filename' ; + $data{oneInput} = 1; + } + else + { + $obj->validateInputFilenames(@inputs) + or return undef; + $_[0] = [ @inputs ] ; + $data{inType} = 'filenames' ; + } + } + elsif ($inType eq 'filename') + { + $obj->validateInputFilenames($_[0]) + or return undef; + } + elsif ($inType eq 'array') + { + $data{inType} = 'filenames' ; + $obj->validateInputArray($_[0]) + or return undef ; + } + + return $obj->saveErrorString("$reportClass: output buffer is read-only") + if $outType eq 'buffer' && readonly(${ $_[1] }); + + if ($outType eq 'filename' ) + { + $obj->croakError("$reportClass: output filename is undef or null string") + if ! defined $_[1] || $_[1] eq '' ; + + if (-e $_[1]) + { + if (-d _ ) + { + return $obj->saveErrorString("output file '$_[1]' is a directory"); + } + } + } + + return $obj ; +} + +sub IO::Compress::Base::Validator::saveErrorString +{ + my $self = shift ; + ${ $self->{Error} } = shift ; + return undef; + +} + +sub IO::Compress::Base::Validator::croakError +{ + my $self = shift ; + $self->saveErrorString($_[0]); + croak $_[0]; +} + + + +sub IO::Compress::Base::Validator::validateInputFilenames +{ + my $self = shift ; + + foreach my $filename (@_) + { + $self->croakError("$self->{reportClass}: input filename is undef or null string") + if ! defined $filename || $filename eq '' ; + + next if $filename eq '-'; + + if (! -e $filename ) + { + return $self->saveErrorString("input file '$filename' does not exist"); + } + + if (-d _ ) + { + return $self->saveErrorString("input file '$filename' is a directory"); + } + +# if (! -r _ ) +# { +# return $self->saveErrorString("cannot open file '$filename': $!"); +# } + } + + return 1 ; +} + +sub IO::Compress::Base::Validator::validateInputArray +{ + my $self = shift ; + + if ( @{ $_[0] } == 0 ) + { + return $self->saveErrorString("empty array reference") ; + } + + foreach my $element ( @{ $_[0] } ) + { + my $inType = whatIsInput($element); + + if (! $inType) + { + $self->croakError("unknown input parameter") ; + } + elsif($inType eq 'filename') + { + $self->validateInputFilenames($element) + or return undef ; + } + else + { + $self->croakError("not a filename") ; + } + } + + return 1 ; +} + +#sub IO::Compress::Base::Validator::validateHash +#{ +# my $self = shift ; +# my $href = shift ; +# +# while (my($k, $v) = each %$href) +# { +# my $ktype = whatIsInput($k); +# my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ; +# +# if ($ktype ne 'filename') +# { +# return $self->saveErrorString("hash key not filename") ; +# } +# +# my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ; +# if (! $valid{$vtype}) +# { +# return $self->saveErrorString("hash value not ok") ; +# } +# } +# +# return $self ; +#} + +sub createSelfTiedObject +{ + my $class = shift || (caller)[0] ; + my $error_ref = shift ; + + my $obj = bless Symbol::gensym(), ref($class) || $class; + tie *$obj, $obj if $] >= 5.005; + *$obj->{Closed} = 1 ; + $$error_ref = ''; + *$obj->{Error} = $error_ref ; + my $errno = 0 ; + *$obj->{ErrorNo} = \$errno ; + + return $obj; +} + + + +#package Parse::Parameters ; +# +# +#require Exporter; +#our ($VERSION, @ISA, @EXPORT); +#$VERSION = '2.000_08'; +#@ISA = qw(Exporter); + +$EXPORT_TAGS{Parse} = [qw( ParseParameters + Parse_any Parse_unsigned Parse_signed + Parse_boolean Parse_string + Parse_code + Parse_writable_scalar + ) + ]; + +push @EXPORT, @{ $EXPORT_TAGS{Parse} } ; + +use constant Parse_any => 0x01; +use constant Parse_unsigned => 0x02; +use constant Parse_signed => 0x04; +use constant Parse_boolean => 0x08; +use constant Parse_string => 0x10; +use constant Parse_code => 0x20; + +#use constant Parse_store_ref => 0x100 ; +#use constant Parse_multiple => 0x100 ; +use constant Parse_writable => 0x200 ; +use constant Parse_writable_scalar => 0x400 | Parse_writable ; + +use constant OFF_PARSED => 0 ; +use constant OFF_TYPE => 1 ; +use constant OFF_DEFAULT => 2 ; +use constant OFF_FIXED => 3 ; +#use constant OFF_FIRST_ONLY => 4 ; +#use constant OFF_STICKY => 5 ; + +use constant IxError => 0; +use constant IxGot => 1 ; + +sub ParseParameters +{ + my $level = shift || 0 ; + + my $sub = (caller($level + 1))[3] ; + local $Carp::CarpLevel = 1 ; + + return $_[1] + if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters"); + + my $p = new IO::Compress::Base::Parameters() ; + $p->parse(@_) + or croak "$sub: $p->[IxError]" ; + + return $p; +} + + +use strict; + +use warnings; +use Carp; + + +sub Init +{ + my $default = shift ; + my %got ; + + my $obj = IO::Compress::Base::Parameters::new(); + while (my ($key, $v) = each %$default) + { + croak "need 2 params [@$v]" + if @$v != 2 ; + + my ($type, $value) = @$v ; +# my ($first_only, $sticky, $type, $value) = @$v ; + my $sticky = 0; + my $x ; + $obj->_checkType($key, \$value, $type, 0, \$x) + or return undef ; + + $key = lc $key; + +# if (! $sticky) { +# $x = [] +# if $type & Parse_multiple; + +# $got{$key} = [0, $type, $value, $x, $first_only, $sticky] ; + $got{$key} = [0, $type, $value, $x] ; +# } +# +# $got{$key}[OFF_PARSED] = 0 ; + } + + return bless \%got, "IO::Compress::Base::Parameters::Defaults" ; +} + +sub IO::Compress::Base::Parameters::new +{ + #my $class = shift ; + + my $obj; + $obj->[IxError] = ''; + $obj->[IxGot] = {} ; + + return bless $obj, 'IO::Compress::Base::Parameters' ; +} + +sub IO::Compress::Base::Parameters::setError +{ + my $self = shift ; + my $error = shift ; + my $retval = @_ ? shift : undef ; + + + $self->[IxError] = $error ; + return $retval; +} + +sub IO::Compress::Base::Parameters::getError +{ + my $self = shift ; + return $self->[IxError] ; +} + +sub IO::Compress::Base::Parameters::parse +{ + my $self = shift ; + my $default = shift ; + + my $got = $self->[IxGot] ; + my $firstTime = keys %{ $got } == 0 ; + + my (@Bad) ; + my @entered = () ; + + # Allow the options to be passed as a hash reference or + # as the complete hash. + if (@_ == 0) { + @entered = () ; + } + elsif (@_ == 1) { + my $href = $_[0] ; + + return $self->setError("Expected even number of parameters, got 1") + if ! defined $href or ! ref $href or ref $href ne "HASH" ; + + foreach my $key (keys %$href) { + push @entered, $key ; + push @entered, \$href->{$key} ; + } + } + else { + + my $count = @_; + return $self->setError("Expected even number of parameters, got $count") + if $count % 2 != 0 ; + + for my $i (0.. $count / 2 - 1) { + push @entered, $_[2 * $i] ; + push @entered, \$_[2 * $i + 1] ; + } + } + + foreach my $key (keys %$default) + { + + my ($type, $value) = @{ $default->{$key} } ; + + if ($firstTime) { + $got->{$key} = [0, $type, $value, $value] ; + } + else + { + $got->{$key}[OFF_PARSED] = 0 ; + } + } + + + my %parsed = (); + + + for my $i (0.. @entered / 2 - 1) { + my $key = $entered[2* $i] ; + my $value = $entered[2* $i+1] ; + + #print "Key [$key] Value [$value]" ; + #print defined $$value ? "[$$value]\n" : "[undef]\n"; + + $key =~ s/^-// ; + my $canonkey = lc $key; + + if ($got->{$canonkey}) + { + my $type = $got->{$canonkey}[OFF_TYPE] ; + my $parsed = $parsed{$canonkey}; + ++ $parsed{$canonkey}; + + return $self->setError("Muliple instances of '$key' found") + if $parsed ; + + my $s ; + $self->_checkType($key, $value, $type, 1, \$s) + or return undef ; + + $value = $$value ; + $got->{$canonkey} = [1, $type, $value, $s] ; + + } + else + { push (@Bad, $key) } + } + + if (@Bad) { + my ($bad) = join(", ", @Bad) ; + return $self->setError("unknown key value(s) $bad") ; + } + + return 1; +} + +sub IO::Compress::Base::Parameters::_checkType +{ + my $self = shift ; + + my $key = shift ; + my $value = shift ; + my $type = shift ; + my $validate = shift ; + my $output = shift; + + #local $Carp::CarpLevel = $level ; + #print "PARSE $type $key $value $validate $sub\n" ; + + if ($type & Parse_writable_scalar) + { + return $self->setError("Parameter '$key' not writable") + if readonly $$value ; + + if (ref $$value) + { + return $self->setError("Parameter '$key' not a scalar reference") + if ref $$value ne 'SCALAR' ; + + $$output = $$value ; + } + else + { + return $self->setError("Parameter '$key' not a scalar") + if ref $value ne 'SCALAR' ; + + $$output = $value ; + } + + return 1; + } + + + $value = $$value ; + + if ($type & Parse_any) + { + $$output = $value ; + return 1; + } + elsif ($type & Parse_unsigned) + { + + return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'") + if ! defined $value ; + return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") + if $value !~ /^\d+$/; + + $$output = defined $value ? $value : 0 ; + return 1; + } + elsif ($type & Parse_signed) + { + return $self->setError("Parameter '$key' must be a signed int, got 'undef'") + if ! defined $value ; + return $self->setError("Parameter '$key' must be a signed int, got '$value'") + if $value !~ /^-?\d+$/; + + $$output = defined $value ? $value : 0 ; + return 1 ; + } + elsif ($type & Parse_boolean) + { + return $self->setError("Parameter '$key' must be an int, got '$value'") + if defined $value && $value !~ /^\d*$/; + + $$output = defined $value && $value != 0 ? 1 : 0 ; + return 1; + } + + elsif ($type & Parse_string) + { + $$output = defined $value ? $value : "" ; + return 1; + } + elsif ($type & Parse_code) + { + return $self->setError("Parameter '$key' must be a code reference, got '$value'") + if (! defined $value || ref $value ne 'CODE') ; + + $$output = defined $value ? $value : "" ; + return 1; + } + + $$output = $value ; + return 1; +} + +sub IO::Compress::Base::Parameters::parsed +{ + return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ; +} + + +sub IO::Compress::Base::Parameters::getValue +{ + return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ; +} +sub IO::Compress::Base::Parameters::setValue +{ + $_[0]->[IxGot]{$_[1]}[OFF_PARSED] = 1; + $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] = $_[2] ; + $_[0]->[IxGot]{$_[1]}[OFF_FIXED] = $_[2] ; +} + +sub IO::Compress::Base::Parameters::valueRef +{ + return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ; +} + +sub IO::Compress::Base::Parameters::valueOrDefault +{ + my $self = shift ; + my $name = shift ; + my $default = shift ; + + my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ; + + return $value if defined $value ; + return $default ; +} + +sub IO::Compress::Base::Parameters::wantValue +{ + return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ; +} + +sub IO::Compress::Base::Parameters::clone +{ + my $self = shift ; + my $obj = [] ; + my %got ; + + my $hash = $self->[IxGot] ; + for my $k (keys %{ $hash }) + { + $got{$k} = [ @{ $hash->{$k} } ]; + } + + $obj->[IxError] = $self->[IxError]; + $obj->[IxGot] = \%got ; + + return bless $obj, 'IO::Compress::Base::Parameters' ; +} + +package U64; + +use constant MAX32 => 0xFFFFFFFF ; +use constant HI_1 => MAX32 + 1 ; +use constant LOW => 0 ; +use constant HIGH => 1; + +sub new +{ + return bless [ 0, 0 ], $_[0] + if @_ == 1 ; + + return bless [ $_[1], 0 ], $_[0] + if @_ == 2 ; + + return bless [ $_[2], $_[1] ], $_[0] + if @_ == 3 ; +} + +sub newUnpack_V64 +{ + my ($low, $hi) = unpack "V V", $_[0] ; + bless [ $low, $hi ], "U64"; +} + +sub newUnpack_V32 +{ + my $string = shift; + + my $low = unpack "V", $string ; + bless [ $low, 0 ], "U64"; +} + +sub reset +{ + $_[0]->[HIGH] = $_[0]->[LOW] = 0; +} + +sub clone +{ + bless [ @{$_[0]} ], ref $_[0] ; +} + +sub getHigh +{ + return $_[0]->[HIGH]; +} + +sub getLow +{ + return $_[0]->[LOW]; +} + +sub get32bit +{ + return $_[0]->[LOW]; +} + +sub get64bit +{ + # Not using << here because the result will still be + # a 32-bit value on systems where int size is 32-bits + return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW]; +} + +sub add +{ +# my $self = shift; + my $value = $_[1]; + + if (ref $value eq 'U64') { + $_[0]->[HIGH] += $value->[HIGH] ; + $value = $value->[LOW]; + } + elsif ($value > MAX32) { + $_[0]->[HIGH] += int($value / HI_1) ; + $value = $value % HI_1; + } + + my $available = MAX32 - $_[0]->[LOW] ; + + if ($value > $available) { + ++ $_[0]->[HIGH] ; + $_[0]->[LOW] = $value - $available - 1; + } + else { + $_[0]->[LOW] += $value ; + } +} + +sub add32 +{ +# my $self = shift; + my $value = $_[1]; + + if ($value > MAX32) { + $_[0]->[HIGH] += int($value / HI_1) ; + $value = $value % HI_1; + } + + my $available = MAX32 - $_[0]->[LOW] ; + + if ($value > $available) { + ++ $_[0]->[HIGH] ; + $_[0]->[LOW] = $value - $available - 1; + } + else { + $_[0]->[LOW] += $value ; + } +} + +sub subtract +{ + my $self = shift; + my $value = shift; + + if (ref $value eq 'U64') { + + if ($value->[HIGH]) { + die "bad" + if $self->[HIGH] == 0 || + $value->[HIGH] > $self->[HIGH] ; + + $self->[HIGH] -= $value->[HIGH] ; + } + + $value = $value->[LOW] ; + } + + if ($value > $self->[LOW]) { + -- $self->[HIGH] ; + $self->[LOW] = MAX32 - $value + $self->[LOW] + 1 ; + } + else { + $self->[LOW] -= $value; + } +} + +sub equal +{ + my $self = shift; + my $other = shift; + + return $self->[LOW] == $other->[LOW] && + $self->[HIGH] == $other->[HIGH] ; +} + +sub gt +{ + my $self = shift; + my $other = shift; + + return $self->cmp($other) > 0 ; +} + +sub cmp +{ + my $self = shift; + my $other = shift ; + + if ($self->[LOW] == $other->[LOW]) { + return $self->[HIGH] - $other->[HIGH] ; + } + else { + return $self->[LOW] - $other->[LOW] ; + } +} + + +sub is64bit +{ + return $_[0]->[HIGH] > 0 ; +} + +sub isAlmost64bit +{ + return $_[0]->[HIGH] > 0 || $_[0]->[LOW] == MAX32 ; +} + +sub getPacked_V64 +{ + return pack "V V", @{ $_[0] } ; +} + +sub getPacked_V32 +{ + return pack "V", $_[0]->[LOW] ; +} + +sub pack_V64 +{ + return pack "V V", $_[0], 0; +} + + +sub full32 +{ + return $_[0] == MAX32 ; +} + +sub Value_VV64 +{ + my $buffer = shift; + + my ($lo, $hi) = unpack ("V V" , $buffer); + no warnings 'uninitialized'; + return $hi * HI_1 + $lo; +} + + +package IO::Compress::Base::Common; + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm new file mode 100644 index 0000000000..5fa5f584d2 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm @@ -0,0 +1,805 @@ +package IO::Compress::Bzip2 ; + +use strict ; +use warnings; +use bytes; +require Exporter ; + +use IO::Compress::Base 2.074 ; + +use IO::Compress::Base::Common 2.074 qw(); +use IO::Compress::Adapter::Bzip2 2.074 ; + + + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error); + +$VERSION = '2.074'; +$Bzip2Error = ''; + +@ISA = qw(IO::Compress::Base Exporter); +@EXPORT_OK = qw( $Bzip2Error bzip2 ) ; +%EXPORT_TAGS = %IO::Compress::Base::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + + +sub new +{ + my $class = shift ; + + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$Bzip2Error); + return $obj->_create(undef, @_); +} + +sub bzip2 +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$Bzip2Error); + $obj->_def(@_); +} + + +sub mkHeader +{ + my $self = shift ; + return ''; + +} + +sub getExtraParams +{ + my $self = shift ; + + use IO::Compress::Base::Common 2.074 qw(:Parse); + + return ( + 'blocksize100k' => [IO::Compress::Base::Common::Parse_unsigned, 1], + 'workfactor' => [IO::Compress::Base::Common::Parse_unsigned, 0], + 'verbosity' => [IO::Compress::Base::Common::Parse_boolean, 0], + ); +} + + + +sub ckParams +{ + my $self = shift ; + my $got = shift; + + # check that BlockSize100K is a number between 1 & 9 + if ($got->parsed('blocksize100k')) { + my $value = $got->getValue('blocksize100k'); + return $self->saveErrorString(undef, "Parameter 'BlockSize100K' not between 1 and 9, got $value") + unless defined $value && $value >= 1 && $value <= 9; + + } + + # check that WorkFactor between 0 & 250 + if ($got->parsed('workfactor')) { + my $value = $got->getValue('workfactor'); + return $self->saveErrorString(undef, "Parameter 'WorkFactor' not between 0 and 250, got $value") + unless $value >= 0 && $value <= 250; + } + + return 1 ; +} + + +sub mkComp +{ + my $self = shift ; + my $got = shift ; + + my $BlockSize100K = $got->getValue('blocksize100k'); + my $WorkFactor = $got->getValue('workfactor'); + my $Verbosity = $got->getValue('verbosity'); + + my ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject( + $BlockSize100K, $WorkFactor, + $Verbosity); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + return $obj; +} + + +sub mkTrailer +{ + my $self = shift ; + return ''; +} + +sub mkFinalTrailer +{ + return ''; +} + +#sub newHeader +#{ +# my $self = shift ; +# return ''; +#} + +sub getInverseClass +{ + return ('IO::Uncompress::Bunzip2'); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $file = shift ; + +} + +1; + +__END__ + +=head1 NAME + +IO::Compress::Bzip2 - Write bzip2 files/buffers + + + +=head1 SYNOPSIS + + use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; + + my $status = bzip2 $input => $output [,OPTS] + or die "bzip2 failed: $Bzip2Error\n"; + + my $z = new IO::Compress::Bzip2 $output [,OPTS] + or die "bzip2 failed: $Bzip2Error\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->close() ; + + $Bzip2Error ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + +This module provides a Perl interface that allows writing bzip2 +compressed data to files or buffer. + +For reading bzip2 files/buffers, see the companion module +L<IO::Uncompress::Bunzip2|IO::Uncompress::Bunzip2>. + +=head1 Functional Interface + +A top-level function, C<bzip2>, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L</"OO Interface"> +section. + + use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; + + bzip2 $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "bzip2 failed: $Bzip2Error\n"; + +The functional interface needs Perl5.005 or better. + +=head2 bzip2 $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<bzip2> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<bzip2> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the compressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +compressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +compressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +compressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the compressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<bzip2> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple files/buffers and +C<$output_filename_or_reference> is a single +file/buffer the input files/buffers will be stored +in C<$output_filename_or_reference> as a concatenated series of compressed data streams. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<bzip2>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<bzip2> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<bzip2> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all compressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +compressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any compressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any compressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all compressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any compressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all compressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any compressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any compressed data is output. + +Defaults to 0. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.bz2>. + + use strict ; + use warnings ; + use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; + + my $input = "file1.txt"; + bzip2 $input => "$input.bz2" + or die "bzip2 failed: $Bzip2Error\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + bzip2 $input => \$buffer + or die "bzip2 failed: $Bzip2Error\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; + + bzip2 '</my/home/*.txt>' => '<*.bz2>' + or die "bzip2 failed: $Bzip2Error\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.bz2" ; + bzip2 $input => $output + or die "Error compressing '$input': $Bzip2Error\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::Bzip2> is shown below + + my $z = new IO::Compress::Bzip2 $output [,OPTS] + or die "IO::Compress::Bzip2 failed: $Bzip2Error\n"; + +It returns an C<IO::Compress::Bzip2> object on success and undef on failure. +The variable C<$Bzip2Error> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Bzip2 can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::Bzip2>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C<close> method is called or the C<IO::Compress::Bzip2> +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data +will be append to the end of C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C<seek> before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + +=item C<< BlockSize100K => number >> + +Specify the number of 100K blocks bzip2 uses during compression. + +Valid values are from 1 to 9, where 9 is best compression. + +The default is 1. + +=item C<< WorkFactor => number >> + +Specifies how much effort bzip2 should take before resorting to a slower +fallback compression algorithm. + +Valid values range from 0 to 250, where 0 means use the default value 30. + +The default is 0. + +=item C<< Strict => 0|1 >> + +This is a placeholder option. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + $z->flush; + +Flushes any pending compressed data to the output file/buffer. + +TODO + +Returns true on success. + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the C<close> method has been called. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +This method always returns C<undef> when compressing. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Flushes any pending compressed data and then closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Bzip2 object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::Bzip2 +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the options that are available when creating +the C<$z> object. + +See the L</"Constructor Options"> section for more details. + +=head1 Importing + +No symbolic constants are required by this IO::Compress::Bzip2 at present. + +=over 5 + +=item :all + +Imports C<bzip2> and C<$Bzip2Error>. +Same as doing this + + use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; + + + +=back + +=head1 EXAMPLES + +=head2 Apache::GZip Revisited + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +The primary site for the bzip2 program is L<http://www.bzip.org>. + +See the module L<Compress::Bzip2|Compress::Bzip2> + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Deflate.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Deflate.pm new file mode 100644 index 0000000000..379ad9cd73 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Deflate.pm @@ -0,0 +1,939 @@ +package IO::Compress::Deflate ; + +require 5.006 ; + +use strict ; +use warnings; +use bytes; + +require Exporter ; + +use IO::Compress::RawDeflate 2.074 (); +use IO::Compress::Adapter::Deflate 2.074 ; + +use IO::Compress::Zlib::Constants 2.074 ; +use IO::Compress::Base::Common 2.074 qw(); + + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $DeflateError); + +$VERSION = '2.074'; +$DeflateError = ''; + +@ISA = qw(IO::Compress::RawDeflate Exporter); +@EXPORT_OK = qw( $DeflateError deflate ) ; +%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ; + +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + +sub new +{ + my $class = shift ; + + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$DeflateError); + return $obj->_create(undef, @_); +} + +sub deflate +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$DeflateError); + return $obj->_def(@_); +} + + +sub bitmask($$$$) +{ + my $into = shift ; + my $value = shift ; + my $offset = shift ; + my $mask = shift ; + + return $into | (($value & $mask) << $offset ) ; +} + +sub mkDeflateHdr($$$;$) +{ + my $method = shift ; + my $cinfo = shift; + my $level = shift; + my $fdict_adler = shift ; + + my $cmf = 0; + my $flg = 0; + my $fdict = 0; + $fdict = 1 if defined $fdict_adler; + + $cmf = bitmask($cmf, $method, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS); + $cmf = bitmask($cmf, $cinfo, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS); + + $flg = bitmask($flg, $fdict, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS); + $flg = bitmask($flg, $level, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS); + + my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ; + $flg = bitmask($flg, $fcheck, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS); + + my $hdr = pack("CC", $cmf, $flg) ; + $hdr .= pack("N", $fdict_adler) if $fdict ; + + return $hdr; +} + +sub mkHeader +{ + my $self = shift ; + my $param = shift ; + + my $level = $param->getValue('level'); + my $strategy = $param->getValue('strategy'); + + my $lflag ; + $level = 6 + if $level == Z_DEFAULT_COMPRESSION ; + + if (ZLIB_VERNUM >= 0x1210) + { + if ($strategy >= Z_HUFFMAN_ONLY || $level < 2) + { $lflag = ZLIB_FLG_LEVEL_FASTEST } + elsif ($level < 6) + { $lflag = ZLIB_FLG_LEVEL_FAST } + elsif ($level == 6) + { $lflag = ZLIB_FLG_LEVEL_DEFAULT } + else + { $lflag = ZLIB_FLG_LEVEL_SLOWEST } + } + else + { + $lflag = ($level - 1) >> 1 ; + $lflag = 3 if $lflag > 3 ; + } + + #my $wbits = (MAX_WBITS - 8) << 4 ; + my $wbits = 7; + mkDeflateHdr(ZLIB_CMF_CM_DEFLATED, $wbits, $lflag); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift; + + $got->setValue('adler32' => 1); + return 1 ; +} + + +sub mkTrailer +{ + my $self = shift ; + return pack("N", *$self->{Compress}->adler32()) ; +} + +sub mkFinalTrailer +{ + return ''; +} + +#sub newHeader +#{ +# my $self = shift ; +# return *$self->{Header}; +#} + +sub getExtraParams +{ + my $self = shift ; + return $self->getZlibParams(), +} + +sub getInverseClass +{ + return ('IO::Uncompress::Inflate', + \$IO::Uncompress::Inflate::InflateError); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $file = shift ; + +} + + + +1; + +__END__ + +=head1 NAME + +IO::Compress::Deflate - Write RFC 1950 files/buffers + + + +=head1 SYNOPSIS + + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + my $status = deflate $input => $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + my $z = new IO::Compress::Deflate $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->deflateParams(); + + $z->close() ; + + $DeflateError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1950. + +For reading RFC 1950 files/buffers, see the companion module +L<IO::Uncompress::Inflate|IO::Uncompress::Inflate>. + +=head1 Functional Interface + +A top-level function, C<deflate>, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L</"OO Interface"> +section. + + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + deflate $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "deflate failed: $DeflateError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 deflate $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<deflate> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<deflate> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the compressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +compressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +compressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +compressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the compressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<deflate> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple files/buffers and +C<$output_filename_or_reference> is a single +file/buffer the input files/buffers will be stored +in C<$output_filename_or_reference> as a concatenated series of compressed data streams. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<deflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<deflate> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<deflate> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all compressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +compressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any compressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any compressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all compressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any compressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all compressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any compressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any compressed data is output. + +Defaults to 0. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.1950>. + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + my $input = "file1.txt"; + deflate $input => "$input.1950" + or die "deflate failed: $DeflateError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + deflate $input => \$buffer + or die "deflate failed: $DeflateError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + deflate '</my/home/*.txt>' => '<*.1950>' + or die "deflate failed: $DeflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Deflate qw(deflate $DeflateError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.1950" ; + deflate $input => $output + or die "Error compressing '$input': $DeflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::Deflate> is shown below + + my $z = new IO::Compress::Deflate $output [,OPTS] + or die "IO::Compress::Deflate failed: $DeflateError\n"; + +It returns an C<IO::Compress::Deflate> object on success and undef on failure. +The variable C<$DeflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Deflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::Deflate>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C<close> method is called or the C<IO::Compress::Deflate> +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data +will be append to the end of C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C<seek> before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + +=item C<< Merge => 0|1 >> + +This option is used to compress input data and append it to an existing +compressed data stream in C<$output>. The end result is a single compressed +data stream stored in C<$output>. + +It is a fatal error to attempt to use this option when C<$output> is not an +RFC 1950 data stream. + +There are a number of other limitations with the C<Merge> option: + +=over 5 + +=item 1 + +This module needs to have been built with zlib 1.2.1 or better to work. A +fatal error will be thrown if C<Merge> is used with an older version of +zlib. + +=item 2 + +If C<$output> is a file or a filehandle, it must be seekable. + +=back + +This parameter defaults to 0. + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::Deflate> by default. + + use IO::Compress::Deflate qw(:strategy); + use IO::Compress::Deflate qw(:constants); + use IO::Compress::Deflate qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + +=item C<< Strict => 0|1 >> + +This is a placeholder option. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + $z->flush; + $z->flush($flush_type); + +Flushes any pending compressed data to the output file/buffer. + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + +Returns true on success. + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the C<close> method has been called. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +This method always returns C<undef> when compressing. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Flushes any pending compressed data and then closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Deflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::Deflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the options that are available when creating +the C<$z> object. + +See the L</"Constructor Options"> section for more details. + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + +=head1 Importing + +A number of symbolic constants are required by some methods in +C<IO::Compress::Deflate>. None are imported by default. + +=over 5 + +=item :all + +Imports C<deflate>, C<$DeflateError> and all symbolic +constants that can be used by C<IO::Compress::Deflate>. Same as doing this + + use IO::Compress::Deflate qw(deflate $DeflateError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + use IO::Compress::Deflate qw(:flush :level :strategy) ; + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + + + + +=back + +=head1 EXAMPLES + +=head2 Apache::GZip Revisited + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +L<http://www.faqs.org/rfcs/rfc1950.html>, +L<http://www.faqs.org/rfcs/rfc1951.html> and +L<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +L<http://www.zlib.org>. + +The primary site for gzip is L<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/FAQ.pod b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/FAQ.pod new file mode 100644 index 0000000000..7099418443 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/FAQ.pod @@ -0,0 +1,683 @@ + +=head1 NAME + +IO::Compress::FAQ -- Frequently Asked Questions about IO::Compress + +=head1 DESCRIPTION + +Common questions answered. + +=head1 GENERAL + +=head2 Compatibility with Unix compress/uncompress. + +Although C<Compress::Zlib> has a pair of functions called C<compress> and +C<uncompress>, they are I<not> related to the Unix programs of the same +name. The C<Compress::Zlib> module is not compatible with Unix +C<compress>. + +If you have the C<uncompress> program available, you can use this to read +compressed files + + open F, "uncompress -c $filename |"; + while (<F>) + { + ... + +Alternatively, if you have the C<gunzip> program available, you can use +this to read compressed files + + open F, "gunzip -c $filename |"; + while (<F>) + { + ... + +and this to write compress files, if you have the C<compress> program +available + + open F, "| compress -c $filename "; + print F "data"; + ... + close F ; + +=head2 Accessing .tar.Z files + +The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via the +C<IO::Zlib> module) to access tar files that have been compressed with +C<gzip>. Unfortunately tar files compressed with the Unix C<compress> +utility cannot be read by C<Compress::Zlib> and so cannot be directly +accessed by C<Archive::Tar>. + +If the C<uncompress> or C<gunzip> programs are available, you can use one +of these workarounds to read C<.tar.Z> files from C<Archive::Tar> + +Firstly with C<uncompress> + + use strict; + use warnings; + use Archive::Tar; + + open F, "uncompress -c $filename |"; + my $tar = Archive::Tar->new(*F); + ... + +and this with C<gunzip> + + use strict; + use warnings; + use Archive::Tar; + + open F, "gunzip -c $filename |"; + my $tar = Archive::Tar->new(*F); + ... + +Similarly, if the C<compress> program is available, you can use this to +write a C<.tar.Z> file + + use strict; + use warnings; + use Archive::Tar; + use IO::File; + + my $fh = new IO::File "| compress -c >$filename"; + my $tar = Archive::Tar->new(); + ... + $tar->write($fh); + $fh->close ; + +=head2 How do I recompress using a different compression? + +This is easier that you might expect if you realise that all the +C<IO::Compress::*> objects are derived from C<IO::File> and that all the +C<IO::Uncompress::*> modules can read from an C<IO::File> filehandle. + +So, for example, say you have a file compressed with gzip that you want to +recompress with bzip2. Here is all that is needed to carry out the +recompression. + + use IO::Uncompress::Gunzip ':all'; + use IO::Compress::Bzip2 ':all'; + + my $gzipFile = "somefile.gz"; + my $bzipFile = "somefile.bz2"; + + my $gunzip = new IO::Uncompress::Gunzip $gzipFile + or die "Cannot gunzip $gzipFile: $GunzipError\n" ; + + bzip2 $gunzip => $bzipFile + or die "Cannot bzip2 to $bzipFile: $Bzip2Error\n" ; + +Note, there is a limitation of this technique. Some compression file +formats store extra information along with the compressed data payload. For +example, gzip can optionally store the original filename and Zip stores a +lot of information about the original file. If the original compressed file +contains any of this extra information, it will not be transferred to the +new compressed file using the technique above. + +=head1 ZIP + +=head2 What Compression Types do IO::Compress::Zip & IO::Uncompress::Unzip support? + +The following compression formats are supported by C<IO::Compress::Zip> and +C<IO::Uncompress::Unzip> + +=over 5 + +=item * Store (method 0) + +No compression at all. + +=item * Deflate (method 8) + +This is the default compression used when creating a zip file with +C<IO::Compress::Zip>. + +=item * Bzip2 (method 12) + +Only supported if the C<IO-Compress-Bzip2> module is installed. + +=item * Lzma (method 14) + +Only supported if the C<IO-Compress-Lzma> module is installed. + +=back + +=head2 Can I Read/Write Zip files larger the 4 Gig? + +Yes, both the C<IO-Compress-Zip> and C<IO-Uncompress-Unzip> modules +support the zip feature called I<Zip64>. That allows them to read/write +files/buffers larger than 4Gig. + +If you are creating a Zip file using the one-shot interface, and any of the +input files is greater than 4Gig, a zip64 complaint zip file will be +created. + + zip "really-large-file" => "my.zip"; + +Similarly with the one-shot interface, if the input is a buffer larger than +4 Gig, a zip64 complaint zip file will be created. + + zip \$really_large_buffer => "my.zip"; + +The one-shot interface allows you to force the creation of a zip64 zip file +by including the C<Zip64> option. + + zip $filehandle => "my.zip", Zip64 => 1; + +If you want to create a zip64 zip file with the OO interface you must +specify the C<Zip64> option. + + my $zip = new IO::Compress::Zip "whatever", Zip64 => 1; + +When uncompressing with C<IO-Uncompress-Unzip>, it will automatically +detect if the zip file is zip64. + +If you intend to manipulate the Zip64 zip files created with +C<IO-Compress-Zip> using an external zip/unzip, make sure that it supports +Zip64. + +In particular, if you are using Info-Zip you need to have zip version 3.x +or better to update a Zip64 archive and unzip version 6.x to read a zip64 +archive. + +=head2 Can I write more that 64K entries is a Zip files? + +Yes. Zip64 allows this. See previous question. + +=head2 Zip Resources + +The primary reference for zip files is the "appnote" document available at +L<http://www.pkware.com/documents/casestudies/APPNOTE.TXT> + +An alternatively is the Info-Zip appnote. This is available from +L<ftp://ftp.info-zip.org/pub/infozip/doc/> + +=head1 GZIP + +=head2 Gzip Resources + +The primary reference for gzip files is RFC 1952 +L<http://www.faqs.org/rfcs/rfc1952.html> + +The primary site for gzip is L<http://www.gzip.org>. + +=head2 Dealing with concatenated gzip files + +If the gunzip program encounters a file containing multiple gzip files +concatenated together it will automatically uncompress them all. +The example below illustrates this behaviour + + $ echo abc | gzip -c >x.gz + $ echo def | gzip -c >>x.gz + $ gunzip -c x.gz + abc + def + +By default C<IO::Uncompress::Gunzip> will I<not> behave like the gunzip +program. It will only uncompress the first gzip data stream in the file, as +shown below + + $ perl -MIO::Uncompress::Gunzip=:all -e 'gunzip "x.gz" => \*STDOUT' + abc + +To force C<IO::Uncompress::Gunzip> to uncompress all the gzip data streams, +include the C<MultiStream> option, as shown below + + $ perl -MIO::Uncompress::Gunzip=:all -e 'gunzip "x.gz" => \*STDOUT, MultiStream => 1' + abc + def + +=head2 Reading bgzip files with IO::Uncompress::Gunzip + +A C<bgzip> file consists of a series of valid gzip-compliant data streams +concatenated together. To read a file created by C<bgzip> with +C<IO::Uncompress::Gunzip> use the C<MultiStream> option as shown in the +previous section. + +See the section titled "The BGZF compression format" in +L<http://samtools.github.io/hts-specs/SAMv1.pdf> for a definition of +C<bgzip>. + +=head1 ZLIB + +=head2 Zlib Resources + +The primary site for the I<zlib> compression library is +L<http://www.zlib.org>. + +=head1 Bzip2 + +=head2 Bzip2 Resources + +The primary site for bzip2 is L<http://www.bzip.org>. + +=head2 Dealing with Concatenated bzip2 files + +If the bunzip2 program encounters a file containing multiple bzip2 files +concatenated together it will automatically uncompress them all. +The example below illustrates this behaviour + + $ echo abc | bzip2 -c >x.bz2 + $ echo def | bzip2 -c >>x.bz2 + $ bunzip2 -c x.bz2 + abc + def + +By default C<IO::Uncompress::Bunzip2> will I<not> behave like the bunzip2 +program. It will only uncompress the first bunzip2 data stream in the file, as +shown below + + $ perl -MIO::Uncompress::Bunzip2=:all -e 'bunzip2 "x.bz2" => \*STDOUT' + abc + +To force C<IO::Uncompress::Bunzip2> to uncompress all the bzip2 data streams, +include the C<MultiStream> option, as shown below + + $ perl -MIO::Uncompress::Bunzip2=:all -e 'bunzip2 "x.bz2" => \*STDOUT, MultiStream => 1' + abc + def + +=head2 Interoperating with Pbzip2 + +Pbzip2 (L<http://compression.ca/pbzip2/>) is a parallel implementation of +bzip2. The output from pbzip2 consists of a series of concatenated bzip2 +data streams. + +By default C<IO::Uncompress::Bzip2> will only uncompress the first bzip2 +data stream in a pbzip2 file. To uncompress the complete pbzip2 file you +must include the C<MultiStream> option, like this. + + bunzip2 $input => \$output, MultiStream => 1 + or die "bunzip2 failed: $Bunzip2Error\n"; + +=head1 HTTP & NETWORK + +=head2 Apache::GZip Revisited + +Below is a mod_perl Apache compression module, called C<Apache::GZip>, +taken from +L<http://perl.apache.org/docs/tutorials/tips/mod_perl_tricks/mod_perl_tricks.html#On_the_Fly_Compression> + + package Apache::GZip; + #File: Apache::GZip.pm + + use strict vars; + use Apache::Constants ':common'; + use Compress::Zlib; + use IO::File; + use constant GZIP_MAGIC => 0x1f8b; + use constant OS_MAGIC => 0x03; + + sub handler { + my $r = shift; + my ($fh,$gz); + my $file = $r->filename; + return DECLINED unless $fh=IO::File->new($file); + $r->header_out('Content-Encoding'=>'gzip'); + $r->send_http_header; + return OK if $r->header_only; + + tie *STDOUT,'Apache::GZip',$r; + print($_) while <$fh>; + untie *STDOUT; + return OK; + } + + sub TIEHANDLE { + my($class,$r) = @_; + # initialize a deflation stream + my $d = deflateInit(-WindowBits=>-MAX_WBITS()) || return undef; + + # gzip header -- don't ask how I found out + $r->print(pack("nccVcc",GZIP_MAGIC,Z_DEFLATED,0,time(),0,OS_MAGIC)); + + return bless { r => $r, + crc => crc32(undef), + d => $d, + l => 0 + },$class; + } + + sub PRINT { + my $self = shift; + foreach (@_) { + # deflate the data + my $data = $self->{d}->deflate($_); + $self->{r}->print($data); + # keep track of its length and crc + $self->{l} += length($_); + $self->{crc} = crc32($_,$self->{crc}); + } + } + + sub DESTROY { + my $self = shift; + + # flush the output buffers + my $data = $self->{d}->flush; + $self->{r}->print($data); + + # print the CRC and the total length (uncompressed) + $self->{r}->print(pack("LL",@{$self}{qw/crc l/})); + } + + 1; + +Here's the Apache configuration entry you'll need to make use of it. Once +set it will result in everything in the /compressed directory will be +compressed automagically. + + <Location /compressed> + SetHandler perl-script + PerlHandler Apache::GZip + </Location> + +Although at first sight there seems to be quite a lot going on in +C<Apache::GZip>, you could sum up what the code was doing as follows -- +read the contents of the file in C<< $r->filename >>, compress it and write +the compressed data to standard output. That's all. + +This code has to jump through a few hoops to achieve this because + +=over + +=item 1. + +The gzip support in C<Compress::Zlib> version 1.x can only work with a real +filesystem filehandle. The filehandles used by Apache modules are not +associated with the filesystem. + +=item 2. + +That means all the gzip support has to be done by hand - in this case by +creating a tied filehandle to deal with creating the gzip header and +trailer. + +=back + +C<IO::Compress::Gzip> doesn't have that filehandle limitation (this was one +of the reasons for writing it in the first place). So if +C<IO::Compress::Gzip> is used instead of C<Compress::Zlib> the whole tied +filehandle code can be removed. Here is the rewritten code. + + package Apache::GZip; + + use strict vars; + use Apache::Constants ':common'; + use IO::Compress::Gzip; + use IO::File; + + sub handler { + my $r = shift; + my ($fh,$gz); + my $file = $r->filename; + return DECLINED unless $fh=IO::File->new($file); + $r->header_out('Content-Encoding'=>'gzip'); + $r->send_http_header; + return OK if $r->header_only; + + my $gz = new IO::Compress::Gzip '-', Minimal => 1 + or return DECLINED ; + + print $gz $_ while <$fh>; + + return OK; + } + +or even more succinctly, like this, using a one-shot gzip + + package Apache::GZip; + + use strict vars; + use Apache::Constants ':common'; + use IO::Compress::Gzip qw(gzip); + + sub handler { + my $r = shift; + $r->header_out('Content-Encoding'=>'gzip'); + $r->send_http_header; + return OK if $r->header_only; + + gzip $r->filename => '-', Minimal => 1 + or return DECLINED ; + + return OK; + } + + 1; + +The use of one-shot C<gzip> above just reads from C<< $r->filename >> and +writes the compressed data to standard output. + +Note the use of the C<Minimal> option in the code above. When using gzip +for Content-Encoding you should I<always> use this option. In the example +above it will prevent the filename being included in the gzip header and +make the size of the gzip data stream a slight bit smaller. + +=head2 Compressed files and Net::FTP + +The C<Net::FTP> module provides two low-level methods called C<stor> and +C<retr> that both return filehandles. These filehandles can used with the +C<IO::Compress/Uncompress> modules to compress or uncompress files read +from or written to an FTP Server on the fly, without having to create a +temporary file. + +Firstly, here is code that uses C<retr> to uncompressed a file as it is +read from the FTP Server. + + use Net::FTP; + use IO::Uncompress::Gunzip qw(:all); + + my $ftp = new Net::FTP ... + + my $retr_fh = $ftp->retr($compressed_filename); + gunzip $retr_fh => $outFilename, AutoClose => 1 + or die "Cannot uncompress '$compressed_file': $GunzipError\n"; + +and this to compress a file as it is written to the FTP Server + + use Net::FTP; + use IO::Compress::Gzip qw(:all); + + my $stor_fh = $ftp->stor($filename); + gzip "filename" => $stor_fh, AutoClose => 1 + or die "Cannot compress '$filename': $GzipError\n"; + +=head1 MISC + +=head2 Using C<InputLength> to uncompress data embedded in a larger file/buffer. + +A fairly common use-case is where compressed data is embedded in a larger +file/buffer and you want to read both. + +As an example consider the structure of a zip file. This is a well-defined +file format that mixes both compressed and uncompressed sections of data in +a single file. + +For the purposes of this discussion you can think of a zip file as sequence +of compressed data streams, each of which is prefixed by an uncompressed +local header. The local header contains information about the compressed +data stream, including the name of the compressed file and, in particular, +the length of the compressed data stream. + +To illustrate how to use C<InputLength> here is a script that walks a zip +file and prints out how many lines are in each compressed file (if you +intend write code to walking through a zip file for real see +L<IO::Uncompress::Unzip/"Walking through a zip file"> ). Also, although +this example uses the zlib-based compression, the technique can be used by +the other C<IO::Uncompress::*> modules. + + use strict; + use warnings; + + use IO::File; + use IO::Uncompress::RawInflate qw(:all); + + use constant ZIP_LOCAL_HDR_SIG => 0x04034b50; + use constant ZIP_LOCAL_HDR_LENGTH => 30; + + my $file = $ARGV[0] ; + + my $fh = new IO::File "<$file" + or die "Cannot open '$file': $!\n"; + + while (1) + { + my $sig; + my $buffer; + + my $x ; + ($x = $fh->read($buffer, ZIP_LOCAL_HDR_LENGTH)) == ZIP_LOCAL_HDR_LENGTH + or die "Truncated file: $!\n"; + + my $signature = unpack ("V", substr($buffer, 0, 4)); + + last unless $signature == ZIP_LOCAL_HDR_SIG; + + # Read Local Header + my $gpFlag = unpack ("v", substr($buffer, 6, 2)); + my $compressedMethod = unpack ("v", substr($buffer, 8, 2)); + my $compressedLength = unpack ("V", substr($buffer, 18, 4)); + my $uncompressedLength = unpack ("V", substr($buffer, 22, 4)); + my $filename_length = unpack ("v", substr($buffer, 26, 2)); + my $extra_length = unpack ("v", substr($buffer, 28, 2)); + + my $filename ; + $fh->read($filename, $filename_length) == $filename_length + or die "Truncated file\n"; + + $fh->read($buffer, $extra_length) == $extra_length + or die "Truncated file\n"; + + if ($compressedMethod != 8 && $compressedMethod != 0) + { + warn "Skipping file '$filename' - not deflated $compressedMethod\n"; + $fh->read($buffer, $compressedLength) == $compressedLength + or die "Truncated file\n"; + next; + } + + if ($compressedMethod == 0 && $gpFlag & 8 == 8) + { + die "Streamed Stored not supported for '$filename'\n"; + } + + next if $compressedLength == 0; + + # Done reading the Local Header + + my $inf = new IO::Uncompress::RawInflate $fh, + Transparent => 1, + InputLength => $compressedLength + or die "Cannot uncompress $file [$filename]: $RawInflateError\n" ; + + my $line_count = 0; + + while (<$inf>) + { + ++ $line_count; + } + + print "$filename: $line_count\n"; + } + +The majority of the code above is concerned with reading the zip local +header data. The code that I want to focus on is at the bottom. + + while (1) { + + # read local zip header data + # get $filename + # get $compressedLength + + my $inf = new IO::Uncompress::RawInflate $fh, + Transparent => 1, + InputLength => $compressedLength + or die "Cannot uncompress $file [$filename]: $RawInflateError\n" ; + + my $line_count = 0; + + while (<$inf>) + { + ++ $line_count; + } + + print "$filename: $line_count\n"; + } + +The call to C<IO::Uncompress::RawInflate> creates a new filehandle C<$inf> +that can be used to read from the parent filehandle C<$fh>, uncompressing +it as it goes. The use of the C<InputLength> option will guarantee that +I<at most> C<$compressedLength> bytes of compressed data will be read from +the C<$fh> filehandle (The only exception is for an error case like a +truncated file or a corrupt data stream). + +This means that once RawInflate is finished C<$fh> will be left at the +byte directly after the compressed data stream. + +Now consider what the code looks like without C<InputLength> + + while (1) { + + # read local zip header data + # get $filename + # get $compressedLength + + # read all the compressed data into $data + read($fh, $data, $compressedLength); + + my $inf = new IO::Uncompress::RawInflate \$data, + Transparent => 1, + or die "Cannot uncompress $file [$filename]: $RawInflateError\n" ; + + my $line_count = 0; + + while (<$inf>) + { + ++ $line_count; + } + + print "$filename: $line_count\n"; + } + +The difference here is the addition of the temporary variable C<$data>. +This is used to store a copy of the compressed data while it is being +uncompressed. + +If you know that C<$compressedLength> isn't that big then using temporary +storage won't be a problem. But if C<$compressedLength> is very large or +you are writing an application that other people will use, and so have no +idea how big C<$compressedLength> will be, it could be an issue. + +Using C<InputLength> avoids the use of temporary storage and means the +application can cope with large compressed data streams. + +One final point -- obviously C<InputLength> can only be used whenever you +know the length of the compressed data beforehand, like here with a zip +file. + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Gzip.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Gzip.pm new file mode 100644 index 0000000000..db01764624 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Gzip.pm @@ -0,0 +1,1251 @@ +package IO::Compress::Gzip ; + +require 5.006 ; + +use strict ; +use warnings; +use bytes; + +require Exporter ; + +use IO::Compress::RawDeflate 2.074 () ; +use IO::Compress::Adapter::Deflate 2.074 ; + +use IO::Compress::Base::Common 2.074 qw(:Status ); +use IO::Compress::Gzip::Constants 2.074 ; +use IO::Compress::Zlib::Extra 2.074 ; + +BEGIN +{ + if (defined &utf8::downgrade ) + { *noUTF8 = \&utf8::downgrade } + else + { *noUTF8 = sub {} } +} + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $GzipError); + +$VERSION = '2.074'; +$GzipError = '' ; + +@ISA = qw(IO::Compress::RawDeflate Exporter); +@EXPORT_OK = qw( $GzipError gzip ) ; +%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ; + +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + +sub new +{ + my $class = shift ; + + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$GzipError); + + $obj->_create(undef, @_); +} + + +sub gzip +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$GzipError); + return $obj->_def(@_); +} + +#sub newHeader +#{ +# my $self = shift ; +# #return GZIP_MINIMUM_HEADER ; +# return $self->mkHeader(*$self->{Got}); +#} + +sub getExtraParams +{ + my $self = shift ; + + return ( + # zlib behaviour + $self->getZlibParams(), + + # Gzip header fields + 'minimal' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'comment' => [IO::Compress::Base::Common::Parse_any, undef], + 'name' => [IO::Compress::Base::Common::Parse_any, undef], + 'time' => [IO::Compress::Base::Common::Parse_any, undef], + 'textflag' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'headercrc' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'os_code' => [IO::Compress::Base::Common::Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code], + 'extrafield'=> [IO::Compress::Base::Common::Parse_any, undef], + 'extraflags'=> [IO::Compress::Base::Common::Parse_any, undef], + + ); +} + + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # gzip always needs crc32 + $got->setValue('crc32' => 1); + + return 1 + if $got->getValue('merge') ; + + my $strict = $got->getValue('strict') ; + + + { + if (! $got->parsed('time') ) { + # Modification time defaults to now. + $got->setValue(time => time) ; + } + + # Check that the Name & Comment don't have embedded NULLs + # Also check that they only contain ISO 8859-1 chars. + if ($got->parsed('name') && defined $got->getValue('name')) { + my $name = $got->getValue('name'); + + return $self->saveErrorString(undef, "Null Character found in Name", + Z_DATA_ERROR) + if $strict && $name =~ /\x00/ ; + + return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Name", + Z_DATA_ERROR) + if $strict && $name =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ; + } + + if ($got->parsed('comment') && defined $got->getValue('comment')) { + my $comment = $got->getValue('comment'); + + return $self->saveErrorString(undef, "Null Character found in Comment", + Z_DATA_ERROR) + if $strict && $comment =~ /\x00/ ; + + return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment", + Z_DATA_ERROR) + if $strict && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o; + } + + if ($got->parsed('os_code') ) { + my $value = $got->getValue('os_code'); + + return $self->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'") + if $value < 0 || $value > 255 ; + + } + + # gzip only supports Deflate at present + $got->setValue('method' => Z_DEFLATED) ; + + if ( ! $got->parsed('extraflags')) { + $got->setValue('extraflags' => 2) + if $got->getValue('level') == Z_BEST_COMPRESSION ; + $got->setValue('extraflags' => 4) + if $got->getValue('level') == Z_BEST_SPEED ; + } + + my $data = $got->getValue('extrafield') ; + if (defined $data) { + my $bad = IO::Compress::Zlib::Extra::parseExtraField($data, $strict, 1) ; + return $self->saveErrorString(undef, "Error with ExtraField Parameter: $bad", Z_DATA_ERROR) + if $bad ; + + $got->setValue('extrafield' => $data) ; + } + } + + return 1; +} + +sub mkTrailer +{ + my $self = shift ; + return pack("V V", *$self->{Compress}->crc32(), + *$self->{UnCompSize}->get32bit()); +} + +sub getInverseClass +{ + return ('IO::Uncompress::Gunzip', + \$IO::Uncompress::Gunzip::GunzipError); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $filename = shift ; + + return if IO::Compress::Base::Common::isaScalar($filename); + + my $defaultTime = (stat($filename))[9] ; + + $params->setValue('name' => $filename) + if ! $params->parsed('name') ; + + $params->setValue('time' => $defaultTime) + if ! $params->parsed('time') ; +} + + +sub mkHeader +{ + my $self = shift ; + my $param = shift ; + + # short-circuit if a minimal header is requested. + return GZIP_MINIMUM_HEADER if $param->getValue('minimal') ; + + # METHOD + my $method = $param->valueOrDefault('method', GZIP_CM_DEFLATED) ; + + # FLAGS + my $flags = GZIP_FLG_DEFAULT ; + $flags |= GZIP_FLG_FTEXT if $param->getValue('textflag') ; + $flags |= GZIP_FLG_FHCRC if $param->getValue('headercrc') ; + $flags |= GZIP_FLG_FEXTRA if $param->wantValue('extrafield') ; + $flags |= GZIP_FLG_FNAME if $param->wantValue('name') ; + $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('comment') ; + + # MTIME + my $time = $param->valueOrDefault('time', GZIP_MTIME_DEFAULT) ; + + # EXTRA FLAGS + my $extra_flags = $param->valueOrDefault('extraflags', GZIP_XFL_DEFAULT); + + # OS CODE + my $os_code = $param->valueOrDefault('os_code', GZIP_OS_DEFAULT) ; + + + my $out = pack("C4 V C C", + GZIP_ID1, # ID1 + GZIP_ID2, # ID2 + $method, # Compression Method + $flags, # Flags + $time, # Modification Time + $extra_flags, # Extra Flags + $os_code, # Operating System Code + ) ; + + # EXTRA + if ($flags & GZIP_FLG_FEXTRA) { + my $extra = $param->getValue('extrafield') ; + $out .= pack("v", length $extra) . $extra ; + } + + # NAME + if ($flags & GZIP_FLG_FNAME) { + my $name .= $param->getValue('name') ; + $name =~ s/\x00.*$//; + $out .= $name ; + # Terminate the filename with NULL unless it already is + $out .= GZIP_NULL_BYTE + if !length $name or + substr($name, 1, -1) ne GZIP_NULL_BYTE ; + } + + # COMMENT + if ($flags & GZIP_FLG_FCOMMENT) { + my $comment .= $param->getValue('comment') ; + $comment =~ s/\x00.*$//; + $out .= $comment ; + # Terminate the comment with NULL unless it already is + $out .= GZIP_NULL_BYTE + if ! length $comment or + substr($comment, 1, -1) ne GZIP_NULL_BYTE; + } + + # HEADER CRC + $out .= pack("v", Compress::Raw::Zlib::crc32($out) & 0x00FF ) + if $param->getValue('headercrc') ; + + noUTF8($out); + + return $out ; +} + +sub mkFinalTrailer +{ + return ''; +} + +1; + +__END__ + +=head1 NAME + +IO::Compress::Gzip - Write RFC 1952 files/buffers + + + +=head1 SYNOPSIS + + use IO::Compress::Gzip qw(gzip $GzipError) ; + + my $status = gzip $input => $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + my $z = new IO::Compress::Gzip $output [,OPTS] + or die "gzip failed: $GzipError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->deflateParams(); + + $z->close() ; + + $GzipError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1952. + +All the gzip headers defined in RFC 1952 can be created using +this module. + +For reading RFC 1952 files/buffers, see the companion module +L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>. + +=head1 Functional Interface + +A top-level function, C<gzip>, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L</"OO Interface"> +section. + + use IO::Compress::Gzip qw(gzip $GzipError) ; + + gzip $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "gzip failed: $GzipError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 gzip $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<gzip> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<gzip> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +In addition, if C<$input_filename_or_reference> is a simple filename, +the default values for +the C<Name> and C<Time> options will be sourced from that file. + +If you do not want to use these defaults they can be overridden by +explicitly setting the C<Name> and C<Time> options or by setting the +C<Minimal> parameter. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the compressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +compressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +compressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +compressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the compressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<gzip> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple files/buffers and +C<$output_filename_or_reference> is a single +file/buffer the input files/buffers will be stored +in C<$output_filename_or_reference> as a concatenated series of compressed data streams. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<gzip>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<gzip> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<gzip> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all compressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +compressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any compressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any compressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all compressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any compressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all compressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any compressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any compressed data is output. + +Defaults to 0. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.gz>. + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + + my $input = "file1.txt"; + gzip $input => "$input.gz" + or die "gzip failed: $GzipError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + gzip $input => \$buffer + or die "gzip failed: $GzipError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + + gzip '</my/home/*.txt>' => '<*.gz>' + or die "gzip failed: $GzipError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Gzip qw(gzip $GzipError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.gz" ; + gzip $input => $output + or die "Error compressing '$input': $GzipError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::Gzip> is shown below + + my $z = new IO::Compress::Gzip $output [,OPTS] + or die "IO::Compress::Gzip failed: $GzipError\n"; + +It returns an C<IO::Compress::Gzip> object on success and undef on failure. +The variable C<$GzipError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Gzip can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::Gzip>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C<close> method is called or the C<IO::Compress::Gzip> +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data +will be append to the end of C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C<seek> before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + +=item C<< Merge => 0|1 >> + +This option is used to compress input data and append it to an existing +compressed data stream in C<$output>. The end result is a single compressed +data stream stored in C<$output>. + +It is a fatal error to attempt to use this option when C<$output> is not an +RFC 1952 data stream. + +There are a number of other limitations with the C<Merge> option: + +=over 5 + +=item 1 + +This module needs to have been built with zlib 1.2.1 or better to work. A +fatal error will be thrown if C<Merge> is used with an older version of +zlib. + +=item 2 + +If C<$output> is a file or a filehandle, it must be seekable. + +=back + +This parameter defaults to 0. + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::Gzip> by default. + + use IO::Compress::Gzip qw(:strategy); + use IO::Compress::Gzip qw(:constants); + use IO::Compress::Gzip qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + +=item C<< Minimal => 0|1 >> + +If specified, this option will force the creation of the smallest possible +compliant gzip header (which is exactly 10 bytes long) as defined in +RFC 1952. + +See the section titled "Compliance" in RFC 1952 for a definition +of the values used for the fields in the gzip header. + +All other parameters that control the content of the gzip header will +be ignored if this parameter is set to 1. + +This parameter defaults to 0. + +=item C<< Comment => $comment >> + +Stores the contents of C<$comment> in the COMMENT field in +the gzip header. +By default, no comment field is written to the gzip file. + +If the C<-Strict> option is enabled, the comment can only consist of ISO +8859-1 characters plus line feed. + +If the C<-Strict> option is disabled, the comment field can contain any +character except NULL. If any null characters are present, the field +will be truncated at the first NULL. + +=item C<< Name => $string >> + +Stores the contents of C<$string> in the gzip NAME header field. If +C<Name> is not specified, no gzip NAME field will be created. + +If the C<-Strict> option is enabled, C<$string> can only consist of ISO +8859-1 characters. + +If C<-Strict> is disabled, then C<$string> can contain any character +except NULL. If any null characters are present, the field will be +truncated at the first NULL. + +=item C<< Time => $number >> + +Sets the MTIME field in the gzip header to $number. + +This field defaults to the time the C<IO::Compress::Gzip> object was created +if this option is not specified. + +=item C<< TextFlag => 0|1 >> + +This parameter controls the setting of the FLG.FTEXT bit in the gzip +header. It is used to signal that the data stored in the gzip file/buffer +is probably text. + +The default is 0. + +=item C<< HeaderCRC => 0|1 >> + +When true this parameter will set the FLG.FHCRC bit to 1 in the gzip header +and set the CRC16 header field to the CRC of the complete gzip header +except the CRC16 field itself. + +B<Note> that gzip files created with the C<HeaderCRC> flag set to 1 cannot +be read by most, if not all, of the standard gunzip utilities, most +notably gzip version 1.2.4. You should therefore avoid using this option if +you want to maximize the portability of your gzip files. + +This parameter defaults to 0. + +=item C<< OS_Code => $value >> + +Stores C<$value> in the gzip OS header field. A number between 0 and 255 is +valid. + +If not specified, this parameter defaults to the OS code of the Operating +System this module was built on. The value 3 is used as a catch-all for all +Unix variants and unknown Operating Systems. + +=item C<< ExtraField => $data >> + +This parameter allows additional metadata to be stored in the ExtraField in +the gzip header. An RFC 1952 compliant ExtraField consists of zero or more +subfields. Each subfield consists of a two byte header followed by the +subfield data. + +The list of subfields can be supplied in any of the following formats + + -ExtraField => [$id1, $data1, + $id2, $data2, + ... + ] + -ExtraField => [ [$id1 => $data1], + [$id2 => $data2], + ... + ] + -ExtraField => { $id1 => $data1, + $id2 => $data2, + ... + } + +Where C<$id1>, C<$id2> are two byte subfield ID's. The second byte of +the ID cannot be 0, unless the C<Strict> option has been disabled. + +If you use the hash syntax, you have no control over the order in which +the ExtraSubFields are stored, plus you cannot have SubFields with +duplicate ID. + +Alternatively the list of subfields can by supplied as a scalar, thus + + -ExtraField => $rawdata + +If you use the raw format, and the C<Strict> option is enabled, +C<IO::Compress::Gzip> will check that C<$rawdata> consists of zero or more +conformant sub-fields. When C<Strict> is disabled, C<$rawdata> can +consist of any arbitrary byte stream. + +The maximum size of the Extra Field 65535 bytes. + +=item C<< ExtraFlags => $value >> + +Sets the XFL byte in the gzip header to C<$value>. + +If this option is not present, the value stored in XFL field will be +determined by the setting of the C<Level> option. + +If C<< Level => Z_BEST_SPEED >> has been specified then XFL is set to 2. +If C<< Level => Z_BEST_COMPRESSION >> has been specified then XFL is set to 4. +Otherwise XFL is set to 0. + +=item C<< Strict => 0|1 >> + +C<Strict> will optionally police the values supplied with other options +to ensure they are compliant with RFC1952. + +This option is enabled by default. + +If C<Strict> is enabled the following behaviour will be policed: + +=over 5 + +=item * + +The value supplied with the C<Name> option can only contain ISO 8859-1 +characters. + +=item * + +The value supplied with the C<Comment> option can only contain ISO 8859-1 +characters plus line-feed. + +=item * + +The values supplied with the C<-Name> and C<-Comment> options cannot +contain multiple embedded nulls. + +=item * + +If an C<ExtraField> option is specified and it is a simple scalar, +it must conform to the sub-field structure as defined in RFC 1952. + +=item * + +If an C<ExtraField> option is specified the second byte of the ID will be +checked in each subfield to ensure that it does not contain the reserved +value 0x00. + +=back + +When C<Strict> is disabled the following behaviour will be policed: + +=over 5 + +=item * + +The value supplied with C<-Name> option can contain +any character except NULL. + +=item * + +The value supplied with C<-Comment> option can contain any character +except NULL. + +=item * + +The values supplied with the C<-Name> and C<-Comment> options can contain +multiple embedded nulls. The string written to the gzip header will +consist of the characters up to, but not including, the first embedded +NULL. + +=item * + +If an C<ExtraField> option is specified and it is a simple scalar, the +structure will not be checked. The only error is if the length is too big. + +=item * + +The ID header in an C<ExtraField> sub-field can consist of any two bytes. + +=back + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + $z->flush; + $z->flush($flush_type); + +Flushes any pending compressed data to the output file/buffer. + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + +Returns true on success. + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the C<close> method has been called. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +This method always returns C<undef> when compressing. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Flushes any pending compressed data and then closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Gzip object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::Gzip +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the options that are available when creating +the C<$z> object. + +See the L</"Constructor Options"> section for more details. + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + +=head1 Importing + +A number of symbolic constants are required by some methods in +C<IO::Compress::Gzip>. None are imported by default. + +=over 5 + +=item :all + +Imports C<gzip>, C<$GzipError> and all symbolic +constants that can be used by C<IO::Compress::Gzip>. Same as doing this + + use IO::Compress::Gzip qw(gzip $GzipError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + use IO::Compress::Gzip qw(:flush :level :strategy) ; + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + + + + +=back + +=head1 EXAMPLES + +=head2 Apache::GZip Revisited + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +L<http://www.faqs.org/rfcs/rfc1950.html>, +L<http://www.faqs.org/rfcs/rfc1951.html> and +L<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +L<http://www.zlib.org>. + +The primary site for gzip is L<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Gzip/Constants.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Gzip/Constants.pm new file mode 100644 index 0000000000..8186bf325e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Gzip/Constants.pm @@ -0,0 +1,148 @@ +package IO::Compress::Gzip::Constants; + +use strict ; +use warnings; +use bytes; + +require Exporter; + +our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names); +our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE); + +$VERSION = '2.074'; + +@ISA = qw(Exporter); + +@EXPORT= qw( + + GZIP_ID_SIZE + GZIP_ID1 + GZIP_ID2 + + GZIP_FLG_DEFAULT + GZIP_FLG_FTEXT + GZIP_FLG_FHCRC + GZIP_FLG_FEXTRA + GZIP_FLG_FNAME + GZIP_FLG_FCOMMENT + GZIP_FLG_RESERVED + + GZIP_CM_DEFLATED + + GZIP_MIN_HEADER_SIZE + GZIP_TRAILER_SIZE + + GZIP_MTIME_DEFAULT + GZIP_XFL_DEFAULT + GZIP_FEXTRA_HEADER_SIZE + GZIP_FEXTRA_MAX_SIZE + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE + GZIP_FEXTRA_SUBFIELD_ID_SIZE + GZIP_FEXTRA_SUBFIELD_LEN_SIZE + GZIP_FEXTRA_SUBFIELD_MAX_SIZE + + $GZIP_FNAME_INVALID_CHAR_RE + $GZIP_FCOMMENT_INVALID_CHAR_RE + + GZIP_FHCRC_SIZE + + GZIP_ISIZE_MAX + GZIP_ISIZE_MOD_VALUE + + + GZIP_NULL_BYTE + + GZIP_OS_DEFAULT + + %GZIP_OS_Names + + GZIP_MINIMUM_HEADER + + ); + +# Constant names derived from RFC 1952 + +use constant GZIP_ID_SIZE => 2 ; +use constant GZIP_ID1 => 0x1F; +use constant GZIP_ID2 => 0x8B; + +use constant GZIP_MIN_HEADER_SIZE => 10 ;# minimum gzip header size +use constant GZIP_TRAILER_SIZE => 8 ; + + +use constant GZIP_FLG_DEFAULT => 0x00 ; +use constant GZIP_FLG_FTEXT => 0x01 ; +use constant GZIP_FLG_FHCRC => 0x02 ; # called CONTINUATION in gzip +use constant GZIP_FLG_FEXTRA => 0x04 ; +use constant GZIP_FLG_FNAME => 0x08 ; +use constant GZIP_FLG_FCOMMENT => 0x10 ; +#use constant GZIP_FLG_ENCRYPTED => 0x20 ; # documented in gzip sources +use constant GZIP_FLG_RESERVED => (0x20 | 0x40 | 0x80) ; + +use constant GZIP_XFL_DEFAULT => 0x00 ; + +use constant GZIP_MTIME_DEFAULT => 0x00 ; + +use constant GZIP_FEXTRA_HEADER_SIZE => 2 ; +use constant GZIP_FEXTRA_MAX_SIZE => 0xFFFF ; +use constant GZIP_FEXTRA_SUBFIELD_ID_SIZE => 2 ; +use constant GZIP_FEXTRA_SUBFIELD_LEN_SIZE => 2 ; +use constant GZIP_FEXTRA_SUBFIELD_HEADER_SIZE => GZIP_FEXTRA_SUBFIELD_ID_SIZE + + GZIP_FEXTRA_SUBFIELD_LEN_SIZE; +use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => GZIP_FEXTRA_MAX_SIZE - + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE ; + + +if (ord('A') == 193) +{ + # EBCDIC + $GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x3f\xff]'; + $GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x0a\x11-\x14\x16-\x3f\xff]'; + +} +else +{ + $GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x1F\x7F-\x9F]'; + $GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x09\x11-\x1F\x7F-\x9F]'; +} + +use constant GZIP_FHCRC_SIZE => 2 ; # aka CONTINUATION in gzip + +use constant GZIP_CM_DEFLATED => 8 ; + +use constant GZIP_NULL_BYTE => "\x00"; +use constant GZIP_ISIZE_MAX => 0xFFFFFFFF ; +use constant GZIP_ISIZE_MOD_VALUE => GZIP_ISIZE_MAX + 1 ; + +# OS Names sourced from http://www.gzip.org/format.txt + +use constant GZIP_OS_DEFAULT=> 0xFF ; +%GZIP_OS_Names = ( + 0 => 'MS-DOS', + 1 => 'Amiga', + 2 => 'VMS', + 3 => 'Unix', + 4 => 'VM/CMS', + 5 => 'Atari TOS', + 6 => 'HPFS (OS/2, NT)', + 7 => 'Macintosh', + 8 => 'Z-System', + 9 => 'CP/M', + 10 => 'TOPS-20', + 11 => 'NTFS (NT)', + 12 => 'SMS QDOS', + 13 => 'Acorn RISCOS', + 14 => 'VFAT file system (Win95, NT)', + 15 => 'MVS', + 16 => 'BeOS', + 17 => 'Tandem/NSK', + 18 => 'THEOS', + GZIP_OS_DEFAULT() => 'Unknown', + ) ; + +use constant GZIP_MINIMUM_HEADER => pack("C4 V C C", + GZIP_ID1, GZIP_ID2, GZIP_CM_DEFLATED, GZIP_FLG_DEFAULT, + GZIP_MTIME_DEFAULT, GZIP_XFL_DEFAULT, GZIP_OS_DEFAULT) ; + + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm new file mode 100644 index 0000000000..bc1b71eefe --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm @@ -0,0 +1,995 @@ +package IO::Compress::RawDeflate ; + +# create RFC1951 +# +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base 2.074 ; +use IO::Compress::Base::Common 2.074 qw(:Status ); +use IO::Compress::Adapter::Deflate 2.074 ; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError); + +$VERSION = '2.074'; +$RawDeflateError = ''; + +@ISA = qw(IO::Compress::Base Exporter); +@EXPORT_OK = qw( $RawDeflateError rawdeflate ) ; +push @EXPORT_OK, @IO::Compress::Adapter::Deflate::EXPORT_OK ; + +%EXPORT_TAGS = %IO::Compress::Adapter::Deflate::DEFLATE_CONSTANTS; + + +{ + my %seen; + foreach (keys %EXPORT_TAGS ) + { + push @{$EXPORT_TAGS{constants}}, + grep { !$seen{$_}++ } + @{ $EXPORT_TAGS{$_} } + } + $EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ; +} + + +%DEFLATE_CONSTANTS = %EXPORT_TAGS; + +#push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; + +Exporter::export_ok_tags('all'); + + + +sub new +{ + my $class = shift ; + + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$RawDeflateError); + + return $obj->_create(undef, @_); +} + +sub rawdeflate +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$RawDeflateError); + return $obj->_def(@_); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift; + + return 1 ; +} + +sub mkComp +{ + my $self = shift ; + my $got = shift ; + + my ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject( + $got->getValue('crc32'), + $got->getValue('adler32'), + $got->getValue('level'), + $got->getValue('strategy') + ); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + return $obj; +} + + +sub mkHeader +{ + my $self = shift ; + return ''; +} + +sub mkTrailer +{ + my $self = shift ; + return ''; +} + +sub mkFinalTrailer +{ + return ''; +} + + +#sub newHeader +#{ +# my $self = shift ; +# return ''; +#} + +sub getExtraParams +{ + my $self = shift ; + return getZlibParams(); +} + +use IO::Compress::Base::Common 2.074 qw(:Parse); +use Compress::Raw::Zlib 2.074 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); +our %PARAMS = ( + #'method' => [IO::Compress::Base::Common::Parse_unsigned, Z_DEFLATED], + 'level' => [IO::Compress::Base::Common::Parse_signed, Z_DEFAULT_COMPRESSION], + 'strategy' => [IO::Compress::Base::Common::Parse_signed, Z_DEFAULT_STRATEGY], + + 'crc32' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'adler32' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'merge' => [IO::Compress::Base::Common::Parse_boolean, 0], + ); + +sub getZlibParams +{ + return %PARAMS; +} + +sub getInverseClass +{ + return ('IO::Uncompress::RawInflate', + \$IO::Uncompress::RawInflate::RawInflateError); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $file = shift ; + +} + +use Fcntl qw(SEEK_SET); + +sub createMerge +{ + my $self = shift ; + my $outValue = shift ; + my $outType = shift ; + + my ($invClass, $error_ref) = $self->getInverseClass(); + eval "require $invClass" + or die "aaaahhhh" ; + + my $inf = $invClass->new( $outValue, + Transparent => 0, + #Strict => 1, + AutoClose => 0, + Scan => 1) + or return $self->saveErrorString(undef, "Cannot create InflateScan object: $$error_ref" ) ; + + my $end_offset = 0; + $inf->scan() + or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $inf->errorNo) ; + $inf->zap($end_offset) + or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $inf->errorNo) ; + + my $def = *$self->{Compress} = $inf->createDeflate(); + + *$self->{Header} = *$inf->{Info}{Header}; + *$self->{UnCompSize} = *$inf->{UnCompSize}->clone(); + *$self->{CompSize} = *$inf->{CompSize}->clone(); + # TODO -- fix this + #*$self->{CompSize} = new U64(0, *$self->{UnCompSize_32bit}); + + + if ( $outType eq 'buffer') + { substr( ${ *$self->{Buffer} }, $end_offset) = '' } + elsif ($outType eq 'handle' || $outType eq 'filename') { + *$self->{FH} = *$inf->{FH} ; + delete *$inf->{FH}; + *$self->{FH}->flush() ; + *$self->{Handle} = 1 if $outType eq 'handle'; + + #seek(*$self->{FH}, $end_offset, SEEK_SET) + *$self->{FH}->seek($end_offset, SEEK_SET) + or return $self->saveErrorString(undef, $!, $!) ; + } + + return $def ; +} + +#### zlib specific methods + +sub deflateParams +{ + my $self = shift ; + + my $level = shift ; + my $strategy = shift ; + + my $status = *$self->{Compress}->deflateParams(Level => $level, Strategy => $strategy) ; + return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) + if $status == STATUS_ERROR; + + return 1; +} + + + + +1; + +__END__ + +=head1 NAME + +IO::Compress::RawDeflate - Write RFC 1951 files/buffers + + + +=head1 SYNOPSIS + + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + my $status = rawdeflate $input => $output [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + + my $z = new IO::Compress::RawDeflate $output [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->deflateParams(); + + $z->close() ; + + $RawDeflateError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + +This module provides a Perl interface that allows writing compressed +data to files or buffer as defined in RFC 1951. + +Note that RFC 1951 data is not a good choice of compression format +to use in isolation, especially if you want to auto-detect it. + +For reading RFC 1951 files/buffers, see the companion module +L<IO::Uncompress::RawInflate|IO::Uncompress::RawInflate>. + +=head1 Functional Interface + +A top-level function, C<rawdeflate>, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L</"OO Interface"> +section. + + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + rawdeflate $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 rawdeflate $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<rawdeflate> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<rawdeflate> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the compressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +compressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +compressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +compressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the compressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<rawdeflate> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple files/buffers and +C<$output_filename_or_reference> is a single +file/buffer the input files/buffers will be stored +in C<$output_filename_or_reference> as a concatenated series of compressed data streams. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<rawdeflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<rawdeflate> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<rawdeflate> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all compressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +compressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any compressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any compressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all compressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any compressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all compressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any compressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any compressed data is output. + +Defaults to 0. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.1951>. + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + my $input = "file1.txt"; + rawdeflate $input => "$input.1951" + or die "rawdeflate failed: $RawDeflateError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + rawdeflate $input => \$buffer + or die "rawdeflate failed: $RawDeflateError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + rawdeflate '</my/home/*.txt>' => '<*.1951>' + or die "rawdeflate failed: $RawDeflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.1951" ; + rawdeflate $input => $output + or die "Error compressing '$input': $RawDeflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::RawDeflate> is shown below + + my $z = new IO::Compress::RawDeflate $output [,OPTS] + or die "IO::Compress::RawDeflate failed: $RawDeflateError\n"; + +It returns an C<IO::Compress::RawDeflate> object on success and undef on failure. +The variable C<$RawDeflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::RawDeflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::RawDeflate>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C<close> method is called or the C<IO::Compress::RawDeflate> +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data +will be append to the end of C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C<seek> before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + +=item C<< Merge => 0|1 >> + +This option is used to compress input data and append it to an existing +compressed data stream in C<$output>. The end result is a single compressed +data stream stored in C<$output>. + +It is a fatal error to attempt to use this option when C<$output> is not an +RFC 1951 data stream. + +There are a number of other limitations with the C<Merge> option: + +=over 5 + +=item 1 + +This module needs to have been built with zlib 1.2.1 or better to work. A +fatal error will be thrown if C<Merge> is used with an older version of +zlib. + +=item 2 + +If C<$output> is a file or a filehandle, it must be seekable. + +=back + +This parameter defaults to 0. + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::RawDeflate> by default. + + use IO::Compress::RawDeflate qw(:strategy); + use IO::Compress::RawDeflate qw(:constants); + use IO::Compress::RawDeflate qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + +=item C<< Strict => 0|1 >> + +This is a placeholder option. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + $z->flush; + $z->flush($flush_type); + +Flushes any pending compressed data to the output file/buffer. + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + +Returns true on success. + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the C<close> method has been called. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +This method always returns C<undef> when compressing. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Flushes any pending compressed data and then closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::RawDeflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::RawDeflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the options that are available when creating +the C<$z> object. + +See the L</"Constructor Options"> section for more details. + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + +=head1 Importing + +A number of symbolic constants are required by some methods in +C<IO::Compress::RawDeflate>. None are imported by default. + +=over 5 + +=item :all + +Imports C<rawdeflate>, C<$RawDeflateError> and all symbolic +constants that can be used by C<IO::Compress::RawDeflate>. Same as doing this + + use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + use IO::Compress::RawDeflate qw(:flush :level :strategy) ; + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + + + + +=back + +=head1 EXAMPLES + +=head2 Apache::GZip Revisited + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +L<http://www.faqs.org/rfcs/rfc1950.html>, +L<http://www.faqs.org/rfcs/rfc1951.html> and +L<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +L<http://www.zlib.org>. + +The primary site for gzip is L<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zip.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zip.pm new file mode 100644 index 0000000000..07c72d6706 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zip.pm @@ -0,0 +1,1965 @@ +package IO::Compress::Zip ; + +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.074 qw(:Status ); +use IO::Compress::RawDeflate 2.074 (); +use IO::Compress::Adapter::Deflate 2.074 ; +use IO::Compress::Adapter::Identity 2.074 ; +use IO::Compress::Zlib::Extra 2.074 ; +use IO::Compress::Zip::Constants 2.074 ; + +use File::Spec(); +use Config; + +use Compress::Raw::Zlib 2.074 (); + +BEGIN +{ + eval { require IO::Compress::Adapter::Bzip2 ; + import IO::Compress::Adapter::Bzip2 2.074 ; + require IO::Compress::Bzip2 ; + import IO::Compress::Bzip2 2.074 ; + } ; + + eval { require IO::Compress::Adapter::Lzma ; + import IO::Compress::Adapter::Lzma 2.074 ; + require IO::Compress::Lzma ; + import IO::Compress::Lzma 2.074 ; + } ; +} + + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $ZipError); + +$VERSION = '2.074'; +$ZipError = ''; + +@ISA = qw(IO::Compress::RawDeflate Exporter); +@EXPORT_OK = qw( $ZipError zip ) ; +%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ; + +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; + +$EXPORT_TAGS{zip_method} = [qw( ZIP_CM_STORE ZIP_CM_DEFLATE ZIP_CM_BZIP2 ZIP_CM_LZMA)]; +push @{ $EXPORT_TAGS{all} }, @{ $EXPORT_TAGS{zip_method} }; + +Exporter::export_ok_tags('all'); + +sub new +{ + my $class = shift ; + + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$ZipError); + $obj->_create(undef, @_); + +} + +sub zip +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$ZipError); + return $obj->_def(@_); +} + +sub isMethodAvailable +{ + my $method = shift; + + # Store & Deflate are always available + return 1 + if $method == ZIP_CM_STORE || $method == ZIP_CM_DEFLATE ; + + return 1 + if $method == ZIP_CM_BZIP2 and + defined $IO::Compress::Adapter::Bzip2::VERSION; + + return 1 + if $method == ZIP_CM_LZMA and + defined $IO::Compress::Adapter::Lzma::VERSION; + + return 0; +} + +sub beforePayload +{ + my $self = shift ; + + if (*$self->{ZipData}{Sparse} ) { + my $inc = 1024 * 100 ; + my $NULLS = ("\x00" x $inc) ; + my $sparse = *$self->{ZipData}{Sparse} ; + *$self->{CompSize}->add( $sparse ); + *$self->{UnCompSize}->add( $sparse ); + + *$self->{FH}->seek($sparse, IO::Handle::SEEK_CUR); + + *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32($NULLS, *$self->{ZipData}{CRC32}) + for 1 .. int $sparse / $inc; + *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(substr($NULLS, 0, $sparse % $inc), + *$self->{ZipData}{CRC32}) + if $sparse % $inc; + } +} + +sub mkComp +{ + my $self = shift ; + my $got = shift ; + + my ($obj, $errstr, $errno) ; + + if (*$self->{ZipData}{Method} == ZIP_CM_STORE) { + ($obj, $errstr, $errno) = IO::Compress::Adapter::Identity::mkCompObject( + $got->getValue('level'), + $got->getValue('strategy') + ); + *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(undef); + } + elsif (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { + ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject( + $got->getValue('crc32'), + $got->getValue('adler32'), + $got->getValue('level'), + $got->getValue('strategy') + ); + } + elsif (*$self->{ZipData}{Method} == ZIP_CM_BZIP2) { + ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject( + $got->getValue('blocksize100k'), + $got->getValue('workfactor'), + $got->getValue('verbosity') + ); + *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(undef); + } + elsif (*$self->{ZipData}{Method} == ZIP_CM_LZMA) { + ($obj, $errstr, $errno) = IO::Compress::Adapter::Lzma::mkRawZipCompObject($got->getValue('preset'), + $got->getValue('extreme'), + ); + *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(undef); + } + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + if (! defined *$self->{ZipData}{SizesOffset}) { + *$self->{ZipData}{SizesOffset} = 0; + *$self->{ZipData}{Offset} = new U64 ; + } + + *$self->{ZipData}{AnyZip64} = 0 + if ! defined *$self->{ZipData}{AnyZip64} ; + + return $obj; +} + +sub reset +{ + my $self = shift ; + + *$self->{Compress}->reset(); + *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(''); + + return STATUS_OK; +} + +sub filterUncompressed +{ + my $self = shift ; + + if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { + *$self->{ZipData}{CRC32} = *$self->{Compress}->crc32(); + } + else { + *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(${$_[0]}, *$self->{ZipData}{CRC32}); + + } +} + +sub canonicalName +{ + # This sub is derived from Archive::Zip::_asZipDirName + + # Return the normalized name as used in a zip file (path + # separators become slashes, etc.). + # Will translate internal slashes in path components (i.e. on Macs) to + # underscores. Discards volume names. + # When $forceDir is set, returns paths with trailing slashes + # + # input output + # . '.' + # ./a a + # ./a/b a/b + # ./a/b/ a/b + # a/b/ a/b + # /a/b/ a/b + # c:\a\b\c.doc a/b/c.doc # on Windows + # "i/o maps:whatever" i_o maps/whatever # on Macs + + my $name = shift; + my $forceDir = shift ; + + my ( $volume, $directories, $file ) = + File::Spec->splitpath( File::Spec->canonpath($name), $forceDir ); + + my @dirs = map { $_ =~ s{/}{_}g; $_ } + File::Spec->splitdir($directories); + + if ( @dirs > 0 ) { pop (@dirs) if $dirs[-1] eq '' } # remove empty component + push @dirs, defined($file) ? $file : '' ; + + my $normalised_path = join '/', @dirs; + + # Leading directory separators should not be stored in zip archives. + # Example: + # C:\a\b\c\ a/b/c + # C:\a\b\c.txt a/b/c.txt + # /a/b/c/ a/b/c + # /a/b/c.txt a/b/c.txt + $normalised_path =~ s{^/}{}; # remove leading separator + + return $normalised_path; +} + + +sub mkHeader +{ + my $self = shift; + my $param = shift ; + + *$self->{ZipData}{LocalHdrOffset} = U64::clone(*$self->{ZipData}{Offset}); + + my $comment = ''; + $comment = $param->valueOrDefault('comment') ; + + my $filename = ''; + $filename = $param->valueOrDefault('name') ; + + $filename = canonicalName($filename) + if length $filename && $param->getValue('canonicalname') ; + + if (defined *$self->{ZipData}{FilterName} ) { + local *_ = \$filename ; + &{ *$self->{ZipData}{FilterName} }() ; + } + +# if ( $param->getValue('utf8') ) { +# require Encode ; +# $filename = Encode::encode_utf8($filename) +# if length $filename ; +# $comment = Encode::encode_utf8($comment) +# if length $comment ; +# } + + my $hdr = ''; + + my $time = _unixToDosTime($param->getValue('time')); + + my $extra = ''; + my $ctlExtra = ''; + my $empty = 0; + my $osCode = $param->getValue('os_code') ; + my $extFileAttr = 0 ; + + # This code assumes Unix. + # TODO - revisit this + $extFileAttr = 0100644 << 16 + if $osCode == ZIP_OS_CODE_UNIX ; + + if (*$self->{ZipData}{Zip64}) { + $empty = IO::Compress::Base::Common::MAX32; + + my $x = ''; + $x .= pack "V V", 0, 0 ; # uncompressedLength + $x .= pack "V V", 0, 0 ; # compressedLength + + # Zip64 needs to be first in extra field to workaround a Windows Explorer Bug + # See http://www.info-zip.org/phpBB3/viewtopic.php?f=3&t=440 for details + $extra .= IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x); + } + + if (! $param->getValue('minimal')) { + if ($param->parsed('mtime')) + { + $extra .= mkExtendedTime($param->getValue('mtime'), + $param->getValue('atime'), + $param->getValue('ctime')); + + $ctlExtra .= mkExtendedTime($param->getValue('mtime')); + } + + if ( $osCode == ZIP_OS_CODE_UNIX ) + { + if ( $param->getValue('want_exunixn') ) + { + my $ux3 = mkUnixNExtra( @{ $param->getValue('want_exunixn') }); + $extra .= $ux3; + $ctlExtra .= $ux3; + } + + if ( $param->getValue('exunix2') ) + { + $extra .= mkUnix2Extra( @{ $param->getValue('exunix2') }); + $ctlExtra .= mkUnix2Extra(); + } + } + + $extFileAttr = $param->getValue('extattr') + if defined $param->getValue('extattr') ; + + $extra .= $param->getValue('extrafieldlocal') + if defined $param->getValue('extrafieldlocal'); + + $ctlExtra .= $param->getValue('extrafieldcentral') + if defined $param->getValue('extrafieldcentral'); + } + + my $method = *$self->{ZipData}{Method} ; + my $gpFlag = 0 ; + $gpFlag |= ZIP_GP_FLAG_STREAMING_MASK + if *$self->{ZipData}{Stream} ; + + $gpFlag |= ZIP_GP_FLAG_LZMA_EOS_PRESENT + if $method == ZIP_CM_LZMA ; + +# $gpFlag |= ZIP_GP_FLAG_LANGUAGE_ENCODING +# if $param->getValue('utf8') && (length($filename) || length($comment)); + + my $version = $ZIP_CM_MIN_VERSIONS{$method}; + $version = ZIP64_MIN_VERSION + if ZIP64_MIN_VERSION > $version && *$self->{ZipData}{Zip64}; + + my $madeBy = ($param->getValue('os_code') << 8) + $version; + my $extract = $version; + + *$self->{ZipData}{Version} = $version; + *$self->{ZipData}{MadeBy} = $madeBy; + + my $ifa = 0; + $ifa |= ZIP_IFA_TEXT_MASK + if $param->getValue('textflag'); + + $hdr .= pack "V", ZIP_LOCAL_HDR_SIG ; # signature + $hdr .= pack 'v', $extract ; # extract Version & OS + $hdr .= pack 'v', $gpFlag ; # general purpose flag (set streaming mode) + $hdr .= pack 'v', $method ; # compression method (deflate) + $hdr .= pack 'V', $time ; # last mod date/time + $hdr .= pack 'V', 0 ; # crc32 - 0 when streaming + $hdr .= pack 'V', $empty ; # compressed length - 0 when streaming + $hdr .= pack 'V', $empty ; # uncompressed length - 0 when streaming + $hdr .= pack 'v', length $filename ; # filename length + $hdr .= pack 'v', length $extra ; # extra length + + $hdr .= $filename ; + + # Remember the offset for the compressed & uncompressed lengths in the + # local header. + if (*$self->{ZipData}{Zip64}) { + *$self->{ZipData}{SizesOffset} = *$self->{ZipData}{Offset}->get64bit() + + length($hdr) + 4 ; + } + else { + *$self->{ZipData}{SizesOffset} = *$self->{ZipData}{Offset}->get64bit() + + 18; + } + + $hdr .= $extra ; + + + my $ctl = ''; + + $ctl .= pack "V", ZIP_CENTRAL_HDR_SIG ; # signature + $ctl .= pack 'v', $madeBy ; # version made by + $ctl .= pack 'v', $extract ; # extract Version + $ctl .= pack 'v', $gpFlag ; # general purpose flag (streaming mode) + $ctl .= pack 'v', $method ; # compression method (deflate) + $ctl .= pack 'V', $time ; # last mod date/time + $ctl .= pack 'V', 0 ; # crc32 + $ctl .= pack 'V', $empty ; # compressed length + $ctl .= pack 'V', $empty ; # uncompressed length + $ctl .= pack 'v', length $filename ; # filename length + + *$self->{ZipData}{ExtraOffset} = length $ctl; + *$self->{ZipData}{ExtraSize} = length $ctlExtra ; + + $ctl .= pack 'v', length $ctlExtra ; # extra length + $ctl .= pack 'v', length $comment ; # file comment length + $ctl .= pack 'v', 0 ; # disk number start + $ctl .= pack 'v', $ifa ; # internal file attributes + $ctl .= pack 'V', $extFileAttr ; # external file attributes + + # offset to local hdr + if (*$self->{ZipData}{LocalHdrOffset}->is64bit() ) { + $ctl .= pack 'V', IO::Compress::Base::Common::MAX32 ; + } + else { + $ctl .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V32() ; + } + + $ctl .= $filename ; + + *$self->{ZipData}{Offset}->add32(length $hdr) ; + + *$self->{ZipData}{CentralHeader} = [ $ctl, $ctlExtra, $comment]; + + return $hdr; +} + +sub mkTrailer +{ + my $self = shift ; + + my $crc32 ; + if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { + $crc32 = pack "V", *$self->{Compress}->crc32(); + } + else { + $crc32 = pack "V", *$self->{ZipData}{CRC32}; + } + + my ($ctl, $ctlExtra, $comment) = @{ *$self->{ZipData}{CentralHeader} }; + + my $sizes ; + if (! *$self->{ZipData}{Zip64}) { + $sizes .= *$self->{CompSize}->getPacked_V32() ; # Compressed size + $sizes .= *$self->{UnCompSize}->getPacked_V32() ; # Uncompressed size + } + else { + $sizes .= *$self->{CompSize}->getPacked_V64() ; # Compressed size + $sizes .= *$self->{UnCompSize}->getPacked_V64() ; # Uncompressed size + } + + my $data = $crc32 . $sizes ; + + my $xtrasize = *$self->{UnCompSize}->getPacked_V64() ; # Uncompressed size + $xtrasize .= *$self->{CompSize}->getPacked_V64() ; # Compressed size + + my $hdr = ''; + + if (*$self->{ZipData}{Stream}) { + $hdr = pack "V", ZIP_DATA_HDR_SIG ; # signature + $hdr .= $data ; + } + else { + $self->writeAt(*$self->{ZipData}{LocalHdrOffset}->get64bit() + 14, $crc32) + or return undef; + $self->writeAt(*$self->{ZipData}{SizesOffset}, + *$self->{ZipData}{Zip64} ? $xtrasize : $sizes) + or return undef; + } + + # Central Header Record/Zip64 extended field + + substr($ctl, 16, length $crc32) = $crc32 ; + + my $zip64Payload = ''; + + # uncompressed length - only set zip64 if needed + if (*$self->{UnCompSize}->isAlmost64bit()) { # || *$self->{ZipData}{Zip64}) { + $zip64Payload .= *$self->{UnCompSize}->getPacked_V64() ; + } else { + substr($ctl, 24, 4) = *$self->{UnCompSize}->getPacked_V32() ; + } + + # compressed length - only set zip64 if needed + if (*$self->{CompSize}->isAlmost64bit()) { # || *$self->{ZipData}{Zip64}) { + $zip64Payload .= *$self->{CompSize}->getPacked_V64() ; + } else { + substr($ctl, 20, 4) = *$self->{CompSize}->getPacked_V32() ; + } + + # Local Header offset + $zip64Payload .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V64() + if *$self->{ZipData}{LocalHdrOffset}->is64bit() ; + + # disk no - always zero, so don't need to include it. + #$zip64Payload .= pack "V", 0 ; + + my $zip64Xtra = ''; + + if (length $zip64Payload) { + $zip64Xtra = IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $zip64Payload); + + substr($ctl, *$self->{ZipData}{ExtraOffset}, 2) = + pack 'v', *$self->{ZipData}{ExtraSize} + length $zip64Xtra; + + *$self->{ZipData}{AnyZip64} = 1; + } + + # Zip64 needs to be first in extra field to workaround a Windows Explorer Bug + # See http://www.info-zip.org/phpBB3/viewtopic.php?f=3&t=440 for details + $ctl .= $zip64Xtra . $ctlExtra . $comment; + + *$self->{ZipData}{Offset}->add32(length($hdr)); + *$self->{ZipData}{Offset}->add( *$self->{CompSize} ); + push @{ *$self->{ZipData}{CentralDir} }, $ctl ; + + return $hdr; +} + +sub mkFinalTrailer +{ + my $self = shift ; + + my $comment = ''; + $comment = *$self->{ZipData}{ZipComment} ; + + my $cd_offset = *$self->{ZipData}{Offset}->get32bit() ; # offset to start central dir + + my $entries = @{ *$self->{ZipData}{CentralDir} }; + + *$self->{ZipData}{AnyZip64} = 1 + if *$self->{ZipData}{Offset}->is64bit || $entries >= 0xFFFF ; + + my $cd = join '', @{ *$self->{ZipData}{CentralDir} }; + my $cd_len = length $cd ; + + my $z64e = ''; + + if ( *$self->{ZipData}{AnyZip64} ) { + + my $v = *$self->{ZipData}{Version} ; + my $mb = *$self->{ZipData}{MadeBy} ; + $z64e .= pack 'v', $mb ; # Version made by + $z64e .= pack 'v', $v ; # Version to extract + $z64e .= pack 'V', 0 ; # number of disk + $z64e .= pack 'V', 0 ; # number of disk with central dir + $z64e .= U64::pack_V64 $entries ; # entries in central dir on this disk + $z64e .= U64::pack_V64 $entries ; # entries in central dir + $z64e .= U64::pack_V64 $cd_len ; # size of central dir + $z64e .= *$self->{ZipData}{Offset}->getPacked_V64() ; # offset to start central dir + + $z64e = pack("V", ZIP64_END_CENTRAL_REC_HDR_SIG) # signature + . U64::pack_V64(length $z64e) + . $z64e ; + + *$self->{ZipData}{Offset}->add32(length $cd) ; + + $z64e .= pack "V", ZIP64_END_CENTRAL_LOC_HDR_SIG; # signature + $z64e .= pack 'V', 0 ; # number of disk with central dir + $z64e .= *$self->{ZipData}{Offset}->getPacked_V64() ; # offset to end zip64 central dir + $z64e .= pack 'V', 1 ; # Total number of disks + + $cd_offset = IO::Compress::Base::Common::MAX32 ; + $cd_len = IO::Compress::Base::Common::MAX32 if IO::Compress::Base::Common::isGeMax32 $cd_len ; + $entries = 0xFFFF if $entries >= 0xFFFF ; + } + + my $ecd = ''; + $ecd .= pack "V", ZIP_END_CENTRAL_HDR_SIG ; # signature + $ecd .= pack 'v', 0 ; # number of disk + $ecd .= pack 'v', 0 ; # number of disk with central dir + $ecd .= pack 'v', $entries ; # entries in central dir on this disk + $ecd .= pack 'v', $entries ; # entries in central dir + $ecd .= pack 'V', $cd_len ; # size of central dir + $ecd .= pack 'V', $cd_offset ; # offset to start central dir + $ecd .= pack 'v', length $comment ; # zipfile comment length + $ecd .= $comment; + + return $cd . $z64e . $ecd ; +} + +sub ckParams +{ + my $self = shift ; + my $got = shift; + + $got->setValue('crc32' => 1); + + if (! $got->parsed('time') ) { + # Modification time defaults to now. + $got->setValue('time' => time) ; + } + + if ($got->parsed('extime') ) { + my $timeRef = $got->getValue('extime'); + if ( defined $timeRef) { + return $self->saveErrorString(undef, "exTime not a 3-element array ref") + if ref $timeRef ne 'ARRAY' || @$timeRef != 3; + } + + $got->setValue("mtime", $timeRef->[1]); + $got->setValue("atime", $timeRef->[0]); + $got->setValue("ctime", $timeRef->[2]); + } + + # Unix2/3 Extended Attribute + for my $name (qw(exunix2 exunixn)) + { + if ($got->parsed($name) ) { + my $idRef = $got->getValue($name); + if ( defined $idRef) { + return $self->saveErrorString(undef, "$name not a 2-element array ref") + if ref $idRef ne 'ARRAY' || @$idRef != 2; + } + + $got->setValue("uid", $idRef->[0]); + $got->setValue("gid", $idRef->[1]); + $got->setValue("want_$name", $idRef); + } + } + + *$self->{ZipData}{AnyZip64} = 1 + if $got->getValue('zip64'); + *$self->{ZipData}{Zip64} = $got->getValue('zip64'); + *$self->{ZipData}{Stream} = $got->getValue('stream'); + + my $method = $got->getValue('method'); + return $self->saveErrorString(undef, "Unknown Method '$method'") + if ! defined $ZIP_CM_MIN_VERSIONS{$method}; + + return $self->saveErrorString(undef, "Bzip2 not available") + if $method == ZIP_CM_BZIP2 and + ! defined $IO::Compress::Adapter::Bzip2::VERSION; + + return $self->saveErrorString(undef, "Lzma not available") + if $method == ZIP_CM_LZMA + and ! defined $IO::Compress::Adapter::Lzma::VERSION; + + *$self->{ZipData}{Method} = $method; + + *$self->{ZipData}{ZipComment} = $got->getValue('zipcomment') ; + + for my $name (qw( extrafieldlocal extrafieldcentral )) + { + my $data = $got->getValue($name) ; + if (defined $data) { + my $bad = IO::Compress::Zlib::Extra::parseExtraField($data, 1, 0) ; + return $self->saveErrorString(undef, "Error with $name Parameter: $bad") + if $bad ; + + $got->setValue($name, $data) ; + } + } + + return undef + if defined $IO::Compress::Bzip2::VERSION + and ! IO::Compress::Bzip2::ckParams($self, $got); + + if ($got->parsed('sparse') ) { + *$self->{ZipData}{Sparse} = $got->getValue('sparse') ; + *$self->{ZipData}{Method} = ZIP_CM_STORE; + } + + if ($got->parsed('filtername')) { + my $v = $got->getValue('filtername') ; + *$self->{ZipData}{FilterName} = $v + if ref $v eq 'CODE' ; + } + + return 1 ; +} + +sub outputPayload +{ + my $self = shift ; + return 1 if *$self->{ZipData}{Sparse} ; + return $self->output(@_); +} + + +#sub newHeader +#{ +# my $self = shift ; +# +# return $self->mkHeader(*$self->{Got}); +#} + + +our %PARAMS = ( + 'stream' => [IO::Compress::Base::Common::Parse_boolean, 1], + #'store' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'method' => [IO::Compress::Base::Common::Parse_unsigned, ZIP_CM_DEFLATE], + +# # Zip header fields + 'minimal' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'zip64' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'comment' => [IO::Compress::Base::Common::Parse_any, ''], + 'zipcomment'=> [IO::Compress::Base::Common::Parse_any, ''], + 'name' => [IO::Compress::Base::Common::Parse_any, ''], + 'filtername'=> [IO::Compress::Base::Common::Parse_code, undef], + 'canonicalname'=> [IO::Compress::Base::Common::Parse_boolean, 0], +# 'utf8' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'time' => [IO::Compress::Base::Common::Parse_any, undef], + 'extime' => [IO::Compress::Base::Common::Parse_any, undef], + 'exunix2' => [IO::Compress::Base::Common::Parse_any, undef], + 'exunixn' => [IO::Compress::Base::Common::Parse_any, undef], + 'extattr' => [IO::Compress::Base::Common::Parse_any, + $Compress::Raw::Zlib::gzip_os_code == 3 + ? 0100644 << 16 + : 0], + 'os_code' => [IO::Compress::Base::Common::Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code], + + 'textflag' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'extrafieldlocal' => [IO::Compress::Base::Common::Parse_any, undef], + 'extrafieldcentral'=> [IO::Compress::Base::Common::Parse_any, undef], + + # Lzma + 'preset' => [IO::Compress::Base::Common::Parse_unsigned, 6], + 'extreme' => [IO::Compress::Base::Common::Parse_boolean, 0], + + # For internal use only + 'sparse' => [IO::Compress::Base::Common::Parse_unsigned, 0], + + IO::Compress::RawDeflate::getZlibParams(), + defined $IO::Compress::Bzip2::VERSION + ? IO::Compress::Bzip2::getExtraParams() + : () + + + ); + +sub getExtraParams +{ + return %PARAMS ; +} + +sub getInverseClass +{ + return ('IO::Uncompress::Unzip', + \$IO::Uncompress::Unzip::UnzipError); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $filename = shift ; + + if (IO::Compress::Base::Common::isaScalar($filename)) + { + $params->setValue(zip64 => 1) + if IO::Compress::Base::Common::isGeMax32 length (${ $filename }) ; + + return ; + } + + my ($mode, $uid, $gid, $size, $atime, $mtime, $ctime) ; + if ( $params->parsed('storelinks') ) + { + ($mode, $uid, $gid, $size, $atime, $mtime, $ctime) + = (lstat($filename))[2, 4,5,7, 8,9,10] ; + } + else + { + ($mode, $uid, $gid, $size, $atime, $mtime, $ctime) + = (stat($filename))[2, 4,5,7, 8,9,10] ; + } + + $params->setValue(textflag => -T $filename ) + if ! $params->parsed('textflag'); + + $params->setValue(zip64 => 1) + if IO::Compress::Base::Common::isGeMax32 $size ; + + $params->setValue('name' => $filename) + if ! $params->parsed('name') ; + + $params->setValue('time' => $mtime) + if ! $params->parsed('time') ; + + if ( ! $params->parsed('extime')) + { + $params->setValue('mtime' => $mtime) ; + $params->setValue('atime' => $atime) ; + $params->setValue('ctime' => undef) ; # No Creation time + # TODO - see if can fillout creation time on non-Unix + } + + # NOTE - Unix specific code alert + if (! $params->parsed('extattr')) + { + use Fcntl qw(:mode) ; + my $attr = $mode << 16; + $attr |= ZIP_A_RONLY if ($mode & S_IWRITE) == 0 ; + $attr |= ZIP_A_DIR if ($mode & S_IFMT ) == S_IFDIR ; + + $params->setValue('extattr' => $attr); + } + + $params->setValue('want_exunixn', [$uid, $gid]); + $params->setValue('uid' => $uid) ; + $params->setValue('gid' => $gid) ; + +} + +sub mkExtendedTime +{ + # order expected is m, a, c + + my $times = ''; + my $bit = 1 ; + my $flags = 0; + + for my $time (@_) + { + if (defined $time) + { + $flags |= $bit; + $times .= pack("V", $time); + } + + $bit <<= 1 ; + } + + return IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_EXT_TIMESTAMP, + pack("C", $flags) . $times); +} + +sub mkUnix2Extra +{ + my $ids = ''; + for my $id (@_) + { + $ids .= pack("v", $id); + } + + return IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_INFO_ZIP_UNIX2, + $ids); +} + +sub mkUnixNExtra +{ + my $uid = shift; + my $gid = shift; + + # Assumes UID/GID are 32-bit + my $ids ; + $ids .= pack "C", 1; # version + $ids .= pack "C", $Config{uidsize}; + $ids .= pack "V", $uid; + $ids .= pack "C", $Config{gidsize}; + $ids .= pack "V", $gid; + + return IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_INFO_ZIP_UNIXN, + $ids); +} + + +# from Archive::Zip +sub _unixToDosTime # Archive::Zip::Member +{ + my $time_t = shift; + + # TODO - add something to cope with unix time < 1980 + my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t); + my $dt = 0; + $dt += ( $sec >> 1 ); + $dt += ( $min << 5 ); + $dt += ( $hour << 11 ); + $dt += ( $mday << 16 ); + $dt += ( ( $mon + 1 ) << 21 ); + $dt += ( ( $year - 80 ) << 25 ); + return $dt; +} + +1; + +__END__ + +=head1 NAME + +IO::Compress::Zip - Write zip files/buffers + + + +=head1 SYNOPSIS + + use IO::Compress::Zip qw(zip $ZipError) ; + + my $status = zip $input => $output [,OPTS] + or die "zip failed: $ZipError\n"; + + my $z = new IO::Compress::Zip $output [,OPTS] + or die "zip failed: $ZipError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->deflateParams(); + + $z->close() ; + + $ZipError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + +This module provides a Perl interface that allows writing zip +compressed data to files or buffer. + +The primary purpose of this module is to provide streaming write access to +zip files and buffers. It is not a general-purpose file archiver. If that +is what you want, check out C<Archive::Zip>. + +At present three compression methods are supported by IO::Compress::Zip, +namely Store (no compression at all), Deflate, Bzip2 and LZMA. + +Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must +be installed. + +Note that to create LZMA content, the module C<IO::Compress::Lzma> must +be installed. + +For reading zip files/buffers, see the companion module +L<IO::Uncompress::Unzip|IO::Uncompress::Unzip>. + +=head1 Functional Interface + +A top-level function, C<zip>, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L</"OO Interface"> +section. + + use IO::Compress::Zip qw(zip $ZipError) ; + + zip $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "zip failed: $ZipError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 zip $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<zip> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<zip> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +In addition, if C<$input_filename_or_reference> is a simple filename, +the default values for +the C<Name>, C<Time>, C<TextFlag>, C<ExtAttr>, C<exUnixN> and C<exTime> options will be sourced from that file. + +If you do not want to use these defaults they can be overridden by +explicitly setting the C<Name>, C<Time>, C<TextFlag>, C<ExtAttr>, C<exUnixN> and C<exTime> options or by setting the +C<Minimal> parameter. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the compressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +compressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +compressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +compressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the compressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<zip> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple files/buffers and +C<$output_filename_or_reference> is a single +file/buffer the input files/buffers will each be stored +in C<$output_filename_or_reference> as a distinct entry. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<zip>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<zip> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<zip> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C<binmode> before reading. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all compressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +compressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any compressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any compressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all compressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any compressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all compressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any compressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any compressed data is output. + +Defaults to 0. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt> and write the compressed +data to the file C<file1.txt.zip>. + + use strict ; + use warnings ; + use IO::Compress::Zip qw(zip $ZipError) ; + + my $input = "file1.txt"; + zip $input => "$input.zip" + or die "zip failed: $ZipError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Zip qw(zip $ZipError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt" + or die "Cannot open 'file1.txt': $!\n" ; + my $buffer ; + zip $input => \$buffer + or die "zip failed: $ZipError\n"; + +To create a zip file, C<output.zip>, that contains the compressed contents +of the files C<alpha.txt> and C<beta.txt> + + use strict ; + use warnings ; + use IO::Compress::Zip qw(zip $ZipError) ; + + zip [ 'alpha.txt', 'beta.txt' ] => 'output.zip' + or die "zip failed: $ZipError\n"; + +Alternatively, rather than having to explicitly name each of the files that +you want to compress, you could use a fileglob to select all the C<txt> +files in the current directory, as follows + + use strict ; + use warnings ; + use IO::Compress::Zip qw(zip $ZipError) ; + + my @files = <*.txt>; + zip \@files => 'output.zip' + or die "zip failed: $ZipError\n"; + +or more succinctly + + zip [ <*.txt> ] => 'output.zip' + or die "zip failed: $ZipError\n"; + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C<IO::Compress::Zip> is shown below + + my $z = new IO::Compress::Zip $output [,OPTS] + or die "IO::Compress::Zip failed: $ZipError\n"; + +It returns an C<IO::Compress::Zip> object on success and undef on failure. +The variable C<$ZipError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Zip can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C<IO::Compress::Zip>::new will +return undef. + +=head2 Constructor Options + +C<OPTS> is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C<close> method is called or the C<IO::Compress::Zip> +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C<Append> is enabled, all compressed data +will be append to the end of C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C<Append> is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C<seek> before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + +=item C<< Name => $string >> + +Stores the contents of C<$string> in the zip filename header field. + +If C<Name> is not specified and the C<$input> parameter is a filename, the +value of C<$input> will be used for the zip filename header field. + +If C<Name> is not specified and the C<$input> parameter is not a filename, +no zip filename field will be created. + +Note that both the C<CanonicalName> and C<FilterName> options +can modify the value used for the zip filename header field. + +=item C<< CanonicalName => 0|1 >> + +This option controls whether the filename field in the zip header is +I<normalized> into Unix format before being written to the zip file. + +It is recommended that you enable this option unless you really need +to create a non-standard Zip file. + +This is what APPNOTE.TXT has to say on what should be stored in the zip +filename header field. + + The name of the file, with optional relative path. + The path stored should not contain a drive or + device letter, or a leading slash. All slashes + should be forward slashes '/' as opposed to + backwards slashes '\' for compatibility with Amiga + and UNIX file systems etc. + +This option defaults to B<false>. + +=item C<< FilterName => sub { ... } >> + +This option allow the filename field in the zip header to be modified +before it is written to the zip file. + +This option takes a parameter that must be a reference to a sub. On entry +to the sub the C<$_> variable will contain the name to be filtered. If no +filename is available C<$_> will contain an empty string. + +The value of C<$_> when the sub returns will be stored in the filename +header field. + +Note that if C<CanonicalName> is enabled, a +normalized filename will be passed to the sub. + +If you use C<FilterName> to modify the filename, it is your responsibility +to keep the filename in Unix format. + +Although this option can be used with the OO interface, it is of most use +with the one-shot interface. For example, the code below shows how +C<FilterName> can be used to remove the path component from a series of +filenames before they are stored in C<$zipfile>. + + sub compressTxtFiles + { + my $zipfile = shift ; + my $dir = shift ; + + zip [ <$dir/*.txt> ] => $zipfile, + FilterName => sub { s[^$dir/][] } ; + } + +=item C<< Time => $number >> + +Sets the last modified time field in the zip header to $number. + +This field defaults to the time the C<IO::Compress::Zip> object was created +if this option is not specified and the C<$input> parameter is not a +filename. + +=item C<< ExtAttr => $attr >> + +This option controls the "external file attributes" field in the central +header of the zip file. This is a 4 byte field. + +If you are running a Unix derivative this value defaults to + + 0100644 << 16 + +This should allow read/write access to any files that are extracted from +the zip file/buffer`. + +For all other systems it defaults to 0. + +=item C<< exTime => [$atime, $mtime, $ctime] >> + +This option expects an array reference with exactly three elements: +C<$atime>, C<mtime> and C<$ctime>. These correspond to the last access +time, last modification time and creation time respectively. + +It uses these values to set the extended timestamp field (ID is "UT") in +the local zip header using the three values, $atime, $mtime, $ctime. In +addition it sets the extended timestamp field in the central zip header +using C<$mtime>. + +If any of the three values is C<undef> that time value will not be used. +So, for example, to set only the C<$mtime> you would use this + + exTime => [undef, $mtime, undef] + +If the C<Minimal> option is set to true, this option will be ignored. + +By default no extended time field is created. + +=item C<< exUnix2 => [$uid, $gid] >> + +This option expects an array reference with exactly two elements: C<$uid> +and C<$gid>. These values correspond to the numeric User ID (UID) and Group ID +(GID) of the owner of the files respectively. + +When the C<exUnix2> option is present it will trigger the creation of a +Unix2 extra field (ID is "Ux") in the local zip header. This will be populated +with C<$uid> and C<$gid>. An empty Unix2 extra field will also +be created in the central zip header. + +Note - The UID & GID are stored as 16-bit +integers in the "Ux" field. Use C<< exUnixN >> if your UID or GID are +32-bit. + +If the C<Minimal> option is set to true, this option will be ignored. + +By default no Unix2 extra field is created. + +=item C<< exUnixN => [$uid, $gid] >> + +This option expects an array reference with exactly two elements: C<$uid> +and C<$gid>. These values correspond to the numeric User ID (UID) and Group ID +(GID) of the owner of the files respectively. + +When the C<exUnixN> option is present it will trigger the creation of a +UnixN extra field (ID is "ux") in both the local and central zip headers. +This will be populated with C<$uid> and C<$gid>. +The UID & GID are stored as 32-bit integers. + +If the C<Minimal> option is set to true, this option will be ignored. + +By default no UnixN extra field is created. + +=item C<< Comment => $comment >> + +Stores the contents of C<$comment> in the Central File Header of +the zip file. + +By default, no comment field is written to the zip file. + +=item C<< ZipComment => $comment >> + +Stores the contents of C<$comment> in the End of Central Directory record +of the zip file. + +By default, no comment field is written to the zip file. + +=item C<< Method => $method >> + +Controls which compression method is used. At present four compression +methods are supported, namely Store (no compression at all), Deflate, +Bzip2 and Lzma. + +The symbols, ZIP_CM_STORE, ZIP_CM_DEFLATE, ZIP_CM_BZIP2 and ZIP_CM_LZMA +are used to select the compression method. + +These constants are not imported by C<IO::Compress::Zip> by default. + + use IO::Compress::Zip qw(:zip_method); + use IO::Compress::Zip qw(:constants); + use IO::Compress::Zip qw(:all); + +Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must +be installed. A fatal error will be thrown if you attempt to create Bzip2 +content when C<IO::Compress::Bzip2> is not available. + +Note that to create Lzma content, the module C<IO::Compress::Lzma> must +be installed. A fatal error will be thrown if you attempt to create Lzma +content when C<IO::Compress::Lzma> is not available. + +The default method is ZIP_CM_DEFLATE. + +=item C<< Stream => 0|1 >> + +This option controls whether the zip file/buffer output is created in +streaming mode. + +Note that when outputting to a file with streaming mode disabled (C<Stream> +is 0), the output file must be seekable. + +The default is 1. + +=item C<< Zip64 => 0|1 >> + +Create a Zip64 zip file/buffer. This option is used if you want +to store files larger than 4 Gig or store more than 64K files in a single +zip archive.. + +C<Zip64> will be automatically set, as needed, if working with the one-shot +interface when the input is either a filename or a scalar reference. + +If you intend to manipulate the Zip64 zip files created with this module +using an external zip/unzip, make sure that it supports Zip64. + +In particular, if you are using Info-Zip you need to have zip version 3.x +or better to update a Zip64 archive and unzip version 6.x to read a zip64 +archive. + +The default is 0. + +=item C<< TextFlag => 0|1 >> + +This parameter controls the setting of a bit in the zip central header. It +is used to signal that the data stored in the zip file/buffer is probably +text. + +In one-shot mode this flag will be set to true if the Perl C<-T> operator thinks +the file contains text. + +The default is 0. + +=item C<< ExtraFieldLocal => $data >> + +=item C<< ExtraFieldCentral => $data >> + +The C<ExtraFieldLocal> option is used to store additional metadata in the +local header for the zip file/buffer. The C<ExtraFieldCentral> does the +same for the matching central header. + +An extra field consists of zero or more subfields. Each subfield consists +of a two byte header followed by the subfield data. + +The list of subfields can be supplied in any of the following formats + + ExtraFieldLocal => [$id1, $data1, + $id2, $data2, + ... + ] + + ExtraFieldLocal => [ [$id1 => $data1], + [$id2 => $data2], + ... + ] + + ExtraFieldLocal => { $id1 => $data1, + $id2 => $data2, + ... + } + +Where C<$id1>, C<$id2> are two byte subfield ID's. + +If you use the hash syntax, you have no control over the order in which +the ExtraSubFields are stored, plus you cannot have SubFields with +duplicate ID. + +Alternatively the list of subfields can by supplied as a scalar, thus + + ExtraField => $rawdata + +In this case C<IO::Compress::Zip> will check that C<$rawdata> consists of +zero or more conformant sub-fields. + +The Extended Time field (ID "UT"), set using the C<exTime> option, and the +Unix2 extra field (ID "Ux), set using the C<exUnix2> option, are examples +of extra fields. + +If the C<Minimal> option is set to true, this option will be ignored. + +The maximum size of an extra field 65535 bytes. + +=item C<< Minimal => 1|0 >> + +If specified, this option will disable the creation of all extra fields +in the zip local and central headers. So the C<exTime>, C<exUnix2>, +C<exUnixN>, C<ExtraFieldLocal> and C<ExtraFieldCentral> options will +be ignored. + +This parameter defaults to 0. + +=item C<< BlockSize100K => number >> + +Specify the number of 100K blocks bzip2 uses during compression. + +Valid values are from 1 to 9, where 9 is best compression. + +This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored +otherwise. + +The default is 1. + +=item C<< WorkFactor => number >> + +Specifies how much effort bzip2 should take before resorting to a slower +fallback compression algorithm. + +Valid values range from 0 to 250, where 0 means use the default value 30. + +This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored +otherwise. + +The default is 0. + +=item C<< Preset => number >> + +Used to choose the LZMA compression preset. + +Valid values are 0-9 and C<LZMA_PRESET_DEFAULT>. + +0 is the fastest compression with the lowest memory usage and the lowest +compression. + +9 is the slowest compression with the highest memory usage but with the best +compression. + +This option is only valid if the C<Method> is ZIP_CM_LZMA. It is ignored +otherwise. + +Defaults to C<LZMA_PRESET_DEFAULT> (6). + +=item C<< Extreme => 0|1 >> + +Makes LZMA compression a lot slower, but a small compression gain. + +This option is only valid if the C<Method> is ZIP_CM_LZMA. It is ignored +otherwise. + +Defaults to 0. + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::Zip> by default. + + use IO::Compress::Zip qw(:strategy); + use IO::Compress::Zip qw(:constants); + use IO::Compress::Zip qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + +=item C<< Strict => 0|1 >> + +This is a placeholder option. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C<print> built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C<undef> if +unsuccessful. + +=head2 flush + +Usage is + + $z->flush; + $z->flush($flush_type); + +Flushes any pending compressed data to the output file/buffer. + +This method takes an optional parameter, C<$flush_type>, that controls +how the flushing will be carried out. By default the C<$flush_type> +used is C<Z_FINISH>. Other valid values for C<$flush_type> are +C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is +strongly recommended that you only set the C<flush_type> parameter if +you fully understand the implications of what it does - overuse of C<flush> +can seriously degrade the level of compression achieved. See the C<zlib> +documentation for details. + +Returns true on success. + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the C<close> method has been called. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +This method always returns C<undef> when compressing. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Flushes any pending compressed data and then closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Zip object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Compress::Zip +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the options that are available when creating +the C<$z> object. + +See the L</"Constructor Options"> section for more details. + +=head2 deflateParams + +Usage is + + $z->deflateParams + +TODO + +=head1 Importing + +A number of symbolic constants are required by some methods in +C<IO::Compress::Zip>. None are imported by default. + +=over 5 + +=item :all + +Imports C<zip>, C<$ZipError> and all symbolic +constants that can be used by C<IO::Compress::Zip>. Same as doing this + + use IO::Compress::Zip qw(zip $ZipError :constants) ; + +=item :constants + +Import all symbolic constants. Same as doing this + + use IO::Compress::Zip qw(:flush :level :strategy :zip_method) ; + +=item :flush + +These symbolic constants are used by the C<flush> method. + + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + +=item :level + +These symbolic constants are used by the C<Level> option in the constructor. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +=item :strategy + +These symbolic constants are used by the C<Strategy> option in the constructor. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +=item :zip_method + +These symbolic constants are used by the C<Method> option in the +constructor. + + ZIP_CM_STORE + ZIP_CM_DEFLATE + ZIP_CM_BZIP2 + + + + +=back + +=head1 EXAMPLES + +=head2 Apache::GZip Revisited + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +L<http://www.faqs.org/rfcs/rfc1950.html>, +L<http://www.faqs.org/rfcs/rfc1951.html> and +L<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +L<http://www.zlib.org>. + +The primary site for gzip is L<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm new file mode 100644 index 0000000000..7e38f1b9aa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm @@ -0,0 +1,125 @@ +package IO::Compress::Zip::Constants; + +use strict ; +use warnings; + +require Exporter; + +our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS); + +$VERSION = '2.074'; + +@ISA = qw(Exporter); + +@EXPORT= qw( + + ZIP_CM_STORE + ZIP_CM_DEFLATE + ZIP_CM_BZIP2 + ZIP_CM_LZMA + ZIP_CM_PPMD + + ZIP_LOCAL_HDR_SIG + ZIP_DATA_HDR_SIG + ZIP_CENTRAL_HDR_SIG + ZIP_END_CENTRAL_HDR_SIG + ZIP64_END_CENTRAL_REC_HDR_SIG + ZIP64_END_CENTRAL_LOC_HDR_SIG + ZIP64_ARCHIVE_EXTRA_SIG + ZIP64_DIGITAL_SIGNATURE_SIG + + ZIP_GP_FLAG_ENCRYPTED_MASK + ZIP_GP_FLAG_STREAMING_MASK + ZIP_GP_FLAG_PATCHED_MASK + ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK + ZIP_GP_FLAG_LZMA_EOS_PRESENT + ZIP_GP_FLAG_LANGUAGE_ENCODING + + ZIP_EXTRA_ID_ZIP64 + ZIP_EXTRA_ID_EXT_TIMESTAMP + ZIP_EXTRA_ID_INFO_ZIP_UNIX2 + ZIP_EXTRA_ID_INFO_ZIP_UNIXN + ZIP_EXTRA_ID_INFO_ZIP_Upath + ZIP_EXTRA_ID_INFO_ZIP_Ucom + ZIP_EXTRA_ID_JAVA_EXE + + ZIP_OS_CODE_UNIX + ZIP_OS_CODE_DEFAULT + + ZIP_IFA_TEXT_MASK + + %ZIP_CM_MIN_VERSIONS + ZIP64_MIN_VERSION + + ZIP_A_RONLY + ZIP_A_HIDDEN + ZIP_A_SYSTEM + ZIP_A_LABEL + ZIP_A_DIR + ZIP_A_ARCHIVE + ); + +# Compression types supported +use constant ZIP_CM_STORE => 0 ; +use constant ZIP_CM_DEFLATE => 8 ; +use constant ZIP_CM_BZIP2 => 12 ; +use constant ZIP_CM_LZMA => 14 ; # Not Supported yet +use constant ZIP_CM_PPMD => 98 ; # Not Supported yet + +# General Purpose Flag +use constant ZIP_GP_FLAG_ENCRYPTED_MASK => (1 << 0) ; +use constant ZIP_GP_FLAG_STREAMING_MASK => (1 << 3) ; +use constant ZIP_GP_FLAG_PATCHED_MASK => (1 << 5) ; +use constant ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK => (1 << 6) ; +use constant ZIP_GP_FLAG_LZMA_EOS_PRESENT => (1 << 1) ; +use constant ZIP_GP_FLAG_LANGUAGE_ENCODING => (1 << 11) ; + +# Internal File Attributes +use constant ZIP_IFA_TEXT_MASK => 1; + +# Signatures for each of the headers +use constant ZIP_LOCAL_HDR_SIG => 0x04034b50; +use constant ZIP_DATA_HDR_SIG => 0x08074b50; +use constant packed_ZIP_DATA_HDR_SIG => pack "V", ZIP_DATA_HDR_SIG; +use constant ZIP_CENTRAL_HDR_SIG => 0x02014b50; +use constant ZIP_END_CENTRAL_HDR_SIG => 0x06054b50; +use constant ZIP64_END_CENTRAL_REC_HDR_SIG => 0x06064b50; +use constant ZIP64_END_CENTRAL_LOC_HDR_SIG => 0x07064b50; +use constant ZIP64_ARCHIVE_EXTRA_SIG => 0x08064b50; +use constant ZIP64_DIGITAL_SIGNATURE_SIG => 0x05054b50; + +use constant ZIP_OS_CODE_UNIX => 3; +use constant ZIP_OS_CODE_DEFAULT => 3; + +# Extra Field ID's +use constant ZIP_EXTRA_ID_ZIP64 => pack "v", 1; +use constant ZIP_EXTRA_ID_EXT_TIMESTAMP => "UT"; +use constant ZIP_EXTRA_ID_INFO_ZIP_UNIX2 => "Ux"; +use constant ZIP_EXTRA_ID_INFO_ZIP_UNIXN => "ux"; +use constant ZIP_EXTRA_ID_INFO_ZIP_Upath => "up"; +use constant ZIP_EXTRA_ID_INFO_ZIP_Ucom => "uc"; +use constant ZIP_EXTRA_ID_JAVA_EXE => pack "v", 0xCAFE; + +# DOS Attributes +use constant ZIP_A_RONLY => 0x01; +use constant ZIP_A_HIDDEN => 0x02; +use constant ZIP_A_SYSTEM => 0x04; +use constant ZIP_A_LABEL => 0x08; +use constant ZIP_A_DIR => 0x10; +use constant ZIP_A_ARCHIVE => 0x20; + +use constant ZIP64_MIN_VERSION => 45; + +%ZIP_CM_MIN_VERSIONS = ( + ZIP_CM_STORE() => 20, + ZIP_CM_DEFLATE() => 20, + ZIP_CM_BZIP2() => 46, + ZIP_CM_LZMA() => 63, + ZIP_CM_PPMD() => 63, + ); + + +1; + +__END__ + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zlib/Constants.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zlib/Constants.pm new file mode 100644 index 0000000000..02d8d36517 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zlib/Constants.pm @@ -0,0 +1,77 @@ + +package IO::Compress::Zlib::Constants ; + +use strict ; +use warnings; +use bytes; + +require Exporter; + +our ($VERSION, @ISA, @EXPORT); + +$VERSION = '2.074'; + +@ISA = qw(Exporter); + +@EXPORT= qw( + + ZLIB_HEADER_SIZE + ZLIB_TRAILER_SIZE + + ZLIB_CMF_CM_OFFSET + ZLIB_CMF_CM_BITS + ZLIB_CMF_CM_DEFLATED + + ZLIB_CMF_CINFO_OFFSET + ZLIB_CMF_CINFO_BITS + ZLIB_CMF_CINFO_MAX + + ZLIB_FLG_FCHECK_OFFSET + ZLIB_FLG_FCHECK_BITS + + ZLIB_FLG_FDICT_OFFSET + ZLIB_FLG_FDICT_BITS + + ZLIB_FLG_LEVEL_OFFSET + ZLIB_FLG_LEVEL_BITS + + ZLIB_FLG_LEVEL_FASTEST + ZLIB_FLG_LEVEL_FAST + ZLIB_FLG_LEVEL_DEFAULT + ZLIB_FLG_LEVEL_SLOWEST + + ZLIB_FDICT_SIZE + + ); + +# Constant names derived from RFC1950 + +use constant ZLIB_HEADER_SIZE => 2; +use constant ZLIB_TRAILER_SIZE => 4; + +use constant ZLIB_CMF_CM_OFFSET => 0; +use constant ZLIB_CMF_CM_BITS => 0xF ; # 0b1111 +use constant ZLIB_CMF_CM_DEFLATED => 8; + +use constant ZLIB_CMF_CINFO_OFFSET => 4; +use constant ZLIB_CMF_CINFO_BITS => 0xF ; # 0b1111; +use constant ZLIB_CMF_CINFO_MAX => 7; + +use constant ZLIB_FLG_FCHECK_OFFSET => 0; +use constant ZLIB_FLG_FCHECK_BITS => 0x1F ; # 0b11111; + +use constant ZLIB_FLG_FDICT_OFFSET => 5; +use constant ZLIB_FLG_FDICT_BITS => 0x1 ; # 0b1; + +use constant ZLIB_FLG_LEVEL_OFFSET => 6; +use constant ZLIB_FLG_LEVEL_BITS => 0x3 ; # 0b11; + +use constant ZLIB_FLG_LEVEL_FASTEST => 0; +use constant ZLIB_FLG_LEVEL_FAST => 1; +use constant ZLIB_FLG_LEVEL_DEFAULT => 2; +use constant ZLIB_FLG_LEVEL_SLOWEST => 3; + +use constant ZLIB_FDICT_SIZE => 4; + + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm new file mode 100644 index 0000000000..f710309e7b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm @@ -0,0 +1,229 @@ +package IO::Compress::Zlib::Extra; + +require 5.006 ; + +use strict ; +use warnings; +use bytes; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); + +$VERSION = '2.074'; + +use IO::Compress::Gzip::Constants 2.074 ; + +sub ExtraFieldError +{ + return $_[0]; + return "Error with ExtraField Parameter: $_[0]" ; +} + +sub validateExtraFieldPair +{ + my $pair = shift ; + my $strict = shift; + my $gzipMode = shift ; + + return ExtraFieldError("Not an array ref") + unless ref $pair && ref $pair eq 'ARRAY'; + + return ExtraFieldError("SubField must have two parts") + unless @$pair == 2 ; + + return ExtraFieldError("SubField ID is a reference") + if ref $pair->[0] ; + + return ExtraFieldError("SubField Data is a reference") + if ref $pair->[1] ; + + # ID is exactly two chars + return ExtraFieldError("SubField ID not two chars long") + unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ; + + # Check that the 2nd byte of the ID isn't 0 + return ExtraFieldError("SubField ID 2nd byte is 0x00") + if $strict && $gzipMode && substr($pair->[0], 1, 1) eq "\x00" ; + + return ExtraFieldError("SubField Data too long") + if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ; + + + return undef ; +} + +sub parseRawExtra +{ + my $data = shift ; + my $extraRef = shift; + my $strict = shift; + my $gzipMode = shift ; + + #my $lax = shift ; + + #return undef + # if $lax ; + + my $XLEN = length $data ; + + return ExtraFieldError("Too Large") + if $XLEN > GZIP_FEXTRA_MAX_SIZE; + + my $offset = 0 ; + while ($offset < $XLEN) { + + return ExtraFieldError("Truncated in FEXTRA Body Section") + if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; + + my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); + $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; + + my $subLen = unpack("v", substr($data, $offset, + GZIP_FEXTRA_SUBFIELD_LEN_SIZE)); + $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ; + + return ExtraFieldError("Truncated in FEXTRA Body Section") + if $offset + $subLen > $XLEN ; + + my $bad = validateExtraFieldPair( [$id, + substr($data, $offset, $subLen)], + $strict, $gzipMode ); + return $bad if $bad ; + push @$extraRef, [$id => substr($data, $offset, $subLen)] + if defined $extraRef;; + + $offset += $subLen ; + } + + + return undef ; +} + +sub findID +{ + my $id_want = shift ; + my $data = shift; + + my $XLEN = length $data ; + + my $offset = 0 ; + while ($offset < $XLEN) { + + return undef + if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; + + my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); + $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; + + my $subLen = unpack("v", substr($data, $offset, + GZIP_FEXTRA_SUBFIELD_LEN_SIZE)); + $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ; + + return undef + if $offset + $subLen > $XLEN ; + + return substr($data, $offset, $subLen) + if $id eq $id_want ; + + $offset += $subLen ; + } + + return undef ; +} + + +sub mkSubField +{ + my $id = shift ; + my $data = shift ; + + return $id . pack("v", length $data) . $data ; +} + +sub parseExtraField +{ + my $dataRef = $_[0]; + my $strict = $_[1]; + my $gzipMode = $_[2]; + #my $lax = @_ == 2 ? $_[1] : 1; + + + # ExtraField can be any of + # + # -ExtraField => $data + # + # -ExtraField => [$id1, $data1, + # $id2, $data2] + # ... + # ] + # + # -ExtraField => [ [$id1 => $data1], + # [$id2 => $data2], + # ... + # ] + # + # -ExtraField => { $id1 => $data1, + # $id2 => $data2, + # ... + # } + + if ( ! ref $dataRef ) { + + return undef + if ! $strict; + + return parseRawExtra($dataRef, undef, 1, $gzipMode); + } + + my $data = $dataRef; + my $out = '' ; + + if (ref $data eq 'ARRAY') { + if (ref $data->[0]) { + + foreach my $pair (@$data) { + return ExtraFieldError("Not list of lists") + unless ref $pair eq 'ARRAY' ; + + my $bad = validateExtraFieldPair($pair, $strict, $gzipMode) ; + return $bad if $bad ; + + $out .= mkSubField(@$pair); + } + } + else { + return ExtraFieldError("Not even number of elements") + unless @$data % 2 == 0; + + for (my $ix = 0; $ix <= @$data -1 ; $ix += 2) { + my $bad = validateExtraFieldPair([$data->[$ix], + $data->[$ix+1]], + $strict, $gzipMode) ; + return $bad if $bad ; + + $out .= mkSubField($data->[$ix], $data->[$ix+1]); + } + } + } + elsif (ref $data eq 'HASH') { + while (my ($id, $info) = each %$data) { + my $bad = validateExtraFieldPair([$id, $info], $strict, $gzipMode); + return $bad if $bad ; + + $out .= mkSubField($id, $info); + } + } + else { + return ExtraFieldError("Not a scalar, array ref or hash ref") ; + } + + return ExtraFieldError("Too Large") + if length $out > GZIP_FEXTRA_MAX_SIZE; + + $_[0] = $out ; + + return undef; +} + +1; + +__END__ diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Dir.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Dir.pm new file mode 100644 index 0000000000..e583fd389a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Dir.pm @@ -0,0 +1,247 @@ +# IO::Dir.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Dir; + +use 5.008_001; + +use strict; +use Carp; +use Symbol; +use Exporter; +use IO::File; +use Tie::Hash; +use File::stat; +use File::Spec; + +our @ISA = qw(Tie::Hash Exporter); +our $VERSION = "1.39"; + +our @EXPORT_OK = qw(DIR_UNLINK); + +sub DIR_UNLINK () { 1 } + +sub new { + @_ >= 1 && @_ <= 2 or croak 'usage: IO::Dir->new([DIRNAME])'; + my $class = shift; + my $dh = gensym; + if (@_) { + IO::Dir::open($dh, $_[0]) + or return undef; + } + bless $dh, $class; +} + +sub DESTROY { + my ($dh) = @_; + local($., $@, $!, $^E, $?); + no warnings 'io'; + closedir($dh); +} + +sub open { + @_ == 2 or croak 'usage: $dh->open(DIRNAME)'; + my ($dh, $dirname) = @_; + return undef + unless opendir($dh, $dirname); + # a dir name should always have a ":" in it; assume dirname is + # in current directory + $dirname = ':' . $dirname if ( ($^O eq 'MacOS') && ($dirname !~ /:/) ); + ${*$dh}{io_dir_path} = $dirname; + 1; +} + +sub close { + @_ == 1 or croak 'usage: $dh->close()'; + my ($dh) = @_; + closedir($dh); +} + +sub read { + @_ == 1 or croak 'usage: $dh->read()'; + my ($dh) = @_; + readdir($dh); +} + +sub seek { + @_ == 2 or croak 'usage: $dh->seek(POS)'; + my ($dh,$pos) = @_; + seekdir($dh,$pos); +} + +sub tell { + @_ == 1 or croak 'usage: $dh->tell()'; + my ($dh) = @_; + telldir($dh); +} + +sub rewind { + @_ == 1 or croak 'usage: $dh->rewind()'; + my ($dh) = @_; + rewinddir($dh); +} + +sub TIEHASH { + my($class,$dir,$options) = @_; + + my $dh = $class->new($dir) + or return undef; + + $options ||= 0; + + ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK; + $dh; +} + +sub FIRSTKEY { + my($dh) = @_; + $dh->rewind; + scalar $dh->read; +} + +sub NEXTKEY { + my($dh) = @_; + scalar $dh->read; +} + +sub EXISTS { + my($dh,$key) = @_; + -e File::Spec->catfile(${*$dh}{io_dir_path}, $key); +} + +sub FETCH { + my($dh,$key) = @_; + &lstat(File::Spec->catfile(${*$dh}{io_dir_path}, $key)); +} + +sub STORE { + my($dh,$key,$data) = @_; + my($atime,$mtime) = ref($data) ? @$data : ($data,$data); + my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key); + unless(-e $file) { + my $io = IO::File->new($file,O_CREAT | O_RDWR); + $io->close if $io; + } + utime($atime,$mtime, $file); +} + +sub DELETE { + my($dh,$key) = @_; + + # Only unlink if unlink-ing is enabled + return 0 + unless ${*$dh}{io_dir_unlink}; + + my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key); + + -d $file + ? rmdir($file) + : unlink($file); +} + +1; + +__END__ + +=head1 NAME + +IO::Dir - supply object methods for directory handles + +=head1 SYNOPSIS + + use IO::Dir; + $d = IO::Dir->new("."); + if (defined $d) { + while (defined($_ = $d->read)) { something($_); } + $d->rewind; + while (defined($_ = $d->read)) { something_else($_); } + undef $d; + } + + tie %dir, 'IO::Dir', "."; + foreach (keys %dir) { + print $_, " " , $dir{$_}->size,"\n"; + } + +=head1 DESCRIPTION + +The C<IO::Dir> package provides two interfaces to perl's directory reading +routines. + +The first interface is an object approach. C<IO::Dir> provides an object +constructor and methods, which are just wrappers around perl's built in +directory reading routines. + +=over 4 + +=item new ( [ DIRNAME ] ) + +C<new> is the constructor for C<IO::Dir> objects. It accepts one optional +argument which, if given, C<new> will pass to C<open> + +=back + +The following methods are wrappers for the directory related functions built +into perl (the trailing 'dir' has been removed from the names). See L<perlfunc> +for details of these functions. + +=over 4 + +=item open ( DIRNAME ) + +=item read () + +=item seek ( POS ) + +=item tell () + +=item rewind () + +=item close () + +=back + +C<IO::Dir> also provides an interface to reading directories via a tied +hash. The tied hash extends the interface beyond just the directory +reading routines by the use of C<lstat>, from the C<File::stat> package, +C<unlink>, C<rmdir> and C<utime>. + +=over 4 + +=item tie %hash, 'IO::Dir', DIRNAME [, OPTIONS ] + +=back + +The keys of the hash will be the names of the entries in the directory. +Reading a value from the hash will be the result of calling +C<File::stat::lstat>. Deleting an element from the hash will +delete the corresponding file or subdirectory, +provided that C<DIR_UNLINK> is included in the C<OPTIONS>. + +Assigning to an entry in the hash will cause the time stamps of the file +to be modified. If the file does not exist then it will be created. Assigning +a single integer to a hash element will cause both the access and +modification times to be changed to that value. Alternatively a reference to +an array of two values can be passed. The first array element will be used to +set the access time and the second element will be used to set the modification +time. + +=head1 SEE ALSO + +L<File::stat> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perlbug@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-2003 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/File.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/File.pm new file mode 100644 index 0000000000..55c5e20d29 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/File.pm @@ -0,0 +1,202 @@ +# + +package IO::File; + +=head1 NAME + +IO::File - supply object methods for filehandles + +=head1 SYNOPSIS + + use IO::File; + + $fh = IO::File->new(); + if ($fh->open("< file")) { + print <$fh>; + $fh->close; + } + + $fh = IO::File->new("> file"); + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = IO::File->new("file", "r"); + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + + $fh = IO::File->new("file", O_WRONLY|O_APPEND); + if (defined $fh) { + print $fh "corge\n"; + + $pos = $fh->getpos; + $fh->setpos($pos); + + undef $fh; # automatically closes the file + } + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends +these classes with methods that are specific to file handles. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( FILENAME [,MODE [,PERMS]] ) + +Creates an C<IO::File>. If it receives any parameters, they are passed to +the method C<open>; if the open fails, the object is destroyed. Otherwise, +it is returned to the caller. + +=item new_tmpfile + +Creates an C<IO::File> opened for read/write on a newly created temporary +file. On systems where this is possible, the temporary file is anonymous +(i.e. it is unlinked after creation, but held open). If the temporary +file cannot be created or opened, the C<IO::File> object is destroyed. +Otherwise, it is returned to the caller. + +=back + +=head1 METHODS + +=over 4 + +=item open( FILENAME [,MODE [,PERMS]] ) + +=item open( FILENAME, IOLAYERS ) + +C<open> accepts one, two or three parameters. With one parameter, +it is just a front end for the built-in C<open> function. With two or three +parameters, the first parameter is a filename that may include +whitespace or other special characters, and the second parameter is +the open mode, optionally followed by a file permission value. + +If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.) +or an ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator (but protects any special characters). + +If C<IO::File::open> is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C<sysopen> operator. +The permissions default to 0666. + +If C<IO::File::open> is given a mode that includes the C<:> character, +it passes all the three arguments to the three-argument C<open> operator. + +For convenience, C<IO::File> exports the O_XXX constants from the +Fcntl module, if this module is available. + +=item binmode( [LAYER] ) + +C<binmode> sets C<binmode> on the underlying C<IO> object, as documented +in C<perldoc -f binmode>. + +C<binmode> accepts one optional parameter, which is the layer to be +passed on to the C<binmode> call. + +=back + +=head1 NOTE + +Some operating systems may perform C<IO::File::new()> or C<IO::File::open()> +on a directory without errors. This behavior is not portable and not +suggested for use. Using C<opendir()> and C<readdir()> or C<IO::Dir> are +suggested instead. + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle>, +L<IO::Seekable>, +L<IO::Dir> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. + +=cut + +use 5.008_001; +use strict; +use Carp; +use Symbol; +use SelectSaver; +use IO::Seekable; + +require Exporter; + +our @ISA = qw(IO::Handle IO::Seekable Exporter); + +our $VERSION = "1.39"; + +our @EXPORT = @IO::Seekable::EXPORT; + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + +################################################ +## Constructor +## + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::File"; + @_ >= 0 && @_ <= 3 + or croak "usage: $class->new([FILENAME [,MODE [,PERMS]]])"; + my $fh = $class->SUPER::new(); + if (@_) { + $fh->open(@_) + or return undef; + } + $fh; +} + +################################################ +## Open +## + +sub open { + @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; + my ($fh, $file) = @_; + if (@_ > 2) { + my ($mode, $perms) = @_[2, 3]; + if ($mode =~ /^\d+$/) { + defined $perms or $perms = 0666; + return sysopen($fh, $file, $mode, $perms); + } elsif ($mode =~ /:/) { + return open($fh, $mode, $file) if @_ == 3; + croak 'usage: $fh->open(FILENAME, IOLAYERS)'; + } else { + return open($fh, IO::Handle::_open_mode_string($mode), $file); + } + } + open($fh, $file); +} + +################################################ +## Binmode +## + +sub binmode { + ( @_ == 1 or @_ == 2 ) or croak 'usage $fh->binmode([LAYER])'; + + my($fh, $layer) = @_; + + return binmode $$fh unless $layer; + return binmode $$fh, $layer; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Handle.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Handle.pm new file mode 100644 index 0000000000..60750575c8 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Handle.pm @@ -0,0 +1,651 @@ +package IO::Handle; + +=head1 NAME + +IO::Handle - supply object methods for I/O handles + +=head1 SYNOPSIS + + use IO::Handle; + + $io = IO::Handle->new(); + if ($io->fdopen(fileno(STDIN),"r")) { + print $io->getline; + $io->close; + } + + $io = IO::Handle->new(); + if ($io->fdopen(fileno(STDOUT),"w")) { + $io->print("Some text\n"); + } + + # setvbuf is not available by default on Perls 5.8.0 and later. + use IO::Handle '_IOLBF'; + $io->setvbuf($buffer_var, _IOLBF, 1024); + + undef $io; # automatically closes the file if it's open + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C<IO::Handle> is the base class for all other IO handle classes. It is +not intended that objects of C<IO::Handle> would be created directly, +but instead C<IO::Handle> is inherited from by several other classes +in the IO hierarchy. + +If you are reading this documentation, looking for a replacement for +the C<FileHandle> package, then I suggest you read the documentation +for C<IO::File> too. + +=head1 CONSTRUCTOR + +=over 4 + +=item new () + +Creates a new C<IO::Handle> object. + +=item new_from_fd ( FD, MODE ) + +Creates an C<IO::Handle> like C<new> does. +It requires two parameters, which are passed to the method C<fdopen>; +if the fdopen fails, the object is destroyed. Otherwise, it is returned +to the caller. + +=back + +=head1 METHODS + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Handle> methods, which are just front ends for the +corresponding built-in functions: + + $io->close + $io->eof + $io->fcntl( FUNCTION, SCALAR ) + $io->fileno + $io->format_write( [FORMAT_NAME] ) + $io->getc + $io->ioctl( FUNCTION, SCALAR ) + $io->read ( BUF, LEN, [OFFSET] ) + $io->print ( ARGS ) + $io->printf ( FMT, [ARGS] ) + $io->say ( ARGS ) + $io->stat + $io->sysread ( BUF, LEN, [OFFSET] ) + $io->syswrite ( BUF, [LEN, [OFFSET]] ) + $io->truncate ( LEN ) + +See L<perlvar> for complete descriptions of each of the following +supported C<IO::Handle> methods. All of them return the previous +value of the attribute and takes an optional single argument that when +given will set the value. If no argument is given the previous value +is unchanged (except for $io->autoflush will actually turn ON +autoflush by default). + + $io->autoflush ( [BOOL] ) $| + $io->format_page_number( [NUM] ) $% + $io->format_lines_per_page( [NUM] ) $= + $io->format_lines_left( [NUM] ) $- + $io->format_name( [STR] ) $~ + $io->format_top_name( [STR] ) $^ + $io->input_line_number( [NUM]) $. + +The following methods are not supported on a per-filehandle basis. + + IO::Handle->format_line_break_characters( [STR] ) $: + IO::Handle->format_formfeed( [STR]) $^L + IO::Handle->output_field_separator( [STR] ) $, + IO::Handle->output_record_separator( [STR] ) $\ + + IO::Handle->input_record_separator( [STR] ) $/ + +Furthermore, for doing normal I/O you might need these: + +=over 4 + +=item $io->fdopen ( FD, MODE ) + +C<fdopen> is like an ordinary C<open> except that its first parameter +is not a filename but rather a file handle name, an IO::Handle object, +or a file descriptor number. (For the documentation of the C<open> +method, see L<IO::File>.) + +=item $io->opened + +Returns true if the object is currently a valid file descriptor, false +otherwise. + +=item $io->getline + +This works like <$io> described in L<perlop/"I/O Operators"> +except that it's more readable and can be safely called in a +list context but still returns just one line. If used as the conditional +within a C<while> or C-style C<for> loop, however, you will need to +emulate the functionality of <$io> with C<< defined($_ = $io->getline) >>. + +=item $io->getlines + +This works like <$io> when called in a list context to read all +the remaining lines in a file, except that it's more readable. +It will also croak() if accidentally called in a scalar context. + +=item $io->ungetc ( ORD ) + +Pushes a character with the given ordinal value back onto the given +handle's input stream. Only one character of pushback per handle is +guaranteed. + +=item $io->write ( BUF, LEN [, OFFSET ] ) + +This C<write> is somewhat like C<write> found in C, in that it is the +opposite of read. The wrapper for the perl C<write> function is +called C<format_write>. However, whilst the C C<write> function returns +the number of bytes written, this C<write> function simply returns true +if successful (like C<print>). A more C-like C<write> is C<syswrite> +(see above). + +=item $io->error + +Returns a true value if the given handle has experienced any errors +since it was opened or since the last call to C<clearerr>, or if the +handle is invalid. It only returns false for a valid handle with no +outstanding errors. + +=item $io->clearerr + +Clear the given handle's error indicator. Returns -1 if the handle is +invalid, 0 otherwise. + +=item $io->sync + +C<sync> synchronizes a file's in-memory state with that on the +physical medium. C<sync> does not operate at the perlio api level, but +operates on the file descriptor (similar to sysread, sysseek and +systell). This means that any data held at the perlio api level will not +be synchronized. To synchronize data that is buffered at the perlio api +level you must use the flush method. C<sync> is not implemented on all +platforms. Returns "0 but true" on success, C<undef> on error, C<undef> +for an invalid handle. See L<fsync(3c)>. + +=item $io->flush + +C<flush> causes perl to flush any buffered data at the perlio api level. +Any unread data in the buffer will be discarded, and any unwritten data +will be written to the underlying file descriptor. Returns "0 but true" +on success, C<undef> on error. + +=item $io->printflush ( ARGS ) + +Turns on autoflush, print ARGS and then restores the autoflush status of the +C<IO::Handle> object. Returns the return value from print. + +=item $io->blocking ( [ BOOL ] ) + +If called with an argument C<blocking> will turn on non-blocking IO if +C<BOOL> is false, and turn it off if C<BOOL> is true. + +C<blocking> will return the value of the previous setting, or the +current setting if C<BOOL> is not given. + +If an error occurs C<blocking> will return undef and C<$!> will be set. + +=back + + +If the C functions setbuf() and/or setvbuf() are available, then +C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering +policy for an IO::Handle. The calling sequences for the Perl functions +are the same as their C counterparts--including the constants C<_IOFBF>, +C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter +specifies a scalar variable to use as a buffer. You should only +change the buffer before any I/O, or immediately after calling flush. + +WARNING: The IO::Handle::setvbuf() is not available by default on +Perls 5.8.0 and later because setvbuf() is rather specific to using +the stdio library, while Perl prefers the new perlio subsystem instead. + +WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not +be modified> in any way until the IO::Handle is closed or C<setbuf> or +C<setvbuf> is called again, or memory corruption may result! Remember that +the order of global destruction is undefined, so even if your buffer +variable remains in scope until program termination, it may be undefined +before the file IO::Handle is closed. Note that you need to import the +constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf +returns nothing. setvbuf returns "0 but true", on success, C<undef> on +failure. + +Lastly, there is a special method for working under B<-T> and setuid/gid +scripts: + +=over 4 + +=item $io->untaint + +Marks the object as taint-clean, and as such data read from it will also +be considered taint-clean. Note that this is a very trusting action to +take, and appropriate consideration for the data source and potential +vulnerability should be kept in mind. Returns 0 on success, -1 if setting +the taint-clean flag failed. (eg invalid handle) + +=back + +=head1 NOTE + +An C<IO::Handle> object is a reference to a symbol/GLOB reference (see +the C<Symbol> package). Some modules that +inherit from C<IO::Handle> may want to keep object related variables +in the hash table part of the GLOB. In an attempt to prevent modules +trampling on each other I propose the that any such module should prefix +its variables with its own name separated by _'s. For example the IO::Socket +module keeps a C<timeout> variable in 'io_socket_timeout'. + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::File> + +=head1 BUGS + +Due to backwards compatibility, all filehandles resemble objects +of class C<IO::Handle>, or actually classes derived from that class. +They actually aren't. Which means you can't derive your own +class from C<IO::Handle> and inherit those methods. + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +=cut + +use 5.008_001; +use strict; +use Carp; +use Symbol; +use SelectSaver; +use IO (); # Load the XS module + +require Exporter; +our @ISA = qw(Exporter); + +our $VERSION = "1.39"; + +our @EXPORT_OK = qw( + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + format_write + + print + printf + say + getline + getlines + + printflush + flush + + SEEK_SET + SEEK_CUR + SEEK_END + _IOFBF + _IOLBF + _IONBF +); + +################################################ +## Constructors, destructors. +## + +sub new { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + if (@_ != 1) { + # Since perl will automatically require IO::File if needed, but + # also initialises IO::File's @ISA as part of the core we must + # ensure IO::File is loaded if IO::Handle is. This avoids effect- + # ively "half-loading" IO::File. + if ($] > 5.013 && $class eq 'IO::File' && !$INC{"IO/File.pm"}) { + require IO::File; + shift; + return IO::File::->new(@_); + } + croak "usage: $class->new()"; + } + my $io = gensym; + bless $io, $class; +} + +sub new_from_fd { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 3 or croak "usage: $class->new_from_fd(FD, MODE)"; + my $io = gensym; + shift; + IO::Handle::fdopen($io, @_) + or return undef; + bless $io, $class; +} + +# +# There is no need for DESTROY to do anything, because when the +# last reference to an IO object is gone, Perl automatically +# closes its associated files (if any). However, to avoid any +# attempts to autoload DESTROY, we here define it to do nothing. +# +sub DESTROY {} + + +################################################ +## Open and close. +## + +sub _open_mode_string { + my ($mode) = @_; + $mode =~ /^\+?(<|>>?)$/ + or $mode =~ s/^r(\+?)$/$1</ + or $mode =~ s/^w(\+?)$/$1>/ + or $mode =~ s/^a(\+?)$/$1>>/ + or croak "IO::Handle: bad open mode: $mode"; + $mode; +} + +sub fdopen { + @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)'; + my ($io, $fd, $mode) = @_; + local(*GLOB); + + if (ref($fd) && "$fd" =~ /GLOB\(/o) { + # It's a glob reference; Alias it as we cannot get name of anon GLOBs + my $n = qualify(*GLOB); + *GLOB = *{*$fd}; + $fd = $n; + } elsif ($fd =~ m#^\d+$#) { + # It's an FD number; prefix with "=". + $fd = "=$fd"; + } + + open($io, _open_mode_string($mode) . '&' . $fd) + ? $io : undef; +} + +sub close { + @_ == 1 or croak 'usage: $io->close()'; + my($io) = @_; + + close($io); +} + +################################################ +## Normal I/O functions. +## + +# flock +# select + +sub opened { + @_ == 1 or croak 'usage: $io->opened()'; + defined fileno($_[0]); +} + +sub fileno { + @_ == 1 or croak 'usage: $io->fileno()'; + fileno($_[0]); +} + +sub getc { + @_ == 1 or croak 'usage: $io->getc()'; + getc($_[0]); +} + +sub eof { + @_ == 1 or croak 'usage: $io->eof()'; + eof($_[0]); +} + +sub print { + @_ or croak 'usage: $io->print(ARGS)'; + my $this = shift; + print $this @_; +} + +sub printf { + @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])'; + my $this = shift; + printf $this @_; +} + +sub say { + @_ or croak 'usage: $io->say(ARGS)'; + my $this = shift; + local $\ = "\n"; + print $this @_; +} + +# Special XS wrapper to make them inherit lexical hints from the caller. +_create_getline_subs( <<'END' ) or die $@; +sub getline { + @_ == 1 or croak 'usage: $io->getline()'; + my $this = shift; + return scalar <$this>; +} + +sub getlines { + @_ == 1 or croak 'usage: $io->getlines()'; + wantarray or + croak 'Can\'t call $io->getlines in a scalar context, use $io->getline'; + my $this = shift; + return <$this>; +} +1; # return true for error checking +END + +*gets = \&getline; # deprecated + +sub truncate { + @_ == 2 or croak 'usage: $io->truncate(LEN)'; + truncate($_[0], $_[1]); +} + +sub read { + @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])'; + read($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub sysread { + @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])'; + sysread($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub write { + @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])'; + local($\) = ""; + $_[2] = length($_[1]) unless defined $_[2]; + print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); +} + +sub syswrite { + @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; + if (defined($_[2])) { + syswrite($_[0], $_[1], $_[2], $_[3] || 0); + } else { + syswrite($_[0], $_[1]); + } +} + +sub stat { + @_ == 1 or croak 'usage: $io->stat()'; + stat($_[0]); +} + +################################################ +## State modification functions. +## + +sub autoflush { + my $old = SelectSaver->new(qualify($_[0], caller)); + my $prev = $|; + $| = @_ > 1 ? $_[1] : 1; + $prev; +} + +sub output_field_separator { + carp "output_field_separator is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $,; + $, = $_[1] if @_ > 1; + $prev; +} + +sub output_record_separator { + carp "output_record_separator is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $\; + $\ = $_[1] if @_ > 1; + $prev; +} + +sub input_record_separator { + carp "input_record_separator is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $/; + $/ = $_[1] if @_ > 1; + $prev; +} + +sub input_line_number { + local $.; + () = tell qualify($_[0], caller) if ref($_[0]); + my $prev = $.; + $. = $_[1] if @_ > 1; + $prev; +} + +sub format_page_number { + my $old; + $old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]); + my $prev = $%; + $% = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_per_page { + my $old; + $old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]); + my $prev = $=; + $= = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_left { + my $old; + $old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]); + my $prev = $-; + $- = $_[1] if @_ > 1; + $prev; +} + +sub format_name { + my $old; + $old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]); + my $prev = $~; + $~ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_top_name { + my $old; + $old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]); + my $prev = $^; + $^ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_line_break_characters { + carp "format_line_break_characters is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $:; + $: = $_[1] if @_ > 1; + $prev; +} + +sub format_formfeed { + carp "format_formfeed is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $^L; + $^L = $_[1] if @_ > 1; + $prev; +} + +sub formline { + my $io = shift; + my $picture = shift; + local($^A) = $^A; + local($\) = ""; + formline($picture, @_); + print $io $^A; +} + +sub format_write { + @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )'; + if (@_ == 2) { + my ($io, $fmt) = @_; + my $oldfmt = $io->format_name(qualify($fmt,caller)); + CORE::write($io); + $io->format_name($oldfmt); + } else { + CORE::write($_[0]); + } +} + +sub fcntl { + @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );'; + my ($io, $op) = @_; + return fcntl($io, $op, $_[2]); +} + +sub ioctl { + @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );'; + my ($io, $op) = @_; + return ioctl($io, $op, $_[2]); +} + +# this sub is for compatibility with older releases of IO that used +# a sub called constant to determine if a constant existed -- GMB +# +# The SEEK_* and _IO?BF constants were the only constants at that time +# any new code should just check defined(&CONSTANT_NAME) + +sub constant { + no strict 'refs'; + my $name = shift; + (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name}) + ? &{$name}() : undef; +} + + +# so that flush.pl can be deprecated + +sub printflush { + my $io = shift; + my $old; + $old = SelectSaver->new(qualify($io, caller)) if ref($io); + local $| = 1; + if(ref($io)) { + print $io @_; + } + else { + print @_; + } +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Pipe.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Pipe.pm new file mode 100644 index 0000000000..f24220f11f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Pipe.pm @@ -0,0 +1,256 @@ +# IO::Pipe.pm +# +# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Pipe; + +use 5.008_001; + +use IO::Handle; +use strict; +use Carp; +use Symbol; + +our $VERSION = "1.39"; + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::Pipe"; + @_ == 0 || @_ == 2 or croak "usage: $class->([READFH, WRITEFH])"; + + my $me = bless gensym(), $class; + + my($readfh,$writefh) = @_ ? @_ : $me->handles; + + pipe($readfh, $writefh) + or return undef; + + @{*$me} = ($readfh, $writefh); + + $me; +} + +sub handles { + @_ == 1 or croak 'usage: $pipe->handles()'; + (IO::Pipe::End->new(), IO::Pipe::End->new()); +} + +my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32'; + +sub _doit { + my $me = shift; + my $rw = shift; + + my $pid = $do_spawn ? 0 : fork(); + + if($pid) { # Parent + return $pid; + } + elsif(defined $pid) { # Child or spawn + my $fh; + my $io = $rw ? \*STDIN : \*STDOUT; + my ($mode, $save) = $rw ? "r" : "w"; + if ($do_spawn) { + require Fcntl; + $save = IO::Handle->new_from_fd($io, $mode); + my $handle = shift; + # Close in child: + unless ($^O eq 'MSWin32') { + fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!"; + } + $fh = $rw ? ${*$me}[0] : ${*$me}[1]; + } else { + shift; + $fh = $rw ? $me->reader() : $me->writer(); # close the other end + } + bless $io, "IO::Handle"; + $io->fdopen($fh, $mode); + $fh->close; + + if ($do_spawn) { + $pid = eval { system 1, @_ }; # 1 == P_NOWAIT + my $err = $!; + + $io->fdopen($save, $mode); + $save->close or croak "Cannot close $!"; + croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0; + return $pid; + } else { + exec @_ or + croak "IO::Pipe: Cannot exec: $!"; + } + } + else { + croak "IO::Pipe: Cannot fork: $!"; + } + + # NOT Reached +} + +sub reader { + @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )'; + my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + + my $fh = ${*$me}[0]; + my $pid; + $pid = $me->_doit(0, $fh, @_) + if(@_); + + close ${*$me}[1]; + bless $me, ref($fh); + *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"r") + unless defined($me->fileno); + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +sub writer { + @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )'; + my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + + my $fh = ${*$me}[1]; + my $pid; + $pid = $me->_doit(1, $fh, @_) + if(@_); + + close ${*$me}[0]; + bless $me, ref($fh); + *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"w") + unless defined($me->fileno); + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +package IO::Pipe::End; + +our(@ISA); + +@ISA = qw(IO::Handle); + +sub close { + my $fh = shift; + my $r = $fh->SUPER::close(@_); + + waitpid(${*$fh}{'io_pipe_pid'},0) + if(defined ${*$fh}{'io_pipe_pid'}); + + $r; +} + +1; + +__END__ + +=head1 NAME + +IO::Pipe - supply object methods for pipes + +=head1 SYNOPSIS + + use IO::Pipe; + + $pipe = IO::Pipe->new(); + + if($pid = fork()) { # Parent + $pipe->reader(); + + while(<$pipe>) { + ... + } + + } + elsif(defined $pid) { # Child + $pipe->writer(); + + print $pipe ... + } + + or + + $pipe = IO::Pipe->new(); + + $pipe->reader(qw(ls -l)); + + while(<$pipe>) { + ... + } + +=head1 DESCRIPTION + +C<IO::Pipe> provides an interface to creating pipes between +processes. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [READER, WRITER] ) + +Creates an C<IO::Pipe>, which is a reference to a newly created symbol +(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two +arguments, which should be objects blessed into C<IO::Handle>, or a +subclass thereof. These two objects will be used for the system call +to C<pipe>. If no arguments are given then method C<handles> is called +on the new C<IO::Pipe> object. + +These two handles are held in the array part of the GLOB until either +C<reader> or C<writer> is called. + +=back + +=head1 METHODS + +=over 4 + +=item reader ([ARGS]) + +The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a +handle at the reading end of the pipe. If C<ARGS> are given then C<fork> +is called and C<ARGS> are passed to exec. + +=item writer ([ARGS]) + +The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a +handle at the writing end of the pipe. If C<ARGS> are given then C<fork> +is called and C<ARGS> are passed to exec. + +=item handles () + +This method is called during construction by C<IO::Pipe::new> +on the newly created C<IO::Pipe> object. It returns an array of two objects +blessed into C<IO::Pipe::End>, or a subclass thereof. + +=back + +=head1 SEE ALSO + +L<IO::Handle> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perlbug@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Poll.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Poll.pm new file mode 100644 index 0000000000..3e949b75f7 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Poll.pm @@ -0,0 +1,208 @@ + +# IO::Poll.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Poll; + +use strict; +use IO::Handle; +use Exporter (); + +our @ISA = qw(Exporter); +our $VERSION = "1.39"; + +our @EXPORT = qw( POLLIN + POLLOUT + POLLERR + POLLHUP + POLLNVAL + ); + +our @EXPORT_OK = qw( + POLLPRI + POLLRDNORM + POLLWRNORM + POLLRDBAND + POLLWRBAND + POLLNORM + ); + +# [0] maps fd's to requested masks +# [1] maps fd's to returned masks +# [2] maps fd's to handles +sub new { + my $class = shift; + + my $self = bless [{},{},{}], $class; + + $self; +} + +sub mask { + my $self = shift; + my $io = shift; + my $fd = fileno($io); + return unless defined $fd; + if (@_) { + my $mask = shift; + if($mask) { + $self->[0]{$fd}{$io} = $mask; # the error events are always returned + $self->[1]{$fd} = 0; # output mask + $self->[2]{$io} = $io; # remember handle + } else { + delete $self->[0]{$fd}{$io}; + unless(%{$self->[0]{$fd}}) { + # We no longer have any handles for this FD + delete $self->[1]{$fd}; + delete $self->[0]{$fd}; + } + delete $self->[2]{$io}; + } + } + + return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io}; + return $self->[0]{$fd}{$io}; +} + + +sub poll { + my($self,$timeout) = @_; + + $self->[1] = {}; + + my($fd,$mask,$iom); + my @poll = (); + + while(($fd,$iom) = each %{$self->[0]}) { + $mask = 0; + $mask |= $_ for values(%$iom); + push(@poll,$fd => $mask); + } + + my $ret = _poll(defined($timeout) ? $timeout * 1000 : -1,@poll); + + return $ret + unless $ret > 0; + + while(@poll) { + my($fd,$got) = splice(@poll,0,2); + $self->[1]{$fd} = $got if $got; + } + + return $ret; +} + +sub events { + my $self = shift; + my $io = shift; + my $fd = fileno($io); + exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io} + ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL) + : 0; +} + +sub remove { + my $self = shift; + my $io = shift; + $self->mask($io,0); +} + +sub handles { + my $self = shift; + return values %{$self->[2]} unless @_; + + my $events = shift || 0; + my($fd,$ev,$io,$mask); + my @handles = (); + + while(($fd,$ev) = each %{$self->[1]}) { + while (($io,$mask) = each %{$self->[0]{$fd}}) { + $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these + push @handles,$self->[2]{$io} if ($ev & $mask) & $events; + } + } + return @handles; +} + +1; + +__END__ + +=head1 NAME + +IO::Poll - Object interface to system poll call + +=head1 SYNOPSIS + + use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP); + + $poll = IO::Poll->new(); + + $poll->mask($input_handle => POLLIN); + $poll->mask($output_handle => POLLOUT); + + $poll->poll($timeout); + + $ev = $poll->events($input); + +=head1 DESCRIPTION + +C<IO::Poll> is a simple interface to the system level poll routine. + +=head1 METHODS + +=over 4 + +=item mask ( IO [, EVENT_MASK ] ) + +If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the +list of file descriptors and the next call to poll will check for +any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be +removed from the list of file descriptors. + +If EVENT_MASK is not given then the return value will be the current +event mask value for IO. + +=item poll ( [ TIMEOUT ] ) + +Call the system level poll routine. If TIMEOUT is not specified then the +call will block. Returns the number of handles which had events +happen, or -1 on error. + +=item events ( IO ) + +Returns the event mask which represents the events that happened on IO +during the last call to C<poll>. + +=item remove ( IO ) + +Remove IO from the list of file descriptors for the next poll. + +=item handles( [ EVENT_MASK ] ) + +Returns a list of handles. If EVENT_MASK is not given then a list of all +handles known will be returned. If EVENT_MASK is given then a list +of handles will be returned which had one of the events specified by +EVENT_MASK happen during the last call ti C<poll> + +=back + +=head1 SEE ALSO + +L<poll(2)>, L<IO::Handle>, L<IO::Select> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perlbug@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Seekable.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Seekable.pm new file mode 100644 index 0000000000..27ed663445 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Seekable.pm @@ -0,0 +1,126 @@ +# + +package IO::Seekable; + +=head1 NAME + +IO::Seekable - supply seek based methods for I/O objects + +=head1 SYNOPSIS + + use IO::Seekable; + package IO::Something; + @ISA = qw(IO::Seekable); + +=head1 DESCRIPTION + +C<IO::Seekable> does not have a constructor of its own as it is intended to +be inherited by other C<IO::Handle> based objects. It provides methods +which allow seeking of the file descriptors. + +=over 4 + +=item $io->getpos + +Returns an opaque value that represents the current position of the +IO::File, or C<undef> if this is not possible (eg an unseekable stream such +as a terminal, pipe or socket). If the fgetpos() function is available in +your C library it is used to implements getpos, else perl emulates getpos +using C's ftell() function. + +=item $io->setpos + +Uses the value of a previous getpos call to return to a previously visited +position. Returns "0 but true" on success, C<undef> on failure. + +=back + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Seekable> methods, which are just front ends for the +corresponding built-in functions: + +=over 4 + +=item $io->seek ( POS, WHENCE ) + +Seek the IO::File to position POS, relative to WHENCE: + +=over 8 + +=item WHENCE=0 (SEEK_SET) + +POS is absolute position. (Seek relative to the start of the file) + +=item WHENCE=1 (SEEK_CUR) + +POS is an offset from the current position. (Seek relative to current) + +=item WHENCE=2 (SEEK_END) + +POS is an offset from the end of the file. (Seek relative to end) + +=back + +The SEEK_* constants can be imported from the C<Fcntl> module if you +don't wish to use the numbers C<0> C<1> or C<2> in your code. + +Returns C<1> upon success, C<0> otherwise. + +=item $io->sysseek( POS, WHENCE ) + +Similar to $io->seek, but sets the IO::File's position using the system +call lseek(2) directly, so will confuse most perl IO operators except +sysread and syswrite (see L<perlfunc> for full details) + +Returns the new position, or C<undef> on failure. A position +of zero is returned as the string C<"0 but true"> + +=item $io->tell + +Returns the IO::File's current position, or -1 on error. + +=back + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle> +L<IO::File> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt> + +=cut + +use 5.008_001; +use Carp; +use strict; +use IO::Handle (); +# XXX we can't get these from IO::Handle or we'll get prototype +# mismatch warnings on C<use POSIX; use IO::File;> :-( +use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); +require Exporter; + +our @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); +our @ISA = qw(Exporter); + +our $VERSION = "1.39"; + +sub seek { + @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)'; + seek($_[0], $_[1], $_[2]); +} + +sub sysseek { + @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)'; + sysseek($_[0], $_[1], $_[2]); +} + +sub tell { + @_ == 1 or croak 'usage: $io->tell()'; + tell($_[0]); +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Select.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Select.pm new file mode 100644 index 0000000000..6176f8bbf8 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Select.pm @@ -0,0 +1,403 @@ +# IO::Select.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Select; + +use strict; +use warnings::register; +require Exporter; + +our $VERSION = "1.39"; + +our @ISA = qw(Exporter); # This is only so we can do version checking + +sub VEC_BITS () {0} +sub FD_COUNT () {1} +sub FIRST_FD () {2} + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + + my $vec = bless [undef,0], $type; + + $vec->add(@_) + if @_; + + $vec; +} + +sub add +{ + shift->_update('add', @_); +} + + +sub remove +{ + shift->_update('remove', @_); +} + + +sub exists +{ + my $vec = shift; + my $fno = $vec->_fileno(shift); + return undef unless defined $fno; + $vec->[$fno + FIRST_FD]; +} + + +sub _fileno +{ + my($self, $f) = @_; + return unless defined $f; + $f = $f->[0] if ref($f) eq 'ARRAY'; + ($f =~ /^\d+$/) ? $f : fileno($f); +} + +sub _update +{ + my $vec = shift; + my $add = shift eq 'add'; + + my $bits = $vec->[VEC_BITS]; + $bits = '' unless defined $bits; + + my $count = 0; + my $f; + foreach $f (@_) + { + my $fn = $vec->_fileno($f); + if ($add) { + next unless defined $fn; + my $i = $fn + FIRST_FD; + if (defined $vec->[$i]) { + $vec->[$i] = $f; # if array rest might be different, so we update + next; + } + $vec->[FD_COUNT]++; + vec($bits, $fn, 1) = 1; + $vec->[$i] = $f; + } else { # remove + if ( ! defined $fn ) { # remove if fileno undef'd + $fn = 0; + for my $fe (@{$vec}[FIRST_FD .. $#$vec]) { + if (defined($fe) && $fe == $f) { + $vec->[FD_COUNT]--; + $fe = undef; + vec($bits, $fn, 1) = 0; + last; + } + ++$fn; + } + } + else { + my $i = $fn + FIRST_FD; + next unless defined $vec->[$i]; + $vec->[FD_COUNT]--; + vec($bits, $fn, 1) = 0; + $vec->[$i] = undef; + } + } + $count++; + } + $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef; + $count; +} + +sub can_read +{ + my $vec = shift; + my $timeout = shift; + my $r = $vec->[VEC_BITS]; + + defined($r) && (select($r,undef,undef,$timeout) > 0) + ? handles($vec, $r) + : (); +} + +sub can_write +{ + my $vec = shift; + my $timeout = shift; + my $w = $vec->[VEC_BITS]; + + defined($w) && (select(undef,$w,undef,$timeout) > 0) + ? handles($vec, $w) + : (); +} + +sub has_exception +{ + my $vec = shift; + my $timeout = shift; + my $e = $vec->[VEC_BITS]; + + defined($e) && (select(undef,undef,$e,$timeout) > 0) + ? handles($vec, $e) + : (); +} + +sub has_error +{ + warnings::warn("Call to deprecated method 'has_error', use 'has_exception'") + if warnings::enabled(); + goto &has_exception; +} + +sub count +{ + my $vec = shift; + $vec->[FD_COUNT]; +} + +sub bits +{ + my $vec = shift; + $vec->[VEC_BITS]; +} + +sub as_string # for debugging +{ + my $vec = shift; + my $str = ref($vec) . ": "; + my $bits = $vec->bits; + my $count = $vec->count; + $str .= defined($bits) ? unpack("b*", $bits) : "undef"; + $str .= " $count"; + my @handles = @$vec; + splice(@handles, 0, FIRST_FD); + for (@handles) { + $str .= " " . (defined($_) ? "$_" : "-"); + } + $str; +} + +sub _max +{ + my($a,$b,$c) = @_; + $a > $b + ? $a > $c + ? $a + : $c + : $b > $c + ? $b + : $c; +} + +sub select +{ + shift + if defined $_[0] && !ref($_[0]); + + my($r,$w,$e,$t) = @_; + my @result = (); + + my $rb = defined $r ? $r->[VEC_BITS] : undef; + my $wb = defined $w ? $w->[VEC_BITS] : undef; + my $eb = defined $e ? $e->[VEC_BITS] : undef; + + if(select($rb,$wb,$eb,$t) > 0) + { + my @r = (); + my @w = (); + my @e = (); + my $i = _max(defined $r ? scalar(@$r)-1 : 0, + defined $w ? scalar(@$w)-1 : 0, + defined $e ? scalar(@$e)-1 : 0); + + for( ; $i >= FIRST_FD ; $i--) + { + my $j = $i - FIRST_FD; + push(@r, $r->[$i]) + if defined $rb && defined $r->[$i] && vec($rb, $j, 1); + push(@w, $w->[$i]) + if defined $wb && defined $w->[$i] && vec($wb, $j, 1); + push(@e, $e->[$i]) + if defined $eb && defined $e->[$i] && vec($eb, $j, 1); + } + + @result = (\@r, \@w, \@e); + } + @result; +} + + +sub handles +{ + my $vec = shift; + my $bits = shift; + my @h = (); + my $i; + my $max = scalar(@$vec) - 1; + + for ($i = FIRST_FD; $i <= $max; $i++) + { + next unless defined $vec->[$i]; + push(@h, $vec->[$i]) + if !defined($bits) || vec($bits, $i - FIRST_FD, 1); + } + + @h; +} + +1; +__END__ + +=head1 NAME + +IO::Select - OO interface to the select system call + +=head1 SYNOPSIS + + use IO::Select; + + $s = IO::Select->new(); + + $s->add(\*STDIN); + $s->add($some_handle); + + @ready = $s->can_read($timeout); + + @ready = IO::Select->new(@handles)->can_read(0); + +=head1 DESCRIPTION + +The C<IO::Select> package implements an object approach to the system C<select> +function call. It allows the user to see what IO handles, see L<IO::Handle>, +are ready for reading, writing or have an exception pending. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ HANDLES ] ) + +The constructor creates a new object and optionally initialises it with a set +of handles. + +=back + +=head1 METHODS + +=over 4 + +=item add ( HANDLES ) + +Add the list of handles to the C<IO::Select> object. It is these values that +will be returned when an event occurs. C<IO::Select> keeps these values in a +cache which is indexed by the C<fileno> of the handle, so if more than one +handle with the same C<fileno> is specified then only the last one is cached. + +Each handle can be an C<IO::Handle> object, an integer or an array +reference where the first element is an C<IO::Handle> or an integer. + +=item remove ( HANDLES ) + +Remove all the given handles from the object. This method also works +by the C<fileno> of the handles. So the exact handles that were added +need not be passed, just handles that have an equivalent C<fileno> + +=item exists ( HANDLE ) + +Returns a true value (actually the handle itself) if it is present. +Returns undef otherwise. + +=item handles + +Return an array of all registered handles. + +=item can_read ( [ TIMEOUT ] ) + +Return an array of handles that are ready for reading. C<TIMEOUT> is the +maximum amount of time to wait before returning an empty list (with C<$!> +unchanged), in seconds, possibly fractional. If C<TIMEOUT> is not given +and any handles are registered then the call will block indefinitely. +Upon error, an empty list is returned, with C<$!> set to indicate the +error. To distinguish between timeout and error, set C<$!> to zero +before calling this method, and check it after an empty list is returned. + +=item can_write ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that can be written to. + +=item has_exception ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that have an exception +condition, for example pending out-of-band data. + +=item count () + +Returns the number of handles that the object will check for when +one of the C<can_> methods is called or the object is passed to +the C<select> static method. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] ) + +C<select> is a static method, that is you call it with the package name +like C<new>. C<READ>, C<WRITE> and C<EXCEPTION> are either C<undef> or +C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as +for the core select call. + +If at least one handle is ready for the specified kind of operation, +the result will be an array of 3 elements, each a reference to an array +which will hold the handles that are ready for reading, writing and +have exceptions respectively. Upon timeout, an empty list is returned, +with C<$!> unchanged. Upon error, an empty list is returned, with C<$!> +set to indicate the error. To distinguish between timeout and error, +set C<$!> to zero before calling this method, and check it after an +empty list is returned. + +=back + +=head1 EXAMPLE + +Here is a short example which shows how C<IO::Select> could be used +to write a server which communicates with several sockets while also +listening for more connections on a listen socket + + use IO::Select; + use IO::Socket; + + $lsn = IO::Socket::INET->new(Listen => 1, LocalPort => 8080); + $sel = IO::Select->new( $lsn ); + + while(@ready = $sel->can_read) { + foreach $fh (@ready) { + if($fh == $lsn) { + # Create a new socket + $new = $lsn->accept; + $sel->add($new); + } + else { + # Process socket + + # Maybe we have finished with the socket + $sel->remove($fh); + $fh->close; + } + } + } + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perlbug@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket.pm new file mode 100644 index 0000000000..bea16ec6e4 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket.pm @@ -0,0 +1,585 @@ + +# IO::Socket.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Socket; + +use 5.008_001; + +use IO::Handle; +use Socket 1.3; +use Carp; +use strict; +use Exporter; +use Errno; + +# legacy + +require IO::Socket::INET; +require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian'); + +our @ISA = qw(IO::Handle); + +our $VERSION = "1.39"; + +our @EXPORT_OK = qw(sockatmark); + +sub import { + my $pkg = shift; + if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast + Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark'); + } else { + my $callpkg = caller; + Exporter::export 'Socket', $callpkg, @_; + } +} + +sub new { + my($class,%arg) = @_; + my $sock = $class->SUPER::new(); + + $sock->autoflush(1); + + ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; + + return scalar(%arg) ? $sock->configure(\%arg) + : $sock; +} + +my @domain2pkg; + +sub register_domain { + my($p,$d) = @_; + $domain2pkg[$d] = $p; +} + +sub configure { + my($sock,$arg) = @_; + my $domain = delete $arg->{Domain}; + + croak 'IO::Socket: Cannot configure a generic socket' + unless defined $domain; + + croak "IO::Socket: Unsupported socket domain" + unless defined $domain2pkg[$domain]; + + croak "IO::Socket: Cannot configure socket in domain '$domain'" + unless ref($sock) eq "IO::Socket"; + + bless($sock, $domain2pkg[$domain]); + $sock->configure($arg); +} + +sub socket { + @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)'; + my($sock,$domain,$type,$protocol) = @_; + + socket($sock,$domain,$type,$protocol) or + return undef; + + ${*$sock}{'io_socket_domain'} = $domain; + ${*$sock}{'io_socket_type'} = $type; + ${*$sock}{'io_socket_proto'} = $protocol; + + $sock; +} + +sub socketpair { + @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)'; + my($class,$domain,$type,$protocol) = @_; + my $sock1 = $class->new(); + my $sock2 = $class->new(); + + socketpair($sock1,$sock2,$domain,$type,$protocol) or + return (); + + ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type; + ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol; + + ($sock1,$sock2); +} + +sub connect { + @_ == 2 or croak 'usage: $sock->connect(NAME)'; + my $sock = shift; + my $addr = shift; + my $timeout = ${*$sock}{'io_socket_timeout'}; + my $err; + my $blocking; + + $blocking = $sock->blocking(0) if $timeout; + if (!connect($sock, $addr)) { + if (defined $timeout && ($!{EINPROGRESS} || $!{EWOULDBLOCK})) { + require IO::Select; + + my $sel = new IO::Select $sock; + + undef $!; + my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout); + if(@$e[0]) { + # Windows return from select after the timeout in case of + # WSAECONNREFUSED(10061) if exception set is not used. + # This behavior is different from Linux. + # Using the exception + # set we now emulate the behavior in Linux + # - Karthik Rajagopalan + $err = $sock->getsockopt(SOL_SOCKET,SO_ERROR); + $@ = "connect: $err"; + } + elsif(!@$w[0]) { + $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + $@ = "connect: timeout"; + } + elsif (!connect($sock,$addr) && + not ($!{EISCONN} || ($^O eq 'MSWin32' && + ($! == (($] < 5.019004) ? 10022 : Errno::EINVAL)))) + ) { + # Some systems refuse to re-connect() to + # an already open socket and set errno to EISCONN. + # Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or + # EINVAL (22) (5.19.4 onwards). + $err = $!; + $@ = "connect: $!"; + } + } + elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) { + $err = $!; + $@ = "connect: $!"; + } + } + + $sock->blocking(1) if $blocking; + + $! = $err if $err; + + $err ? undef : $sock; +} + +# Enable/disable blocking IO on sockets. +# Without args return the current status of blocking, +# with args change the mode as appropriate, returning the +# old setting, or in case of error during the mode change +# undef. + +sub blocking { + my $sock = shift; + + return $sock->SUPER::blocking(@_) + if $^O ne 'MSWin32' && $^O ne 'VMS'; + + # Windows handles blocking differently + # + # http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f + # http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp + # + # 0x8004667e is FIONBIO + # + # which is used to set blocking behaviour. + + # NOTE: + # This is a little confusing, the perl keyword for this is + # 'blocking' but the OS level behaviour is 'non-blocking', probably + # because sockets are blocking by default. + # Therefore internally we have to reverse the semantics. + + my $orig= !${*$sock}{io_sock_nonblocking}; + + return $orig unless @_; + + my $block = shift; + + if ( !$block != !$orig ) { + ${*$sock}{io_sock_nonblocking} = $block ? 0 : 1; + ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking})) + or return undef; + } + + return $orig; +} + + +sub close { + @_ == 1 or croak 'usage: $sock->close()'; + my $sock = shift; + ${*$sock}{'io_socket_peername'} = undef; + $sock->SUPER::close(); +} + +sub bind { + @_ == 2 or croak 'usage: $sock->bind(NAME)'; + my $sock = shift; + my $addr = shift; + + return bind($sock, $addr) ? $sock + : undef; +} + +sub listen { + @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])'; + my($sock,$queue) = @_; + $queue = 5 + unless $queue && $queue > 0; + + return listen($sock, $queue) ? $sock + : undef; +} + +sub accept { + @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])'; + my $sock = shift; + my $pkg = shift || $sock; + my $timeout = ${*$sock}{'io_socket_timeout'}; + my $new = $pkg->new(Timeout => $timeout); + my $peer = undef; + + if(defined $timeout) { + require IO::Select; + + my $sel = new IO::Select $sock; + + unless ($sel->can_read($timeout)) { + $@ = 'accept: timeout'; + $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + return; + } + } + + $peer = accept($new,$sock) + or return; + + ${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto ); + + return wantarray ? ($new, $peer) + : $new; +} + +sub sockname { + @_ == 1 or croak 'usage: $sock->sockname()'; + getsockname($_[0]); +} + +sub peername { + @_ == 1 or croak 'usage: $sock->peername()'; + my($sock) = @_; + ${*$sock}{'io_socket_peername'} ||= getpeername($sock); +} + +sub connected { + @_ == 1 or croak 'usage: $sock->connected()'; + my($sock) = @_; + getpeername($sock); +} + +sub send { + @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])'; + my $sock = $_[0]; + my $flags = $_[2] || 0; + my $peer = $_[3] || $sock->peername; + + croak 'send: Cannot determine peer address' + unless(defined $peer); + + my $r = defined(getpeername($sock)) + ? send($sock, $_[1], $flags) + : send($sock, $_[1], $flags, $peer); + + # remember who we send to, if it was successful + ${*$sock}{'io_socket_peername'} = $peer + if(@_ == 4 && defined $r); + + $r; +} + +sub recv { + @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])'; + my $sock = $_[0]; + my $len = $_[2]; + my $flags = $_[3] || 0; + + # remember who we recv'd from + ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); +} + +sub shutdown { + @_ == 2 or croak 'usage: $sock->shutdown(HOW)'; + my($sock, $how) = @_; + ${*$sock}{'io_socket_peername'} = undef; + shutdown($sock, $how); +} + +sub setsockopt { + @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)'; + setsockopt($_[0],$_[1],$_[2],$_[3]); +} + +my $intsize = length(pack("i",0)); + +sub getsockopt { + @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)'; + my $r = getsockopt($_[0],$_[1],$_[2]); + # Just a guess + $r = unpack("i", $r) + if(defined $r && length($r) == $intsize); + $r; +} + +sub sockopt { + my $sock = shift; + @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_) + : $sock->setsockopt(SOL_SOCKET,@_); +} + +sub atmark { + @_ == 1 or croak 'usage: $sock->atmark()'; + my($sock) = @_; + sockatmark($sock); +} + +sub timeout { + @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])'; + my($sock,$val) = @_; + my $r = ${*$sock}{'io_socket_timeout'}; + + ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val + if(@_ == 2); + + $r; +} + +sub sockdomain { + @_ == 1 or croak 'usage: $sock->sockdomain()'; + my $sock = shift; + if (!defined(${*$sock}{'io_socket_domain'})) { + my $addr = $sock->sockname(); + ${*$sock}{'io_socket_domain'} = sockaddr_family($addr) + if (defined($addr)); + } + ${*$sock}{'io_socket_domain'}; +} + +sub socktype { + @_ == 1 or croak 'usage: $sock->socktype()'; + my $sock = shift; + ${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE) + if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE})); + ${*$sock}{'io_socket_type'} +} + +sub protocol { + @_ == 1 or croak 'usage: $sock->protocol()'; + my($sock) = @_; + ${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL) + if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL})); + ${*$sock}{'io_socket_proto'}; +} + +1; + +__END__ + +=head1 NAME + +IO::Socket - Object interface to socket communications + +=head1 SYNOPSIS + + use IO::Socket; + +=head1 DESCRIPTION + +C<IO::Socket> provides an object interface to creating and using sockets. It +is built upon the L<IO::Handle> interface and inherits all the methods defined +by L<IO::Handle>. + +C<IO::Socket> only defines methods for those operations which are common to all +types of socket. Operations which are specified to a socket in a particular +domain have methods defined in sub classes of C<IO::Socket> + +C<IO::Socket> will export all functions (and constants) defined by L<Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket>, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. +C<new> only looks for one key C<Domain> which tells new which domain +the socket will be in. All other arguments will be passed to the +configuration method of the package for that domain, See below. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +=back + +=head1 METHODS + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Socket> methods, which are just front ends for the +corresponding built-in functions: + + socket + socketpair + bind + listen + accept + send + recv + peername (getpeername) + sockname (getsockname) + shutdown + +Some methods take slightly different arguments to those defined in L<perlfunc> +in attempt to make the interface more flexible. These are + +=over 4 + +=item accept([PKG]) + +perform the system call C<accept> on the socket and return a new +object. The new object will be created in the same class as the listen +socket, unless C<PKG> is specified. This object can be used to +communicate with the client that was trying to connect. + +In a scalar context the new socket is returned, or undef upon +failure. In a list context a two-element array is returned containing +the new socket and the peer address; the list will be empty upon +failure. + +The timeout in the [PKG] can be specified as zero to effect a "poll", +but you shouldn't do that because a new IO::Select object will be +created behind the scenes just to do the single poll. This is +horrendously inefficient. Use rather true select() with a zero +timeout on the handle, or non-blocking IO. + +=item socketpair(DOMAIN, TYPE, PROTOCOL) + +Call C<socketpair> and return a list of two sockets created, or an +empty list on failure. + +=back + +Additional methods that are provided are: + +=over 4 + +=item atmark + +True if the socket is currently positioned at the urgent data mark, +false otherwise. + + use IO::Socket; + + my $sock = IO::Socket::INET->new('some_server'); + $sock->read($data, 1024) until $sock->atmark; + +Note: this is a reasonably new addition to the family of socket +functions, so all systems may not support this yet. If it is +unsupported by the system, an attempt to use this method will +abort the program. + +The atmark() functionality is also exportable as sockatmark() function: + + use IO::Socket 'sockatmark'; + +This allows for a more traditional use of sockatmark() as a procedural +socket function. If your system does not support sockatmark(), the +C<use> declaration will fail at compile time. + +=item connected + +If the socket is in a connected state, the peer address is returned. If the +socket is not in a connected state, undef is returned. + +Note that connected() considers a half-open TCP socket to be "in a connected +state". Specifically, connected() does not distinguish between the +B<ESTABLISHED> and B<CLOSE-WAIT> TCP states; it returns the peer address, +rather than undef, in either case. Thus, in general, connected() cannot +be used to reliably learn whether the peer has initiated a graceful shutdown +because in most cases (see below) the local TCP state machine remains in +B<CLOSE-WAIT> until the local application calls shutdown() or close(); +only at that point does connected() return undef. + +The "in most cases" hedge is because local TCP state machine behavior may +depend on the peer's socket options. In particular, if the peer socket has +SO_LINGER enabled with a zero timeout, then the peer's close() will generate +a RST segment, upon receipt of which the local TCP transitions immediately to +B<CLOSED>, and in that state, connected() I<will> return undef. + +=item protocol + +Returns the numerical number for the protocol being used on the socket, if +known. If the protocol is unknown, as with an AF_UNIX socket, zero +is returned. + +=item sockdomain + +Returns the numerical number for the socket domain type. For example, for +an AF_INET socket the value of &AF_INET will be returned. + +=item sockopt(OPT [, VAL]) + +Unified method to both set and get options in the SOL_SOCKET level. If called +with one argument then getsockopt is called, otherwise setsockopt is called. + +=item getsockopt(LEVEL, OPT) + +Get option associated with the socket. Other levels than SOL_SOCKET +may be specified here. + +=item setsockopt(LEVEL, OPT, VAL) + +Set option associated with the socket. Other levels than SOL_SOCKET +may be specified here. + +=item socktype + +Returns the numerical number for the socket type. For example, for +a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. + +=item timeout([VAL]) + +Set or get the timeout value (in seconds) associated with this socket. +If called without any arguments then the current setting is returned. If +called with an argument the current setting is changed and the previous +value returned. + +=back + +=head1 LIMITATIONS + +On some systems, for an IO::Socket object created with new_from_fd(), +or created with accept() from such an object, the protocol(), +sockdomain() and socktype() methods may return undef. + +=head1 SEE ALSO + +L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> + +=head1 AUTHOR + +Graham Barr. atmark() by Lincoln Stein. Currently maintained by the +Perl Porters. Please report all bugs to <perlbug@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>. +This module is distributed under the same terms as Perl itself. +Feel free to use, modify and redistribute it as long as you retain +the correct attribution. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket/INET.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket/INET.pm new file mode 100644 index 0000000000..084cb1c631 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket/INET.pm @@ -0,0 +1,466 @@ +# IO::Socket::INET.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Socket::INET; + +use strict; +use IO::Socket; +use Socket; +use Carp; +use Exporter; +use Errno; + +our @ISA = qw(IO::Socket); +our $VERSION = "1.39"; + +my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1; + +IO::Socket::INET->register_domain( AF_INET ); + +my %socket_type = ( tcp => SOCK_STREAM, + udp => SOCK_DGRAM, + icmp => SOCK_RAW + ); +my %proto_number; +$proto_number{tcp} = Socket::IPPROTO_TCP() if defined &Socket::IPPROTO_TCP; +$proto_number{udp} = Socket::IPPROTO_UDP() if defined &Socket::IPPROTO_UDP; +$proto_number{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP; +my %proto_name = reverse %proto_number; + +sub new { + my $class = shift; + unshift(@_, "PeerAddr") if @_ == 1; + return $class->SUPER::new(@_); +} + +sub _cache_proto { + my @proto = @_; + for (map lc($_), $proto[0], split(' ', $proto[1])) { + $proto_number{$_} = $proto[2]; + } + $proto_name{$proto[2]} = $proto[0]; +} + +sub _get_proto_number { + my $name = lc(shift); + return undef unless defined $name; + return $proto_number{$name} if exists $proto_number{$name}; + + my @proto = eval { getprotobyname($name) }; + return undef unless @proto; + _cache_proto(@proto); + + return $proto[2]; +} + +sub _get_proto_name { + my $num = shift; + return undef unless defined $num; + return $proto_name{$num} if exists $proto_name{$num}; + + my @proto = eval { getprotobynumber($num) }; + return undef unless @proto; + _cache_proto(@proto); + + return $proto[0]; +} + +sub _sock_info { + my($addr,$port,$proto) = @_; + my $origport = $port; + my @serv = (); + + $port = $1 + if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,); + + if(defined $proto && $proto =~ /\D/) { + my $num = _get_proto_number($proto); + unless (defined $num) { + $@ = "Bad protocol '$proto'"; + return; + } + $proto = $num; + } + + if(defined $port) { + my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef; + my $pnum = ($port =~ m,^(\d+)$,)[0]; + + @serv = getservbyname($port, _get_proto_name($proto) || "") + if ($port =~ m,\D,); + + $port = $serv[2] || $defport || $pnum; + unless (defined $port) { + $@ = "Bad service '$origport'"; + return; + } + + $proto = _get_proto_number($serv[3]) if @serv && !$proto; + } + + return ($addr || undef, + $port || undef, + $proto || undef + ); +} + +sub _error { + my $sock = shift; + my $err = shift; + { + local($!); + my $title = ref($sock).": "; + $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_); + $sock->close() + if(defined fileno($sock)); + } + $! = $err; + return undef; +} + +sub _get_addr { + my($sock,$addr_str, $multi) = @_; + my @addr; + if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) { + (undef, undef, undef, undef, @addr) = gethostbyname($addr_str); + } else { + my $h = inet_aton($addr_str); + push(@addr, $h) if defined $h; + } + @addr; +} + +sub configure { + my($sock,$arg) = @_; + my($lport,$rport,$laddr,$raddr,$proto,$type); + + + $arg->{LocalAddr} = $arg->{LocalHost} + if exists $arg->{LocalHost} && !exists $arg->{LocalAddr}; + + ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, + $arg->{LocalPort}, + $arg->{Proto}) + or return _error($sock, $!, $@); + + $laddr = defined $laddr ? inet_aton($laddr) + : INADDR_ANY; + + return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'") + unless(defined $laddr); + + $arg->{PeerAddr} = $arg->{PeerHost} + if exists $arg->{PeerHost} && !exists $arg->{PeerAddr}; + + unless(exists $arg->{Listen}) { + ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, + $arg->{PeerPort}, + $proto) + or return _error($sock, $!, $@); + } + + $proto ||= _get_proto_number('tcp'); + + $type = $arg->{Type} || $socket_type{lc _get_proto_name($proto)}; + + my @raddr = (); + + if(defined $raddr) { + @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed}); + return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") + unless @raddr; + } + + while(1) { + + $sock->socket(AF_INET, $type, $proto) or + return _error($sock, $!, "$!"); + + if (defined $arg->{Blocking}) { + defined $sock->blocking($arg->{Blocking}) + or return _error($sock, $!, "$!"); + } + + if ($arg->{Reuse} || $arg->{ReuseAddr}) { + $sock->sockopt(SO_REUSEADDR,1) or + return _error($sock, $!, "$!"); + } + + if ($arg->{ReusePort}) { + $sock->sockopt(SO_REUSEPORT,1) or + return _error($sock, $!, "$!"); + } + + if ($arg->{Broadcast}) { + $sock->sockopt(SO_BROADCAST,1) or + return _error($sock, $!, "$!"); + } + + if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) { + $sock->bind($lport || 0, $laddr) or + return _error($sock, $!, "$!"); + } + + if(exists $arg->{Listen}) { + $sock->listen($arg->{Listen} || 5) or + return _error($sock, $!, "$!"); + last; + } + + # don't try to connect unless we're given a PeerAddr + last unless exists($arg->{PeerAddr}); + + $raddr = shift @raddr; + + return _error($sock, $EINVAL, 'Cannot determine remote port') + unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); + + last + unless($type == SOCK_STREAM || defined $raddr); + + return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") + unless defined $raddr; + +# my $timeout = ${*$sock}{'io_socket_timeout'}; +# my $before = time() if $timeout; + + undef $@; + if ($sock->connect(pack_sockaddr_in($rport, $raddr))) { +# ${*$sock}{'io_socket_timeout'} = $timeout; + return $sock; + } + + return _error($sock, $!, $@ || "Timeout") + unless @raddr; + +# if ($timeout) { +# my $new_timeout = $timeout - (time() - $before); +# return _error($sock, +# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL), +# "Timeout") if $new_timeout <= 0; +# ${*$sock}{'io_socket_timeout'} = $new_timeout; +# } + + } + + $sock; +} + +sub connect { + @_ == 2 || @_ == 3 or + croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)'; + my $sock = shift; + return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_)); +} + +sub bind { + @_ == 2 || @_ == 3 or + croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)'; + my $sock = shift; + return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_)) +} + +sub sockaddr { + @_ == 1 or croak 'usage: $sock->sockaddr()'; + my($sock) = @_; + my $name = $sock->sockname; + $name ? (sockaddr_in($name))[1] : undef; +} + +sub sockport { + @_ == 1 or croak 'usage: $sock->sockport()'; + my($sock) = @_; + my $name = $sock->sockname; + $name ? (sockaddr_in($name))[0] : undef; +} + +sub sockhost { + @_ == 1 or croak 'usage: $sock->sockhost()'; + my($sock) = @_; + my $addr = $sock->sockaddr; + $addr ? inet_ntoa($addr) : undef; +} + +sub peeraddr { + @_ == 1 or croak 'usage: $sock->peeraddr()'; + my($sock) = @_; + my $name = $sock->peername; + $name ? (sockaddr_in($name))[1] : undef; +} + +sub peerport { + @_ == 1 or croak 'usage: $sock->peerport()'; + my($sock) = @_; + my $name = $sock->peername; + $name ? (sockaddr_in($name))[0] : undef; +} + +sub peerhost { + @_ == 1 or croak 'usage: $sock->peerhost()'; + my($sock) = @_; + my $addr = $sock->peeraddr; + $addr ? inet_ntoa($addr) : undef; +} + +1; + +__END__ + +=head1 NAME + +IO::Socket::INET - Object interface for AF_INET domain sockets + +=head1 SYNOPSIS + + use IO::Socket::INET; + +=head1 DESCRIPTION + +C<IO::Socket::INET> provides an object interface to creating and using sockets +in the AF_INET domain. It is built upon the L<IO::Socket> interface and +inherits all the methods defined by L<IO::Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket::INET> object, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. + +In addition to the key-value pairs accepted by L<IO::Socket>, +C<IO::Socket::INET> provides. + + + PeerAddr Remote host address <hostname>[:<port>] + PeerHost Synonym for PeerAddr + PeerPort Remote port or service <service>[(<no>)] | <no> + LocalAddr Local host bind address hostname[:port] + LocalHost Synonym for LocalAddr + LocalPort Local host bind port <service>[(<no>)] | <no> + Proto Protocol name (or number) "tcp" | "udp" | ... + Type Socket type SOCK_STREAM | SOCK_DGRAM | ... + Listen Queue size for listen + ReuseAddr Set SO_REUSEADDR before binding + Reuse Set SO_REUSEADDR before binding (deprecated, + prefer ReuseAddr) + ReusePort Set SO_REUSEPORT before binding + Broadcast Set SO_BROADCAST before binding + Timeout Timeout value for various operations + MultiHomed Try all addresses for multi-homed hosts + Blocking Determine if connection will be blocking mode + +If C<Listen> is defined then a listen socket is created, else if the +socket type, which is derived from the protocol, is SOCK_STREAM then +connect() is called. If the C<Listen> argument is given, but false, +the queue size will be set to 5. + +Although it is not illegal, the use of C<MultiHomed> on a socket +which is in non-blocking mode is of little use. This is because the +first connect will never fail with a timeout as the connect call +will not block. + +The C<PeerAddr> can be a hostname or the IP-address on the +"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic +service name. The service name might be followed by a number in +parenthesis which is used if the service is not known by the system. +The C<PeerPort> specification can also be embedded in the C<PeerAddr> +by preceding it with a ":". + +If C<Proto> is not given and you specify a symbolic C<PeerPort> port, +then the constructor will try to derive C<Proto> from the service +name. As a last resort C<Proto> "tcp" is assumed. The C<Type> +parameter will be deduced from C<Proto> if not specified. + +If the constructor is only passed a single argument, it is assumed to +be a C<PeerAddr> specification. + +If C<Blocking> is set to 0, the connection will be in nonblocking mode. +If not specified it defaults to 1 (blocking mode). + +Examples: + + $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', + PeerPort => 'http(80)', + Proto => 'tcp'); + + $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); + + $sock = IO::Socket::INET->new(Listen => 5, + LocalAddr => 'localhost', + LocalPort => 9000, + Proto => 'tcp'); + + $sock = IO::Socket::INET->new('127.0.0.1:25'); + + $sock = IO::Socket::INET->new( + PeerPort => 9999, + PeerAddr => inet_ntoa(INADDR_BROADCAST), + Proto => udp, + LocalAddr => 'localhost', + Broadcast => 1 ) + or die "Can't bind : $@\n"; + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +=back + +=head2 METHODS + +=over 4 + +=item sockaddr () + +Return the address part of the sockaddr structure for the socket + +=item sockport () + +Return the port number that the socket is using on the local host + +=item sockhost () + +Return the address part of the sockaddr structure for the socket in a +text form xx.xx.xx.xx + +=item peeraddr () + +Return the address part of the sockaddr structure for the socket on +the peer host + +=item peerport () + +Return the port number for the socket on the peer host. + +=item peerhost () + +Return the address part of the sockaddr structure for the socket on the +peer host in a text form xx.xx.xx.xx + +=back + +=head1 SEE ALSO + +L<Socket>, L<IO::Socket> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perlbug@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket/IP.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket/IP.pm new file mode 100644 index 0000000000..5a5ee7d204 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket/IP.pm @@ -0,0 +1,1249 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2010-2015 -- leonerd@leonerd.org.uk + +package IO::Socket::IP; +# $VERSION needs to be set before use base 'IO::Socket' +# - https://rt.cpan.org/Ticket/Display.html?id=92107 +BEGIN { + $VERSION = '0.39'; +} + +use strict; +use warnings; +use base qw( IO::Socket ); + +use Carp; + +use Socket 1.97 qw( + getaddrinfo getnameinfo + sockaddr_family + AF_INET + AI_PASSIVE + IPPROTO_TCP IPPROTO_UDP + IPPROTO_IPV6 IPV6_V6ONLY + NI_DGRAM NI_NUMERICHOST NI_NUMERICSERV NIx_NOHOST NIx_NOSERV + SO_REUSEADDR SO_REUSEPORT SO_BROADCAST SO_ERROR + SOCK_DGRAM SOCK_STREAM + SOL_SOCKET +); +my $AF_INET6 = eval { Socket::AF_INET6() }; # may not be defined +my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0; +use POSIX qw( dup2 ); +use Errno qw( EINVAL EINPROGRESS EISCONN ENOTCONN ETIMEDOUT EWOULDBLOCK EOPNOTSUPP ); + +use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" ); + +# At least one OS (Android) is known not to have getprotobyname() +use constant HAVE_GETPROTOBYNAME => defined eval { getprotobyname( "tcp" ) }; + +my $IPv6_re = do { + # translation of RFC 3986 3.2.2 ABNF to re + my $IPv4address = do { + my $dec_octet = q<(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])>; + qq<$dec_octet(?: \\. $dec_octet){3}>; + }; + my $IPv6address = do { + my $h16 = qq<[0-9A-Fa-f]{1,4}>; + my $ls32 = qq<(?: $h16 : $h16 | $IPv4address)>; + qq<(?: + (?: $h16 : ){6} $ls32 + | :: (?: $h16 : ){5} $ls32 + | (?: $h16 )? :: (?: $h16 : ){4} $ls32 + | (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32 + | (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32 + | (?: (?: $h16 : ){0,3} $h16 )? :: $h16 : $ls32 + | (?: (?: $h16 : ){0,4} $h16 )? :: $ls32 + | (?: (?: $h16 : ){0,5} $h16 )? :: $h16 + | (?: (?: $h16 : ){0,6} $h16 )? :: + )> + }; + qr<$IPv6address>xo; +}; + +=head1 NAME + +C<IO::Socket::IP> - Family-neutral IP socket supporting both IPv4 and IPv6 + +=head1 SYNOPSIS + + use IO::Socket::IP; + + my $sock = IO::Socket::IP->new( + PeerHost => "www.google.com", + PeerPort => "http", + Type => SOCK_STREAM, + ) or die "Cannot construct socket - $@"; + + my $familyname = ( $sock->sockdomain == PF_INET6 ) ? "IPv6" : + ( $sock->sockdomain == PF_INET ) ? "IPv4" : + "unknown"; + + printf "Connected to google via %s\n", $familyname; + +=head1 DESCRIPTION + +This module provides a protocol-independent way to use IPv4 and IPv6 sockets, +intended as a replacement for L<IO::Socket::INET>. Most constructor arguments +and methods are provided in a backward-compatible way. For a list of known +differences, see the C<IO::Socket::INET> INCOMPATIBILITES section below. + +It uses the C<getaddrinfo(3)> function to convert hostnames and service names +or port numbers into sets of possible addresses to connect to or listen on. +This allows it to work for IPv6 where the system supports it, while still +falling back to IPv4-only on systems which don't. + +=head1 REPLACING C<IO::Socket> DEFAULT BEHAVIOUR + +By placing C<-register> in the import list, L<IO::Socket> uses +C<IO::Socket::IP> rather than C<IO::Socket::INET> as the class that handles +C<PF_INET>. C<IO::Socket> will also use C<IO::Socket::IP> rather than +C<IO::Socket::INET6> to handle C<PF_INET6>, provided that the C<AF_INET6> +constant is available. + +Changing C<IO::Socket>'s default behaviour means that calling the +C<IO::Socket> constructor with either C<PF_INET> or C<PF_INET6> as the +C<Domain> parameter will yield an C<IO::Socket::IP> object. + + use IO::Socket::IP -register; + + my $sock = IO::Socket->new( + Domain => PF_INET6, + LocalHost => "::1", + Listen => 1, + ) or die "Cannot create socket - $@\n"; + + print "Created a socket of type " . ref($sock) . "\n"; + +Note that C<-register> is a global setting that applies to the entire program; +it cannot be applied only for certain callers, removed, or limited by lexical +scope. + +=cut + +sub import +{ + my $pkg = shift; + my @symbols; + + foreach ( @_ ) { + if( $_ eq "-register" ) { + IO::Socket::IP::_ForINET->register_domain( AF_INET ); + IO::Socket::IP::_ForINET6->register_domain( $AF_INET6 ) if defined $AF_INET6; + } + else { + push @symbols, $_; + } + } + + @_ = ( $pkg, @symbols ); + goto &IO::Socket::import; +} + +# Convenient capability test function +{ + my $can_disable_v6only; + sub CAN_DISABLE_V6ONLY + { + return $can_disable_v6only if defined $can_disable_v6only; + + socket my $testsock, Socket::PF_INET6(), SOCK_STREAM, 0 or + die "Cannot socket(PF_INET6) - $!"; + + if( setsockopt $testsock, IPPROTO_IPV6, IPV6_V6ONLY, 0 ) { + return $can_disable_v6only = 1; + } + elsif( $! == EINVAL || $! == EOPNOTSUPP ) { + return $can_disable_v6only = 0; + } + else { + die "Cannot setsockopt() - $!"; + } + } +} + +=head1 CONSTRUCTORS + +=cut + +=head2 $sock = IO::Socket::IP->new( %args ) + +Creates a new C<IO::Socket::IP> object, containing a newly created socket +handle according to the named arguments passed. The recognised arguments are: + +=over 8 + +=item PeerHost => STRING + +=item PeerService => STRING + +Hostname and service name for the peer to C<connect()> to. The service name +may be given as a port number, as a decimal string. + +=item PeerAddr => STRING + +=item PeerPort => STRING + +For symmetry with the accessor methods and compatibility with +C<IO::Socket::INET>, these are accepted as synonyms for C<PeerHost> and +C<PeerService> respectively. + +=item PeerAddrInfo => ARRAY + +Alternate form of specifying the peer to C<connect()> to. This should be an +array of the form returned by C<Socket::getaddrinfo>. + +This parameter takes precedence over the C<Peer*>, C<Family>, C<Type> and +C<Proto> arguments. + +=item LocalHost => STRING + +=item LocalService => STRING + +Hostname and service name for the local address to C<bind()> to. + +=item LocalAddr => STRING + +=item LocalPort => STRING + +For symmetry with the accessor methods and compatibility with +C<IO::Socket::INET>, these are accepted as synonyms for C<LocalHost> and +C<LocalService> respectively. + +=item LocalAddrInfo => ARRAY + +Alternate form of specifying the local address to C<bind()> to. This should be +an array of the form returned by C<Socket::getaddrinfo>. + +This parameter takes precedence over the C<Local*>, C<Family>, C<Type> and +C<Proto> arguments. + +=item Family => INT + +The address family to pass to C<getaddrinfo> (e.g. C<AF_INET>, C<AF_INET6>). +Normally this will be left undefined, and C<getaddrinfo> will search using any +address family supported by the system. + +=item Type => INT + +The socket type to pass to C<getaddrinfo> (e.g. C<SOCK_STREAM>, +C<SOCK_DGRAM>). Normally defined by the caller; if left undefined +C<getaddrinfo> may attempt to infer the type from the service name. + +=item Proto => STRING or INT + +The IP protocol to use for the socket (e.g. C<'tcp'>, C<IPPROTO_TCP>, +C<'udp'>,C<IPPROTO_UDP>). Normally this will be left undefined, and either +C<getaddrinfo> or the kernel will choose an appropriate value. May be given +either in string name or numeric form. + +=item GetAddrInfoFlags => INT + +More flags to pass to the C<getaddrinfo()> function. If not supplied, a +default of C<AI_ADDRCONFIG> will be used. + +These flags will be combined with C<AI_PASSIVE> if the C<Listen> argument is +given. For more information see the documentation about C<getaddrinfo()> in +the L<Socket> module. + +=item Listen => INT + +If defined, puts the socket into listening mode where new connections can be +accepted using the C<accept> method. The value given is used as the +C<listen(2)> queue size. + +=item ReuseAddr => BOOL + +If true, set the C<SO_REUSEADDR> sockopt + +=item ReusePort => BOOL + +If true, set the C<SO_REUSEPORT> sockopt (not all OSes implement this sockopt) + +=item Broadcast => BOOL + +If true, set the C<SO_BROADCAST> sockopt + +=item Sockopts => ARRAY + +An optional array of other socket options to apply after the three listed +above. The value is an ARRAY containing 2- or 3-element ARRAYrefs. Each inner +array relates to a single option, giving the level and option name, and an +optional value. If the value element is missing, it will be given the value of +a platform-sized integer 1 constant (i.e. suitable to enable most of the +common boolean options). + +For example, both options given below are equivalent to setting C<ReuseAddr>. + + Sockopts => [ + [ SOL_SOCKET, SO_REUSEADDR ], + [ SOL_SOCKET, SO_REUSEADDR, pack( "i", 1 ) ], + ] + +=item V6Only => BOOL + +If defined, set the C<IPV6_V6ONLY> sockopt when creating C<PF_INET6> sockets +to the given value. If true, a listening-mode socket will only listen on the +C<AF_INET6> addresses; if false it will also accept connections from +C<AF_INET> addresses. + +If not defined, the socket option will not be changed, and default value set +by the operating system will apply. For repeatable behaviour across platforms +it is recommended this value always be defined for listening-mode sockets. + +Note that not all platforms support disabling this option. Some, at least +OpenBSD and MirBSD, will fail with C<EINVAL> if you attempt to disable it. +To determine whether it is possible to disable, you may use the class method + + if( IO::Socket::IP->CAN_DISABLE_V6ONLY ) { + ... + } + else { + ... + } + +If your platform does not support disabling this option but you still want to +listen for both C<AF_INET> and C<AF_INET6> connections you will have to create +two listening sockets, one bound to each protocol. + +=item MultiHomed + +This C<IO::Socket::INET>-style argument is ignored, except if it is defined +but false. See the C<IO::Socket::INET> INCOMPATIBILITES section below. + +However, the behaviour it enables is always performed by C<IO::Socket::IP>. + +=item Blocking => BOOL + +If defined but false, the socket will be set to non-blocking mode. Otherwise +it will default to blocking mode. See the NON-BLOCKING section below for more +detail. + +=item Timeout => NUM + +If defined, gives a maximum time in seconds to block per C<connect()> call +when in blocking mode. If missing, no timeout is applied other than that +provided by the underlying operating system. When in non-blocking mode this +parameter is ignored. + +Note that if the hostname resolves to multiple address candidates, the same +timeout will apply to each connection attempt individually, rather than to the +operation as a whole. Further note that the timeout does not apply to the +initial hostname resolve operation, if connecting by hostname. + +This behviour is copied inspired by C<IO::Socket::INET>; for more fine grained +control over connection timeouts, consider performing a nonblocking connect +directly. + +=back + +If neither C<Type> nor C<Proto> hints are provided, a default of +C<SOCK_STREAM> and C<IPPROTO_TCP> respectively will be set, to maintain +compatibility with C<IO::Socket::INET>. Other named arguments that are not +recognised are ignored. + +If neither C<Family> nor any hosts or addresses are passed, nor any +C<*AddrInfo>, then the constructor has no information on which to decide a +socket family to create. In this case, it performs a C<getaddinfo> call with +the C<AI_ADDRCONFIG> flag, no host name, and a service name of C<"0">, and +uses the family of the first returned result. + +If the constructor fails, it will set C<$@> to an appropriate error message; +this may be from C<$!> or it may be some other string; not every failure +necessarily has an associated C<errno> value. + +=head2 $sock = IO::Socket::IP->new( $peeraddr ) + +As a special case, if the constructor is passed a single argument (as +opposed to an even-sized list of key/value pairs), it is taken to be the value +of the C<PeerAddr> parameter. This is parsed in the same way, according to the +behaviour given in the C<PeerHost> AND C<LocalHost> PARSING section below. + +=cut + +sub new +{ + my $class = shift; + my %arg = (@_ == 1) ? (PeerHost => $_[0]) : @_; + return $class->SUPER::new(%arg); +} + +# IO::Socket may call this one; neaten up the arguments from IO::Socket::INET +# before calling our real _configure method +sub configure +{ + my $self = shift; + my ( $arg ) = @_; + + $arg->{PeerHost} = delete $arg->{PeerAddr} + if exists $arg->{PeerAddr} && !exists $arg->{PeerHost}; + + $arg->{PeerService} = delete $arg->{PeerPort} + if exists $arg->{PeerPort} && !exists $arg->{PeerService}; + + $arg->{LocalHost} = delete $arg->{LocalAddr} + if exists $arg->{LocalAddr} && !exists $arg->{LocalHost}; + + $arg->{LocalService} = delete $arg->{LocalPort} + if exists $arg->{LocalPort} && !exists $arg->{LocalService}; + + for my $type (qw(Peer Local)) { + my $host = $type . 'Host'; + my $service = $type . 'Service'; + + if( defined $arg->{$host} ) { + ( $arg->{$host}, my $s ) = $self->split_addr( $arg->{$host} ); + # IO::Socket::INET compat - *Host parsed port always takes precedence + $arg->{$service} = $s if defined $s; + } + } + + $self->_io_socket_ip__configure( $arg ); +} + +# Avoid simply calling it _configure, as some subclasses of IO::Socket::INET on CPAN already take that +sub _io_socket_ip__configure +{ + my $self = shift; + my ( $arg ) = @_; + + my %hints; + my @localinfos; + my @peerinfos; + + my $listenqueue = $arg->{Listen}; + if( defined $listenqueue and + ( defined $arg->{PeerHost} || defined $arg->{PeerService} || defined $arg->{PeerAddrInfo} ) ) { + croak "Cannot Listen with a peer address"; + } + + if( defined $arg->{GetAddrInfoFlags} ) { + $hints{flags} = $arg->{GetAddrInfoFlags}; + } + else { + $hints{flags} = $AI_ADDRCONFIG; + } + + if( defined( my $family = $arg->{Family} ) ) { + $hints{family} = $family; + } + + if( defined( my $type = $arg->{Type} ) ) { + $hints{socktype} = $type; + } + + if( defined( my $proto = $arg->{Proto} ) ) { + unless( $proto =~ m/^\d+$/ ) { + my $protonum = HAVE_GETPROTOBYNAME + ? getprotobyname( $proto ) + : eval { Socket->${\"IPPROTO_\U$proto"}() }; + defined $protonum or croak "Unrecognised protocol $proto"; + $proto = $protonum; + } + + $hints{protocol} = $proto; + } + + # To maintain compatibility with IO::Socket::INET, imply a default of + # SOCK_STREAM + IPPROTO_TCP if neither hint is given + if( !defined $hints{socktype} and !defined $hints{protocol} ) { + $hints{socktype} = SOCK_STREAM; + $hints{protocol} = IPPROTO_TCP; + } + + # Some OSes (NetBSD) don't seem to like just a protocol hint without a + # socktype hint as well. We'll set a couple of common ones + if( !defined $hints{socktype} and defined $hints{protocol} ) { + $hints{socktype} = SOCK_STREAM if $hints{protocol} == IPPROTO_TCP; + $hints{socktype} = SOCK_DGRAM if $hints{protocol} == IPPROTO_UDP; + } + + if( my $info = $arg->{LocalAddrInfo} ) { + ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref"; + @localinfos = @$info; + } + elsif( defined $arg->{LocalHost} or + defined $arg->{LocalService} or + HAVE_MSWIN32 and $arg->{Listen} ) { + # Either may be undef + my $host = $arg->{LocalHost}; + my $service = $arg->{LocalService}; + + unless ( defined $host or defined $service ) { + $service = 0; + } + + local $1; # Placate a taint-related bug; [perl #67962] + defined $service and $service =~ s/\((\d+)\)$// and + my $fallback_port = $1; + + my %localhints = %hints; + $localhints{flags} |= AI_PASSIVE; + ( my $err, @localinfos ) = getaddrinfo( $host, $service, \%localhints ); + + if( $err and defined $fallback_port ) { + ( $err, @localinfos ) = getaddrinfo( $host, $fallback_port, \%localhints ); + } + + if( $err ) { + $@ = "$err"; + $! = EINVAL; + return; + } + } + + if( my $info = $arg->{PeerAddrInfo} ) { + ref $info eq "ARRAY" or croak "Expected 'PeerAddrInfo' to be an ARRAY ref"; + @peerinfos = @$info; + } + elsif( defined $arg->{PeerHost} or defined $arg->{PeerService} ) { + defined( my $host = $arg->{PeerHost} ) or + croak "Expected 'PeerHost'"; + defined( my $service = $arg->{PeerService} ) or + croak "Expected 'PeerService'"; + + local $1; # Placate a taint-related bug; [perl #67962] + defined $service and $service =~ s/\((\d+)\)$// and + my $fallback_port = $1; + + ( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%hints ); + + if( $err and defined $fallback_port ) { + ( $err, @peerinfos ) = getaddrinfo( $host, $fallback_port, \%hints ); + } + + if( $err ) { + $@ = "$err"; + $! = EINVAL; + return; + } + } + + my $INT_1 = pack "i", 1; + + my @sockopts_enabled; + push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEADDR, $INT_1 ] if $arg->{ReuseAddr}; + push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEPORT, $INT_1 ] if $arg->{ReusePort}; + push @sockopts_enabled, [ SOL_SOCKET, SO_BROADCAST, $INT_1 ] if $arg->{Broadcast}; + + if( my $sockopts = $arg->{Sockopts} ) { + ref $sockopts eq "ARRAY" or croak "Expected 'Sockopts' to be an ARRAY ref"; + foreach ( @$sockopts ) { + ref $_ eq "ARRAY" or croak "Bad Sockopts item - expected ARRAYref"; + @$_ >= 2 and @$_ <= 3 or + croak "Bad Sockopts item - expected 2 or 3 elements"; + + my ( $level, $optname, $value ) = @$_; + # TODO: consider more sanity checking on argument values + + defined $value or $value = $INT_1; + push @sockopts_enabled, [ $level, $optname, $value ]; + } + } + + my $blocking = $arg->{Blocking}; + defined $blocking or $blocking = 1; + + my $v6only = $arg->{V6Only}; + + # IO::Socket::INET defines this key. IO::Socket::IP always implements the + # behaviour it requests, so we can ignore it, unless the caller is for some + # reason asking to disable it. + if( defined $arg->{MultiHomed} and !$arg->{MultiHomed} ) { + croak "Cannot disable the MultiHomed parameter"; + } + + my @infos; + foreach my $local ( @localinfos ? @localinfos : {} ) { + foreach my $peer ( @peerinfos ? @peerinfos : {} ) { + next if defined $local->{family} and defined $peer->{family} and + $local->{family} != $peer->{family}; + next if defined $local->{socktype} and defined $peer->{socktype} and + $local->{socktype} != $peer->{socktype}; + next if defined $local->{protocol} and defined $peer->{protocol} and + $local->{protocol} != $peer->{protocol}; + + my $family = $local->{family} || $peer->{family} or next; + my $socktype = $local->{socktype} || $peer->{socktype} or next; + my $protocol = $local->{protocol} || $peer->{protocol} || 0; + + push @infos, { + family => $family, + socktype => $socktype, + protocol => $protocol, + localaddr => $local->{addr}, + peeraddr => $peer->{addr}, + }; + } + } + + if( !@infos ) { + # If there was a Family hint then create a plain unbound, unconnected socket + if( defined $hints{family} ) { + @infos = ( { + family => $hints{family}, + socktype => $hints{socktype}, + protocol => $hints{protocol}, + } ); + } + # If there wasn't, use getaddrinfo()'s AI_ADDRCONFIG side-effect to guess a + # suitable family first. + else { + ( my $err, @infos ) = getaddrinfo( "", "0", \%hints ); + if( $err ) { + $@ = "$err"; + $! = EINVAL; + return; + } + + # We'll take all the @infos anyway, because some OSes (HPUX) are known to + # ignore the AI_ADDRCONFIG hint and return AF_INET6 even if they don't + # support them + } + } + + # In the nonblocking case, caller will be calling ->setup multiple times. + # Store configuration in the object for the ->setup method + # Yes, these are messy. Sorry, I can't help that... + + ${*$self}{io_socket_ip_infos} = \@infos; + + ${*$self}{io_socket_ip_idx} = -1; + + ${*$self}{io_socket_ip_sockopts} = \@sockopts_enabled; + ${*$self}{io_socket_ip_v6only} = $v6only; + ${*$self}{io_socket_ip_listenqueue} = $listenqueue; + ${*$self}{io_socket_ip_blocking} = $blocking; + + ${*$self}{io_socket_ip_errors} = [ undef, undef, undef ]; + + # ->setup is allowed to return false in nonblocking mode + $self->setup or !$blocking or return undef; + + return $self; +} + +sub setup +{ + my $self = shift; + + while(1) { + ${*$self}{io_socket_ip_idx}++; + last if ${*$self}{io_socket_ip_idx} >= @{ ${*$self}{io_socket_ip_infos} }; + + my $info = ${*$self}{io_socket_ip_infos}->[${*$self}{io_socket_ip_idx}]; + + $self->socket( @{$info}{qw( family socktype protocol )} ) or + ( ${*$self}{io_socket_ip_errors}[2] = $!, next ); + + $self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking}; + + foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) { + my ( $level, $optname, $value ) = @$sockopt; + $self->setsockopt( $level, $optname, $value ) or ( $@ = "$!", return undef ); + } + + if( defined ${*$self}{io_socket_ip_v6only} and defined $AF_INET6 and $info->{family} == $AF_INET6 ) { + my $v6only = ${*$self}{io_socket_ip_v6only}; + $self->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, pack "i", $v6only ) or ( $@ = "$!", return undef ); + } + + if( defined( my $addr = $info->{localaddr} ) ) { + $self->bind( $addr ) or + ( ${*$self}{io_socket_ip_errors}[1] = $!, next ); + } + + if( defined( my $listenqueue = ${*$self}{io_socket_ip_listenqueue} ) ) { + $self->listen( $listenqueue ) or ( $@ = "$!", return undef ); + } + + if( defined( my $addr = $info->{peeraddr} ) ) { + if( $self->connect( $addr ) ) { + $! = 0; + return 1; + } + + if( $! == EINPROGRESS or $! == EWOULDBLOCK ) { + ${*$self}{io_socket_ip_connect_in_progress} = 1; + return 0; + } + + # If connect failed but we have no system error there must be an error + # at the application layer, like a bad certificate with + # IO::Socket::SSL. + # In this case don't continue IP based multi-homing because the problem + # cannot be solved at the IP layer. + return 0 if ! $!; + + ${*$self}{io_socket_ip_errors}[0] = $!; + next; + } + + return 1; + } + + # Pick the most appropriate error, stringified + $! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0]; + $@ = "$!"; + return undef; +} + +sub connect :method +{ + my $self = shift; + + # It seems that IO::Socket hides EINPROGRESS errors, making them look like + # a success. This is annoying here. + # Instead of putting up with its frankly-irritating intentional breakage of + # useful APIs I'm just going to end-run around it and call core's connect() + # directly + + if( @_ ) { + my ( $addr ) = @_; + + # Annoyingly IO::Socket's connect() is where the timeout logic is + # implemented, so we'll have to reinvent it here + my $timeout = ${*$self}{'io_socket_timeout'}; + + return connect( $self, $addr ) unless defined $timeout; + + my $was_blocking = $self->blocking( 0 ); + + my $err = defined connect( $self, $addr ) ? 0 : $!+0; + + if( !$err ) { + # All happy + $self->blocking( $was_blocking ); + return 1; + } + elsif( not( $err == EINPROGRESS or $err == EWOULDBLOCK ) ) { + # Failed for some other reason + $self->blocking( $was_blocking ); + return undef; + } + elsif( !$was_blocking ) { + # We shouldn't block anyway + return undef; + } + + my $vec = ''; vec( $vec, $self->fileno, 1 ) = 1; + if( !select( undef, $vec, $vec, $timeout ) ) { + $self->blocking( $was_blocking ); + $! = ETIMEDOUT; + return undef; + } + + # Hoist the error by connect()ing a second time + $err = $self->getsockopt( SOL_SOCKET, SO_ERROR ); + $err = 0 if $err == EISCONN; # Some OSes give EISCONN + + $self->blocking( $was_blocking ); + + $! = $err, return undef if $err; + return 1; + } + + return 1 if !${*$self}{io_socket_ip_connect_in_progress}; + + # See if a connect attempt has just failed with an error + if( my $errno = $self->getsockopt( SOL_SOCKET, SO_ERROR ) ) { + delete ${*$self}{io_socket_ip_connect_in_progress}; + ${*$self}{io_socket_ip_errors}[0] = $! = $errno; + return $self->setup; + } + + # No error, so either connect is still in progress, or has completed + # successfully. We can tell by trying to connect() again; either it will + # succeed or we'll get EISCONN (connected successfully), or EALREADY + # (still in progress). This even works on MSWin32. + my $addr = ${*$self}{io_socket_ip_infos}[${*$self}{io_socket_ip_idx}]{peeraddr}; + + if( connect( $self, $addr ) or $! == EISCONN ) { + delete ${*$self}{io_socket_ip_connect_in_progress}; + $! = 0; + return 1; + } + else { + $! = EINPROGRESS; + return 0; + } +} + +sub connected +{ + my $self = shift; + return defined $self->fileno && + !${*$self}{io_socket_ip_connect_in_progress} && + defined getpeername( $self ); # ->peername caches, we need to detect disconnection +} + +=head1 METHODS + +As well as the following methods, this class inherits all the methods in +L<IO::Socket> and L<IO::Handle>. + +=cut + +sub _get_host_service +{ + my $self = shift; + my ( $addr, $flags, $xflags ) = @_; + + defined $addr or + $! = ENOTCONN, return; + + $flags |= NI_DGRAM if $self->socktype == SOCK_DGRAM; + + my ( $err, $host, $service ) = getnameinfo( $addr, $flags, $xflags || 0 ); + croak "getnameinfo - $err" if $err; + + return ( $host, $service ); +} + +sub _unpack_sockaddr +{ + my ( $addr ) = @_; + my $family = sockaddr_family $addr; + + if( $family == AF_INET ) { + return ( Socket::unpack_sockaddr_in( $addr ) )[1]; + } + elsif( defined $AF_INET6 and $family == $AF_INET6 ) { + return ( Socket::unpack_sockaddr_in6( $addr ) )[1]; + } + else { + croak "Unrecognised address family $family"; + } +} + +=head2 ( $host, $service ) = $sock->sockhost_service( $numeric ) + +Returns the hostname and service name of the local address (that is, the +socket address given by the C<sockname> method). + +If C<$numeric> is true, these will be given in numeric form rather than being +resolved into names. + +The following four convenience wrappers may be used to obtain one of the two +values returned here. If both host and service names are required, this method +is preferable to the following wrappers, because it will call +C<getnameinfo(3)> only once. + +=cut + +sub sockhost_service +{ + my $self = shift; + my ( $numeric ) = @_; + + $self->_get_host_service( $self->sockname, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 ); +} + +=head2 $addr = $sock->sockhost + +Return the numeric form of the local address as a textual representation + +=head2 $port = $sock->sockport + +Return the numeric form of the local port number + +=head2 $host = $sock->sockhostname + +Return the resolved name of the local address + +=head2 $service = $sock->sockservice + +Return the resolved name of the local port number + +=cut + +sub sockhost { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, NI_NUMERICHOST, NIx_NOSERV ) )[0] } +sub sockport { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, NI_NUMERICSERV, NIx_NOHOST ) )[1] } + +sub sockhostname { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, 0, NIx_NOSERV ) )[0] } +sub sockservice { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, 0, NIx_NOHOST ) )[1] } + +=head2 $addr = $sock->sockaddr + +Return the local address as a binary octet string + +=cut + +sub sockaddr { my $self = shift; _unpack_sockaddr $self->sockname } + +=head2 ( $host, $service ) = $sock->peerhost_service( $numeric ) + +Returns the hostname and service name of the peer address (that is, the +socket address given by the C<peername> method), similar to the +C<sockhost_service> method. + +The following four convenience wrappers may be used to obtain one of the two +values returned here. If both host and service names are required, this method +is preferable to the following wrappers, because it will call +C<getnameinfo(3)> only once. + +=cut + +sub peerhost_service +{ + my $self = shift; + my ( $numeric ) = @_; + + $self->_get_host_service( $self->peername, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 ); +} + +=head2 $addr = $sock->peerhost + +Return the numeric form of the peer address as a textual representation + +=head2 $port = $sock->peerport + +Return the numeric form of the peer port number + +=head2 $host = $sock->peerhostname + +Return the resolved name of the peer address + +=head2 $service = $sock->peerservice + +Return the resolved name of the peer port number + +=cut + +sub peerhost { my $self = shift; scalar +( $self->_get_host_service( $self->peername, NI_NUMERICHOST, NIx_NOSERV ) )[0] } +sub peerport { my $self = shift; scalar +( $self->_get_host_service( $self->peername, NI_NUMERICSERV, NIx_NOHOST ) )[1] } + +sub peerhostname { my $self = shift; scalar +( $self->_get_host_service( $self->peername, 0, NIx_NOSERV ) )[0] } +sub peerservice { my $self = shift; scalar +( $self->_get_host_service( $self->peername, 0, NIx_NOHOST ) )[1] } + +=head2 $addr = $peer->peeraddr + +Return the peer address as a binary octet string + +=cut + +sub peeraddr { my $self = shift; _unpack_sockaddr $self->peername } + +# This unbelievably dodgy hack works around the bug that IO::Socket doesn't do +# it +# https://rt.cpan.org/Ticket/Display.html?id=61577 +sub accept +{ + my $self = shift; + my ( $new, $peer ) = $self->SUPER::accept( @_ ) or return; + + ${*$new}{$_} = ${*$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto ); + + return wantarray ? ( $new, $peer ) + : $new; +} + +# This second unbelievably dodgy hack guarantees that $self->fileno doesn't +# change, which is useful during nonblocking connect +sub socket :method +{ + my $self = shift; + return $self->SUPER::socket(@_) if not defined $self->fileno; + + # I hate core prototypes sometimes... + socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef; + + dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!"; +} + +# Versions of IO::Socket before 1.35 may leave socktype undef if from, say, an +# ->fdopen call. In this case we'll apply a fix +BEGIN { + if( eval($IO::Socket::VERSION) < 1.35 ) { + *socktype = sub { + my $self = shift; + my $type = $self->SUPER::socktype; + if( !defined $type ) { + $type = $self->sockopt( Socket::SO_TYPE() ); + } + return $type; + }; + } +} + +=head2 $inet = $sock->as_inet + +Returns a new L<IO::Socket::INET> instance wrapping the same filehandle. This +may be useful in cases where it is required, for backward-compatibility, to +have a real object of C<IO::Socket::INET> type instead of C<IO::Socket::IP>. +The new object will wrap the same underlying socket filehandle as the +original, so care should be taken not to continue to use both objects +concurrently. Ideally the original C<$sock> should be discarded after this +method is called. + +This method checks that the socket domain is C<PF_INET> and will throw an +exception if it isn't. + +=cut + +sub as_inet +{ + my $self = shift; + croak "Cannot downgrade a non-PF_INET socket to IO::Socket::INET" unless $self->sockdomain == AF_INET; + return IO::Socket::INET->new_from_fd( $self->fileno, "r+" ); +} + +=head1 NON-BLOCKING + +If the constructor is passed a defined but false value for the C<Blocking> +argument then the socket is put into non-blocking mode. When in non-blocking +mode, the socket will not be set up by the time the constructor returns, +because the underlying C<connect(2)> syscall would otherwise have to block. + +The non-blocking behaviour is an extension of the C<IO::Socket::INET> API, +unique to C<IO::Socket::IP>, because the former does not support multi-homed +non-blocking connect. + +When using non-blocking mode, the caller must repeatedly check for +writeability on the filehandle (for instance using C<select> or C<IO::Poll>). +Each time the filehandle is ready to write, the C<connect> method must be +called, with no arguments. Note that some operating systems, most notably +C<MSWin32> do not report a C<connect()> failure using write-ready; so you must +also C<select()> for exceptional status. + +While C<connect> returns false, the value of C<$!> indicates whether it should +be tried again (by being set to the value C<EINPROGRESS>, or C<EWOULDBLOCK> on +MSWin32), or whether a permanent error has occurred (e.g. C<ECONNREFUSED>). + +Once the socket has been connected to the peer, C<connect> will return true +and the socket will now be ready to use. + +Note that calls to the platform's underlying C<getaddrinfo(3)> function may +block. If C<IO::Socket::IP> has to perform this lookup, the constructor will +block even when in non-blocking mode. + +To avoid this blocking behaviour, the caller should pass in the result of such +a lookup using the C<PeerAddrInfo> or C<LocalAddrInfo> arguments. This can be +achieved by using L<Net::LibAsyncNS>, or the C<getaddrinfo(3)> function can be +called in a child process. + + use IO::Socket::IP; + use Errno qw( EINPROGRESS EWOULDBLOCK ); + + my @peeraddrinfo = ... # Caller must obtain the getaddinfo result here + + my $socket = IO::Socket::IP->new( + PeerAddrInfo => \@peeraddrinfo, + Blocking => 0, + ) or die "Cannot construct socket - $@"; + + while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) { + my $wvec = ''; + vec( $wvec, fileno $socket, 1 ) = 1; + my $evec = ''; + vec( $evec, fileno $socket, 1 ) = 1; + + select( undef, $wvec, $evec, undef ) or die "Cannot select - $!"; + } + + die "Cannot connect - $!" if $!; + + ... + +The example above uses C<select()>, but any similar mechanism should work +analogously. C<IO::Socket::IP> takes care when creating new socket filehandles +to preserve the actual file descriptor number, so such techniques as C<poll> +or C<epoll> should be transparent to its reallocation of a different socket +underneath, perhaps in order to switch protocol family between C<PF_INET> and +C<PF_INET6>. + +For another example using C<IO::Poll> and C<Net::LibAsyncNS>, see the +F<examples/nonblocking_libasyncns.pl> file in the module distribution. + +=cut + +=head1 C<PeerHost> AND C<LocalHost> PARSING + +To support the C<IO::Socket::INET> API, the host and port information may be +passed in a single string rather than as two separate arguments. + +If either C<LocalHost> or C<PeerHost> (or their C<...Addr> synonyms) have any +of the following special forms then special parsing is applied. + +The value of the C<...Host> argument will be split to give both the hostname +and port (or service name): + + hostname.example.org:http # Host name + 192.0.2.1:80 # IPv4 address + [2001:db8::1]:80 # IPv6 address + +In each case, the port or service name (e.g. C<80>) is passed as the +C<LocalService> or C<PeerService> argument. + +Either of C<LocalService> or C<PeerService> (or their C<...Port> synonyms) can +be either a service name, a decimal number, or a string containing both a +service name and number, in a form such as + + http(80) + +In this case, the name (C<http>) will be tried first, but if the resolver does +not understand it then the port number (C<80>) will be used instead. + +If the C<...Host> argument is in this special form and the corresponding +C<...Service> or C<...Port> argument is also defined, the one parsed from +the C<...Host> argument will take precedence and the other will be ignored. + +=head2 ( $host, $port ) = IO::Socket::IP->split_addr( $addr ) + +Utility method that provides the parsing functionality described above. +Returns a 2-element list, containing either the split hostname and port +description if it could be parsed, or the given address and C<undef> if it was +not recognised. + + IO::Socket::IP->split_addr( "hostname:http" ) + # ( "hostname", "http" ) + + IO::Socket::IP->split_addr( "192.0.2.1:80" ) + # ( "192.0.2.1", "80" ) + + IO::Socket::IP->split_addr( "[2001:db8::1]:80" ) + # ( "2001:db8::1", "80" ) + + IO::Socket::IP->split_addr( "something.else" ) + # ( "something.else", undef ) + +=cut + +sub split_addr +{ + shift; + my ( $addr ) = @_; + + local ( $1, $2 ); # Placate a taint-related bug; [perl #67962] + if( $addr =~ m/\A\[($IPv6_re)\](?::([^\s:]*))?\z/ or + $addr =~ m/\A([^\s:]*):([^\s:]*)\z/ ) { + return ( $1, $2 ) if defined $2 and length $2; + return ( $1, undef ); + } + + return ( $addr, undef ); +} + +=head2 $addr = IO::Socket::IP->join_addr( $host, $port ) + +Utility method that performs the reverse of C<split_addr>, returning a string +formed by joining the specified host address and port number. The host address +will be wrapped in C<[]> brackets if required (because it is a raw IPv6 +numeric address). + +This can be especially useful when combined with the C<sockhost_service> or +C<peerhost_service> methods. + + say "Connected to ", IO::Socket::IP->join_addr( $sock->peerhost_service ); + +=cut + +sub join_addr +{ + shift; + my ( $host, $port ) = @_; + + $host = "[$host]" if $host =~ m/:/; + + return join ":", $host, $port if defined $port; + return $host; +} + +# Since IO::Socket->new( Domain => ... ) will delete the Domain parameter +# before calling ->configure, we need to keep track of which it was + +package # hide from indexer + IO::Socket::IP::_ForINET; +use base qw( IO::Socket::IP ); + +sub configure +{ + # This is evil + my $self = shift; + my ( $arg ) = @_; + + bless $self, "IO::Socket::IP"; + $self->configure( { %$arg, Family => Socket::AF_INET() } ); +} + +package # hide from indexer + IO::Socket::IP::_ForINET6; +use base qw( IO::Socket::IP ); + +sub configure +{ + # This is evil + my $self = shift; + my ( $arg ) = @_; + + bless $self, "IO::Socket::IP"; + $self->configure( { %$arg, Family => Socket::AF_INET6() } ); +} + +=head1 C<IO::Socket::INET> INCOMPATIBILITES + +=over 4 + +=item * + +The behaviour enabled by C<MultiHomed> is in fact implemented by +C<IO::Socket::IP> as it is required to correctly support searching for a +useable address from the results of the C<getaddrinfo(3)> call. The +constructor will ignore the value of this argument, except if it is defined +but false. An exception is thrown in this case, because that would request it +disable the C<getaddrinfo(3)> search behaviour in the first place. + +=item * + +C<IO::Socket::IP> implements both the C<Blocking> and C<Timeout> parameters, +but it implements the interaction of both in a different way. + +In C<::INET>, supplying a timeout overrides the non-blocking behaviour, +meaning that the C<connect()> operation will still block despite that the +caller asked for a non-blocking socket. This is not explicitly specified in +its documentation, nor does this author believe that is a useful behaviour - +it appears to come from a quirk of implementation. + +In C<::IP> therefore, the C<Blocking> parameter takes precedence - if a +non-blocking socket is requested, no operation will block. The C<Timeout> +parameter here simply defines the maximum time that a blocking C<connect()> +call will wait, if it blocks at all. + +In order to specifically obtain the "blocking connect then non-blocking send +and receive" behaviour of specifying this combination of options to C<::INET> +when using C<::IP>, perform first a blocking connect, then afterwards turn the +socket into nonblocking mode. + + my $sock = IO::Socket::IP->new( + PeerHost => $peer, + Timeout => 20, + ) or die "Cannot connect - $@"; + + $sock->blocking( 0 ); + +This code will behave identically under both C<IO::Socket::INET> and +C<IO::Socket::IP>. + +=back + +=cut + +=head1 TODO + +=over 4 + +=item * + +Investigate whether C<POSIX::dup2> upsets BSD's C<kqueue> watchers, and if so, +consider what possible workarounds might be applied. + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket/UNIX.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket/UNIX.pm new file mode 100644 index 0000000000..a46dd593d6 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Socket/UNIX.pm @@ -0,0 +1,157 @@ +# IO::Socket::UNIX.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Socket::UNIX; + +use strict; +use IO::Socket; +use Carp; + +our @ISA = qw(IO::Socket); +our $VERSION = "1.39"; + +IO::Socket::UNIX->register_domain( AF_UNIX ); + +sub new { + my $class = shift; + unshift(@_, "Peer") if @_ == 1; + return $class->SUPER::new(@_); +} + +sub configure { + my($sock,$arg) = @_; + my($bport,$cport); + + my $type = $arg->{Type} || SOCK_STREAM; + + $sock->socket(AF_UNIX, $type, 0) or + return undef; + + if(exists $arg->{Local}) { + my $addr = sockaddr_un($arg->{Local}); + $sock->bind($addr) or + return undef; + } + if(exists $arg->{Listen} && $type != SOCK_DGRAM) { + $sock->listen($arg->{Listen} || 5) or + return undef; + } + elsif(exists $arg->{Peer}) { + my $addr = sockaddr_un($arg->{Peer}); + $sock->connect($addr) or + return undef; + } + + $sock; +} + +sub hostpath { + @_ == 1 or croak 'usage: $sock->hostpath()'; + my $n = $_[0]->sockname || return undef; + (sockaddr_un($n))[0]; +} + +sub peerpath { + @_ == 1 or croak 'usage: $sock->peerpath()'; + my $n = $_[0]->peername || return undef; + (sockaddr_un($n))[0]; +} + +1; # Keep require happy + +__END__ + +=head1 NAME + +IO::Socket::UNIX - Object interface for AF_UNIX domain sockets + +=head1 SYNOPSIS + + use IO::Socket::UNIX; + + my $SOCK_PATH = "$ENV{HOME}/unix-domain-socket-test.sock"; + + # Server: + my $server = IO::Socket::UNIX->new( + Type => SOCK_STREAM(), + Local => $SOCK_PATH, + Listen => 1, + ); + + my $count = 1; + while (my $conn = $server->accept()) { + $conn->print("Hello " . ($count++) . "\n"); + } + + # Client: + my $client = IO::Socket::UNIX->new( + Type => SOCK_STREAM(), + Peer => $SOCK_PATH, + ); + + # Now read and write from $client + +=head1 DESCRIPTION + +C<IO::Socket::UNIX> provides an object interface to creating and using sockets +in the AF_UNIX domain. It is built upon the L<IO::Socket> interface and +inherits all the methods defined by L<IO::Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket::UNIX> object, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. + +In addition to the key-value pairs accepted by L<IO::Socket>, +C<IO::Socket::UNIX> provides. + + Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM) + Local Path to local fifo + Peer Path to peer fifo + Listen Queue size for listen + +If the constructor is only passed a single argument, it is assumed to +be a C<Peer> specification. + +If the C<Listen> argument is given, but false, the queue size will be set to 5. + +=back + +=head1 METHODS + +=over 4 + +=item hostpath() + +Returns the pathname to the fifo at the local end + +=item peerpath() + +Returns the pathanme to the fifo at the peer end + +=back + +=head1 SEE ALSO + +L<Socket>, L<IO::Socket> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perlbug@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Bunzip2.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Bunzip2.pm new file mode 100644 index 0000000000..2bd5e24236 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Bunzip2.pm @@ -0,0 +1,112 @@ +package IO::Uncompress::Adapter::Bunzip2; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.074 qw(:Status); + +use Compress::Raw::Bzip2 2.074 ; + +our ($VERSION, @ISA); +$VERSION = '2.074'; + +sub mkUncompObject +{ + my $small = shift || 0; + my $verbosity = shift || 0; + + my ($inflate, $status) = new Compress::Raw::Bunzip2(1, 1, $small, $verbosity, 1); + + return (undef, "Could not create Inflation object: $status", $status) + if $status != BZ_OK ; + + return bless {'Inf' => $inflate, + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + 'ConsumesInput' => 1, + } ; + +} + +sub uncompr +{ + my $self = shift ; + my $from = shift ; + my $to = shift ; + my $eof = shift ; + + my $inf = $self->{Inf}; + + my $status = $inf->bzinflate($from, $to); + $self->{ErrorNo} = $status; + + if ($status != BZ_OK && $status != BZ_STREAM_END ) + { + $self->{Error} = "Inflation Error: $status"; + return STATUS_ERROR; + } + + + return STATUS_OK if $status == BZ_OK ; + return STATUS_ENDSTREAM if $status == BZ_STREAM_END ; + return STATUS_ERROR ; +} + + +sub reset +{ + my $self = shift ; + + my ($inf, $status) = new Compress::Raw::Bunzip2(); + $self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ; + + if ($status != BZ_OK) + { + $self->{Error} = "Cannot create Inflate object: $status"; + return STATUS_ERROR; + } + + $self->{Inf} = $inf; + + return STATUS_OK ; +} + +sub compressedBytes +{ + my $self = shift ; + $self->{Inf}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Inf}->uncompressedBytes(); +} + +sub crc32 +{ + my $self = shift ; + #$self->{Inf}->crc32(); +} + +sub adler32 +{ + my $self = shift ; + #$self->{Inf}->adler32(); +} + +sub sync +{ + my $self = shift ; + #( $self->{Inf}->inflateSync(@_) == BZ_OK) + # ? STATUS_OK + # : STATUS_ERROR ; +} + + +1; + +__END__ + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm new file mode 100644 index 0000000000..3327fbc4bc --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm @@ -0,0 +1,188 @@ +package IO::Uncompress::Adapter::Identity; + +use warnings; +use strict; +use bytes; + +use IO::Compress::Base::Common 2.074 qw(:Status); +use IO::Compress::Zip::Constants ; + +our ($VERSION); + +$VERSION = '2.074'; + +use Compress::Raw::Zlib 2.074 (); + +sub mkUncompObject +{ + my $streaming = shift; + my $zip64 = shift; + + my $crc32 = 1; #shift ; + my $adler32 = shift; + + bless { 'CompSize' => new U64 , # 0, + 'UnCompSize' => 0, + 'wantCRC32' => $crc32, + 'CRC32' => Compress::Raw::Zlib::crc32(''), + 'wantADLER32'=> $adler32, + 'ADLER32' => Compress::Raw::Zlib::adler32(''), + 'ConsumesInput' => 1, + 'Streaming' => $streaming, + 'Zip64' => $zip64, + 'DataHdrSize' => $zip64 ? 24 : 16, + 'Pending' => '', + + } ; +} + + +sub uncompr +{ + my $self = shift; + my $in = $_[0]; + my $eof = $_[2]; + + my $len = length $$in; + my $remainder = ''; + + if (defined $$in && $len) { + + if ($self->{Streaming}) { + + if (length $self->{Pending}) { + $$in = $self->{Pending} . $$in ; + $len = length $$in; + $self->{Pending} = ''; + } + + my $ind = index($$in, "\x50\x4b\x07\x08"); + + if ($ind < 0) { + $len = length $$in; + if ($len >= 3 && substr($$in, -3) eq "\x50\x4b\x07") { + $ind = $len - 3 ; + } + elsif ($len >= 2 && substr($$in, -2) eq "\x50\x4b") { + $ind = $len - 2 ; + } + elsif ($len >= 1 && substr($$in, -1) eq "\x50") { + $ind = $len - 1 ; + } + } + + if ($ind >= 0) { + $remainder = substr($$in, $ind) ; + substr($$in, $ind) = '' ; + } + } + + if (length $remainder && length $remainder < $self->{DataHdrSize}) { + $self->{Pending} = $remainder ; + $remainder = ''; + } + elsif (length $remainder >= $self->{DataHdrSize}) { + my $crc = unpack "V", substr($remainder, 4); + if ($crc == Compress::Raw::Zlib::crc32($$in, $self->{CRC32})) { + my ($l1, $l2) ; + + if ($self->{Zip64}) { + $l1 = U64::newUnpack_V64(substr($remainder, 8)); + $l2 = U64::newUnpack_V64(substr($remainder, 16)); + } + else { + $l1 = U64::newUnpack_V32(substr($remainder, 8)); + $l2 = U64::newUnpack_V32(substr($remainder, 12)); + } + + my $newLen = $self->{CompSize}->clone(); + $newLen->add(length $$in); + if ($l1->equal($l2) && $l1->equal($newLen) ) { + $eof = 1; + } + else { + $$in .= substr($remainder, 0, 4) ; + $remainder = substr($remainder, 4); + #$self->{Pending} = substr($remainder, 4); + #$remainder = ''; + $eof = 0; + } + } + else { + $$in .= substr($remainder, 0, 4) ; + $remainder = substr($remainder, 4); + #$self->{Pending} = substr($remainder, 4); + #$remainder = ''; + $eof = 0; + } + } + + if (length $$in) { + $self->{CompSize}->add(length $$in) ; + + $self->{CRC32} = Compress::Raw::Zlib::crc32($$in, $self->{CRC32}) + if $self->{wantCRC32}; + + $self->{ADLER32} = Compress::Zlib::adler32($$in, $self->{ADLER32}) + if $self->{wantADLER32}; + } + + ${ $_[1] } .= $$in; + $$in = $remainder; + } + + return STATUS_ENDSTREAM if $eof; + return STATUS_OK ; +} + +sub reset +{ + my $self = shift; + + $self->{CompSize} = 0; + $self->{UnCompSize} = 0; + $self->{CRC32} = Compress::Raw::Zlib::crc32(''); + $self->{ADLER32} = Compress::Raw::Zlib::adler32(''); + + return STATUS_OK ; +} + +#sub count +#{ +# my $self = shift ; +# return $self->{UnCompSize} ; +#} + +sub compressedBytes +{ + my $self = shift ; + return $self->{CompSize} ; +} + +sub uncompressedBytes +{ + my $self = shift ; + return $self->{CompSize} ; +} + +sub sync +{ + return STATUS_OK ; +} + +sub crc32 +{ + my $self = shift ; + return $self->{CRC32}; +} + +sub adler32 +{ + my $self = shift ; + return $self->{ADLER32}; +} + + +1; + +__END__ diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Inflate.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Inflate.pm new file mode 100644 index 0000000000..256d8409dd --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Inflate.pm @@ -0,0 +1,158 @@ +package IO::Uncompress::Adapter::Inflate; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.074 qw(:Status); +use Compress::Raw::Zlib 2.074 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); + +our ($VERSION); +$VERSION = '2.074'; + + + +sub mkUncompObject +{ + my $crc32 = shift || 1; + my $adler32 = shift || 1; + my $scan = shift || 0; + + my $inflate ; + my $status ; + + if ($scan) + { + ($inflate, $status) = new Compress::Raw::Zlib::InflateScan + #LimitOutput => 1, + CRC32 => $crc32, + ADLER32 => $adler32, + WindowBits => - MAX_WBITS ; + } + else + { + ($inflate, $status) = new Compress::Raw::Zlib::Inflate + AppendOutput => 1, + LimitOutput => 1, + CRC32 => $crc32, + ADLER32 => $adler32, + WindowBits => - MAX_WBITS ; + } + + return (undef, "Could not create Inflation object: $status", $status) + if $status != Z_OK ; + + return bless {'Inf' => $inflate, + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + 'ConsumesInput' => 1, + } ; + +} + +sub uncompr +{ + my $self = shift ; + my $from = shift ; + my $to = shift ; + my $eof = shift ; + + my $inf = $self->{Inf}; + + my $status = $inf->inflate($from, $to, $eof); + $self->{ErrorNo} = $status; + + if ($status != Z_OK && $status != Z_STREAM_END && $status != Z_BUF_ERROR) + { + $self->{Error} = "Inflation Error: $status"; + return STATUS_ERROR; + } + + return STATUS_OK if $status == Z_BUF_ERROR ; # ??? + return STATUS_OK if $status == Z_OK ; + return STATUS_ENDSTREAM if $status == Z_STREAM_END ; + return STATUS_ERROR ; +} + +sub reset +{ + my $self = shift ; + $self->{Inf}->inflateReset(); + + return STATUS_OK ; +} + +#sub count +#{ +# my $self = shift ; +# $self->{Inf}->inflateCount(); +#} + +sub crc32 +{ + my $self = shift ; + $self->{Inf}->crc32(); +} + +sub compressedBytes +{ + my $self = shift ; + $self->{Inf}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Inf}->uncompressedBytes(); +} + +sub adler32 +{ + my $self = shift ; + $self->{Inf}->adler32(); +} + +sub sync +{ + my $self = shift ; + ( $self->{Inf}->inflateSync(@_) == Z_OK) + ? STATUS_OK + : STATUS_ERROR ; +} + + +sub getLastBlockOffset +{ + my $self = shift ; + $self->{Inf}->getLastBlockOffset(); +} + +sub getEndOffset +{ + my $self = shift ; + $self->{Inf}->getEndOffset(); +} + +sub resetLastBlockByte +{ + my $self = shift ; + $self->{Inf}->resetLastBlockByte(@_); +} + +sub createDeflateStream +{ + my $self = shift ; + my $deflate = $self->{Inf}->createDeflateStream(@_); + return bless {'Def' => $deflate, + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + }, 'IO::Compress::Adapter::Deflate'; +} + +1; + + +__END__ + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm new file mode 100644 index 0000000000..40264960fd --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm @@ -0,0 +1,1002 @@ +package IO::Uncompress::AnyInflate ; + +# for RFC1950, RFC1951 or RFC1952 + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.074 (); + +use IO::Uncompress::Adapter::Inflate 2.074 (); + + +use IO::Uncompress::Base 2.074 ; +use IO::Uncompress::Gunzip 2.074 ; +use IO::Uncompress::Inflate 2.074 ; +use IO::Uncompress::RawInflate 2.074 ; +use IO::Uncompress::Unzip 2.074 ; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError); + +$VERSION = '2.074'; +$AnyInflateError = ''; + +@ISA = qw(IO::Uncompress::Base Exporter); +@EXPORT_OK = qw( $AnyInflateError anyinflate ) ; +%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + +# TODO - allow the user to pick a set of the three formats to allow +# or just assume want to auto-detect any of the three formats. + +sub new +{ + my $class = shift ; + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$AnyInflateError); + $obj->_create(undef, 0, @_); +} + +sub anyinflate +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$AnyInflateError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + use IO::Compress::Base::Common 2.074 qw(:Parse); + return ( 'rawinflate' => [Parse_boolean, 0] ) ; +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # any always needs both crc32 and adler32 + $got->setValue('crc32' => 1); + $got->setValue('adler32' => 1); + + return 1; +} + +sub mkUncomp +{ + my $self = shift ; + my $got = shift ; + + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + my @possible = qw( Inflate Gunzip Unzip ); + unshift @possible, 'RawInflate' + if 1 || $got->getValue('rawinflate'); + + my $magic = $self->ckMagic( @possible ); + + if ($magic) { + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + return 1; + } + + return 0 ; +} + + + +sub ckMagic +{ + my $self = shift; + my @names = @_ ; + + my $keep = ref $self ; + for my $class ( map { "IO::Uncompress::$_" } @names) + { + bless $self => $class; + my $magic = $self->ckMagic(); + + if ($magic) + { + #bless $self => $class; + return $magic ; + } + + $self->pushBack(*$self->{HeaderPending}) ; + *$self->{HeaderPending} = '' ; + } + + bless $self => $keep; + return undef; +} + +1 ; + +__END__ + + +=head1 NAME + +IO::Uncompress::AnyInflate - Uncompress zlib-based (zip, gzip) file/buffer + +=head1 SYNOPSIS + + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + my $status = anyinflate $input => $output [,OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + + my $z = new IO::Uncompress::AnyInflate $input [OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $status = $z->inflateSync() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $AnyInflateError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + +=head1 DESCRIPTION + +This module provides a Perl interface that allows the reading of +files/buffers that have been compressed in a number of formats that use the +zlib compression library. + +The formats supported are + +=over 5 + +=item RFC 1950 + +=item RFC 1951 (optionally) + +=item gzip (RFC 1952) + +=item zip + +=back + +The module will auto-detect which, if any, of the supported +compression formats is being used. + +=head1 Functional Interface + +A top-level function, C<anyinflate>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + anyinflate $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 anyinflate $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<anyinflate> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<anyinflate> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the uncompressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +uncompressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +uncompressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +uncompressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the uncompressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<anyinflate> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple compressed +files/buffers and C<$output_filename_or_reference> is +a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<anyinflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<anyinflate> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<anyinflate> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all uncompressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +uncompressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any uncompressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any uncompressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all uncompressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any uncompressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all uncompressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any uncompressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any uncompressed data is output. + +Defaults to 0. + +=item C<< MultiStream => 0|1 >> + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt.Compressed> and write the +uncompressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + my $input = "file1.txt.Compressed"; + my $output = "file1.txt"; + anyinflate $input => $output + or die "anyinflate failed: $AnyInflateError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.Compressed" + or die "Cannot open 'file1.txt.Compressed': $!\n" ; + my $buffer ; + anyinflate $input => \$buffer + or die "anyinflate failed: $AnyInflateError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.Compressed" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + anyinflate '</my/home/*.txt.Compressed>' => '</my/home/#1.txt>' + or die "anyinflate failed: $AnyInflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + + for my $input ( glob "/my/home/*.txt.Compressed" ) + { + my $output = $input; + $output =~ s/.Compressed// ; + anyinflate $input => $output + or die "Error compressing '$input': $AnyInflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::AnyInflate is shown below + + my $z = new IO::Uncompress::AnyInflate $input [OPTS] + or die "IO::Uncompress::AnyInflate failed: $AnyInflateError\n"; + +Returns an C<IO::Uncompress::AnyInflate> object on success and undef on failure. +The variable C<$AnyInflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::AnyInflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$input>. + +=back + +=head2 Constructor Options + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::AnyInflate object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/buffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::AnyInflate will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + +If the input is an RFC 1950 data stream, the following will be checked: + +=over 5 + +=item 1 + +The ADLER32 checksum field must be present. + +=item 2 + +The value of the ADLER32 field read must match the adler32 value of the +uncompressed data actually contained in the file. + +=back + +If the input is a gzip (RFC 1952) data stream, the following will be checked: + +=over 5 + +=item 1 + +If the FHCRC bit is set in the gzip FLG header byte, the CRC16 bytes in the +header must match the crc16 value of the gzip header actually read. + +=item 2 + +If the gzip header contains a name field (FNAME) it consists solely of ISO +8859-1 characters. + +=item 3 + +If the gzip header contains a comment field (FCOMMENT) it consists solely +of ISO 8859-1 characters plus line-feed. + +=item 4 + +If the gzip FEXTRA header field is present it must conform to the sub-field +structure as defined in RFC 1952. + +=item 5 + +The CRC32 and ISIZE trailer fields must be present. + +=item 6 + +The value of the CRC32 field read must match the crc32 value of the +uncompressed data actually contained in the gzip file. + +=item 7 + +The value of the ISIZE fields read must match the length of the +uncompressed data actually read from the file. + +=back + +=item C<< RawInflate => 0|1 >> + +When auto-detecting the compressed format, try to test for raw-deflate (RFC +1951) content using the C<IO::Uncompress::RawInflate> module. + +The reason this is not default behaviour is because RFC 1951 content can +only be detected by attempting to uncompress it. This process is error +prone and can result is false positives. + +Defaults to 0. + +=item C<< ParseExtra => 0|1 >> +If the gzip FEXTRA header field is present and this option is set, it will +force the module to check that it conforms to the sub-field structure as +defined in RFC 1952. + +If the C<Strict> is on it will automatically enable this option. + +Defaults to 0. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size of the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the end of the compressed input stream has been reached. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + +Note that the implementation of C<seek> in this module does not provide +true random access to a compressed file/buffer. It works by uncompressing +data from the current offset in the file/buffer until it reaches the +uncompressed offset specified in the parameters to C<seek>. For very small +files this may be acceptable behaviour. For large files it may cause an +unacceptable delay. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to determine what constitutes a line +terminator. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::AnyInflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::AnyInflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::AnyInflate at present. + +=over 5 + +=item :all + +Imports C<anyinflate> and C<$AnyInflateError>. +Same as doing this + + use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; + +=back + +=head1 EXAMPLES + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +L<http://www.faqs.org/rfcs/rfc1950.html>, +L<http://www.faqs.org/rfcs/rfc1951.html> and +L<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +L<http://www.zlib.org>. + +The primary site for gzip is L<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm new file mode 100644 index 0000000000..e149a129ac --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm @@ -0,0 +1,1034 @@ +package IO::Uncompress::AnyUncompress ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.074 (); + +use IO::Uncompress::Base 2.074 ; + + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError); + +$VERSION = '2.074'; +$AnyUncompressError = ''; + +@ISA = qw(IO::Uncompress::Base Exporter); +@EXPORT_OK = qw( $AnyUncompressError anyuncompress ) ; +%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + +# TODO - allow the user to pick a set of the three formats to allow +# or just assume want to auto-detect any of the three formats. + +BEGIN +{ + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + eval ' use IO::Uncompress::Adapter::Inflate 2.074 ;'; + eval ' use IO::Uncompress::Adapter::Bunzip2 2.074 ;'; + eval ' use IO::Uncompress::Adapter::LZO 2.074 ;'; + eval ' use IO::Uncompress::Adapter::Lzf 2.074 ;'; + eval ' use IO::Uncompress::Adapter::UnLzma 2.074 ;'; + eval ' use IO::Uncompress::Adapter::UnXz 2.074 ;'; + + eval ' use IO::Uncompress::Bunzip2 2.074 ;'; + eval ' use IO::Uncompress::UnLzop 2.074 ;'; + eval ' use IO::Uncompress::Gunzip 2.074 ;'; + eval ' use IO::Uncompress::Inflate 2.074 ;'; + eval ' use IO::Uncompress::RawInflate 2.074 ;'; + eval ' use IO::Uncompress::Unzip 2.074 ;'; + eval ' use IO::Uncompress::UnLzf 2.074 ;'; + eval ' use IO::Uncompress::UnLzma 2.074 ;'; + eval ' use IO::Uncompress::UnXz 2.074 ;'; +} + +sub new +{ + my $class = shift ; + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$AnyUncompressError); + $obj->_create(undef, 0, @_); +} + +sub anyuncompress +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$AnyUncompressError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + return ( 'rawinflate' => [IO::Compress::Base::Common::Parse_boolean, 0] , + 'unlzma' => [IO::Compress::Base::Common::Parse_boolean, 0] ) ; +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # any always needs both crc32 and adler32 + $got->setValue('crc32' => 1); + $got->setValue('adler32' => 1); + + return 1; +} + +sub mkUncomp +{ + my $self = shift ; + my $got = shift ; + + my $magic ; + + # try zlib first + if (defined $IO::Uncompress::RawInflate::VERSION ) + { + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + my @possible = qw( Inflate Gunzip Unzip ); + unshift @possible, 'RawInflate' + if $got->getValue('rawinflate'); + + $magic = $self->ckMagic( @possible ); + + if ($magic) { + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + return 1; + } + } + + if (defined $IO::Uncompress::UnLzma::VERSION && $got->getValue('unlzma')) + { + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::UnLzma::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + my @possible = qw( UnLzma ); + #unshift @possible, 'RawInflate' + # if $got->getValue('rawinflate'); + + if ( *$self->{Info} = $self->ckMagic( @possible )) + { + return 1; + } + } + + if (defined $IO::Uncompress::UnXz::VERSION and + $magic = $self->ckMagic('UnXz')) { + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + my ($obj, $errstr, $errno) = + IO::Uncompress::Adapter::UnXz::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + return 1; + } + + if (defined $IO::Uncompress::Bunzip2::VERSION and + $magic = $self->ckMagic('Bunzip2')) { + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Bunzip2::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + return 1; + } + + if (defined $IO::Uncompress::UnLzop::VERSION and + $magic = $self->ckMagic('UnLzop')) { + + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::LZO::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + return 1; + } + + if (defined $IO::Uncompress::UnLzf::VERSION and + $magic = $self->ckMagic('UnLzf')) { + + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Lzf::mkUncompObject(); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + return 1; + } + + return 0 ; +} + + + +sub ckMagic +{ + my $self = shift; + my @names = @_ ; + + my $keep = ref $self ; + for my $class ( map { "IO::Uncompress::$_" } @names) + { + bless $self => $class; + my $magic = $self->ckMagic(); + + if ($magic) + { + #bless $self => $class; + return $magic ; + } + + $self->pushBack(*$self->{HeaderPending}) ; + *$self->{HeaderPending} = '' ; + } + + bless $self => $keep; + return undef; +} + +1 ; + +__END__ + + +=head1 NAME + +IO::Uncompress::AnyUncompress - Uncompress gzip, zip, bzip2 or lzop file/buffer + +=head1 SYNOPSIS + + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + + my $status = anyuncompress $input => $output [,OPTS] + or die "anyuncompress failed: $AnyUncompressError\n"; + + my $z = new IO::Uncompress::AnyUncompress $input [OPTS] + or die "anyuncompress failed: $AnyUncompressError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $AnyUncompressError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + +=head1 DESCRIPTION + +This module provides a Perl interface that allows the reading of +files/buffers that have been compressed with a variety of compression +libraries. + +The formats supported are: + +=over 5 + +=item RFC 1950 + +=item RFC 1951 (optionally) + +=item gzip (RFC 1952) + +=item zip + +=item bzip2 + +=item lzop + +=item lzf + +=item lzma + +=item xz + +=back + +The module will auto-detect which, if any, of the supported +compression formats is being used. + +=head1 Functional Interface + +A top-level function, C<anyuncompress>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + + anyuncompress $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "anyuncompress failed: $AnyUncompressError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 anyuncompress $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<anyuncompress> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<anyuncompress> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the uncompressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +uncompressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +uncompressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +uncompressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the uncompressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<anyuncompress> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple compressed +files/buffers and C<$output_filename_or_reference> is +a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<anyuncompress>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<anyuncompress> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<anyuncompress> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all uncompressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +uncompressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any uncompressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any uncompressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all uncompressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any uncompressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all uncompressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any uncompressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any uncompressed data is output. + +Defaults to 0. + +=item C<< MultiStream => 0|1 >> + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt.Compressed> and write the +uncompressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + + my $input = "file1.txt.Compressed"; + my $output = "file1.txt"; + anyuncompress $input => $output + or die "anyuncompress failed: $AnyUncompressError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.Compressed" + or die "Cannot open 'file1.txt.Compressed': $!\n" ; + my $buffer ; + anyuncompress $input => \$buffer + or die "anyuncompress failed: $AnyUncompressError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.Compressed" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + + anyuncompress '</my/home/*.txt.Compressed>' => '</my/home/#1.txt>' + or die "anyuncompress failed: $AnyUncompressError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + + for my $input ( glob "/my/home/*.txt.Compressed" ) + { + my $output = $input; + $output =~ s/.Compressed// ; + anyuncompress $input => $output + or die "Error compressing '$input': $AnyUncompressError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::AnyUncompress is shown below + + my $z = new IO::Uncompress::AnyUncompress $input [OPTS] + or die "IO::Uncompress::AnyUncompress failed: $AnyUncompressError\n"; + +Returns an C<IO::Uncompress::AnyUncompress> object on success and undef on failure. +The variable C<$AnyUncompressError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::AnyUncompress can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$input>. + +=back + +=head2 Constructor Options + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::AnyUncompress object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/buffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::AnyUncompress will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + +=item C<< RawInflate => 0|1 >> + +When auto-detecting the compressed format, try to test for raw-deflate (RFC +1951) content using the C<IO::Uncompress::RawInflate> module. + +The reason this is not default behaviour is because RFC 1951 content can +only be detected by attempting to uncompress it. This process is error +prone and can result is false positives. + +Defaults to 0. + +=item C<< UnLzma => 0|1 >> + +When auto-detecting the compressed format, try to test for lzma_alone +content using the C<IO::Uncompress::UnLzma> module. + +The reason this is not default behaviour is because lzma_alone content can +only be detected by attempting to uncompress it. This process is error +prone and can result is false positives. + +Defaults to 0. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size of the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the end of the compressed input stream has been reached. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + +Note that the implementation of C<seek> in this module does not provide +true random access to a compressed file/buffer. It works by uncompressing +data from the current offset in the file/buffer until it reaches the +uncompressed offset specified in the parameters to C<seek>. For very small +files this may be acceptable behaviour. For large files it may cause an +unacceptable delay. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to determine what constitutes a line +terminator. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::AnyUncompress object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::AnyUncompress +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::AnyUncompress at present. + +=over 5 + +=item :all + +Imports C<anyuncompress> and C<$AnyUncompressError>. +Same as doing this + + use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; + +=back + +=head1 EXAMPLES + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Base.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Base.pm new file mode 100644 index 0000000000..4ba3efab16 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Base.pm @@ -0,0 +1,1556 @@ + +package IO::Uncompress::Base ; + +use strict ; +use warnings; +use bytes; + +our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS); +@ISA = qw(IO::File Exporter); + + +$VERSION = '2.074'; + +use constant G_EOF => 0 ; +use constant G_ERR => -1 ; + +use IO::Compress::Base::Common 2.074 ; + +use IO::File ; +use Symbol; +use Scalar::Util (); +use List::Util (); +use Carp ; + +%EXPORT_TAGS = ( ); +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; + +sub smartRead +{ + my $self = $_[0]; + my $out = $_[1]; + my $size = $_[2]; + $$out = "" ; + + my $offset = 0 ; + my $status = 1; + + + if (defined *$self->{InputLength}) { + return 0 + if *$self->{InputLengthRemaining} <= 0 ; + $size = List::Util::min($size, *$self->{InputLengthRemaining}); + } + + if ( length *$self->{Prime} ) { + $$out = substr(*$self->{Prime}, 0, $size) ; + substr(*$self->{Prime}, 0, $size) = '' ; + if (length $$out == $size) { + *$self->{InputLengthRemaining} -= length $$out + if defined *$self->{InputLength}; + + return length $$out ; + } + $offset = length $$out ; + } + + my $get_size = $size - $offset ; + + if (defined *$self->{FH}) { + if ($offset) { + # Not using this + # + # *$self->{FH}->read($$out, $get_size, $offset); + # + # because the filehandle may not support the offset parameter + # An example is Net::FTP + my $tmp = ''; + $status = *$self->{FH}->read($tmp, $get_size) ; + substr($$out, $offset) = $tmp + if defined $status && $status > 0 ; + } + else + { $status = *$self->{FH}->read($$out, $get_size) } + } + elsif (defined *$self->{InputEvent}) { + my $got = 1 ; + while (length $$out < $size) { + last + if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0; + } + + if (length $$out > $size ) { + *$self->{Prime} = substr($$out, $size, length($$out)); + substr($$out, $size, length($$out)) = ''; + } + + *$self->{EventEof} = 1 if $got <= 0 ; + } + else { + no warnings 'uninitialized'; + my $buf = *$self->{Buffer} ; + $$buf = '' unless defined $$buf ; + substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size); + if (*$self->{ConsumeInput}) + { substr($$buf, 0, $get_size) = '' } + else + { *$self->{BufferOffset} += length($$out) - $offset } + } + + *$self->{InputLengthRemaining} -= length($$out) #- $offset + if defined *$self->{InputLength}; + + if (! defined $status) { + $self->saveStatus($!) ; + return STATUS_ERROR; + } + + $self->saveStatus(length $$out < 0 ? STATUS_ERROR : STATUS_OK) ; + + return length $$out; +} + +sub pushBack +{ + my $self = shift ; + + return if ! defined $_[0] || length $_[0] == 0 ; + + if (defined *$self->{FH} || defined *$self->{InputEvent} ) { + *$self->{Prime} = $_[0] . *$self->{Prime} ; + *$self->{InputLengthRemaining} += length($_[0]); + } + else { + my $len = length $_[0]; + + if($len > *$self->{BufferOffset}) { + *$self->{Prime} = substr($_[0], 0, $len - *$self->{BufferOffset}) . *$self->{Prime} ; + *$self->{InputLengthRemaining} = *$self->{InputLength}; + *$self->{BufferOffset} = 0 + } + else { + *$self->{InputLengthRemaining} += length($_[0]); + *$self->{BufferOffset} -= length($_[0]) ; + } + } +} + +sub smartSeek +{ + my $self = shift ; + my $offset = shift ; + my $truncate = shift; + my $position = shift || SEEK_SET; + + # TODO -- need to take prime into account + if (defined *$self->{FH}) + { *$self->{FH}->seek($offset, $position) } + else { + if ($position == SEEK_END) { + *$self->{BufferOffset} = length ${ *$self->{Buffer} } + $offset ; + } + elsif ($position == SEEK_CUR) { + *$self->{BufferOffset} += $offset ; + } + else { + *$self->{BufferOffset} = $offset ; + } + + substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = '' + if $truncate; + return 1; + } +} + +sub smartTell +{ + my $self = shift ; + + if (defined *$self->{FH}) + { return *$self->{FH}->tell() } + else + { return *$self->{BufferOffset} } +} + +sub smartWrite +{ + my $self = shift ; + my $out_data = shift ; + + if (defined *$self->{FH}) { + # flush needed for 5.8.0 + defined *$self->{FH}->write($out_data, length $out_data) && + defined *$self->{FH}->flush() ; + } + else { + my $buf = *$self->{Buffer} ; + substr($$buf, *$self->{BufferOffset}, length $out_data) = $out_data ; + *$self->{BufferOffset} += length($out_data) ; + return 1; + } +} + +sub smartReadExact +{ + return $_[0]->smartRead($_[1], $_[2]) == $_[2]; +} + +sub smartEof +{ + my ($self) = $_[0]; + local $.; + + return 0 if length *$self->{Prime} || *$self->{PushMode}; + + if (defined *$self->{FH}) + { + # Could use + # + # *$self->{FH}->eof() + # + # here, but this can cause trouble if + # the filehandle is itself a tied handle, but it uses sysread. + # Then we get into mixing buffered & non-buffered IO, + # which will cause trouble + + my $info = $self->getErrInfo(); + + my $buffer = ''; + my $status = $self->smartRead(\$buffer, 1); + $self->pushBack($buffer) if length $buffer; + $self->setErrInfo($info); + + return $status == 0 ; + } + elsif (defined *$self->{InputEvent}) + { *$self->{EventEof} } + else + { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) } +} + +sub clearError +{ + my $self = shift ; + + *$self->{ErrorNo} = 0 ; + ${ *$self->{Error} } = '' ; +} + +sub getErrInfo +{ + my $self = shift ; + + return [ *$self->{ErrorNo}, ${ *$self->{Error} } ] ; +} + +sub setErrInfo +{ + my $self = shift ; + my $ref = shift; + + *$self->{ErrorNo} = $ref->[0] ; + ${ *$self->{Error} } = $ref->[1] ; +} + +sub saveStatus +{ + my $self = shift ; + my $errno = shift() + 0 ; + + *$self->{ErrorNo} = $errno; + ${ *$self->{Error} } = '' ; + + return *$self->{ErrorNo} ; +} + + +sub saveErrorString +{ + my $self = shift ; + my $retval = shift ; + + ${ *$self->{Error} } = shift ; + *$self->{ErrorNo} = @_ ? shift() + 0 : STATUS_ERROR ; + + return $retval; +} + +sub croakError +{ + my $self = shift ; + $self->saveErrorString(0, $_[0]); + croak $_[0]; +} + + +sub closeError +{ + my $self = shift ; + my $retval = shift ; + + my $errno = *$self->{ErrorNo}; + my $error = ${ *$self->{Error} }; + + $self->close(); + + *$self->{ErrorNo} = $errno ; + ${ *$self->{Error} } = $error ; + + return $retval; +} + +sub error +{ + my $self = shift ; + return ${ *$self->{Error} } ; +} + +sub errorNo +{ + my $self = shift ; + return *$self->{ErrorNo}; +} + +sub HeaderError +{ + my ($self) = shift; + return $self->saveErrorString(undef, "Header Error: $_[0]", STATUS_ERROR); +} + +sub TrailerError +{ + my ($self) = shift; + return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", STATUS_ERROR); +} + +sub TruncatedHeader +{ + my ($self) = shift; + return $self->HeaderError("Truncated in $_[0] Section"); +} + +sub TruncatedTrailer +{ + my ($self) = shift; + return $self->TrailerError("Truncated in $_[0] Section"); +} + +sub postCheckParams +{ + return 1; +} + +sub checkParams +{ + my $self = shift ; + my $class = shift ; + + my $got = shift || IO::Compress::Base::Parameters::new(); + + my $Valid = { + 'blocksize' => [IO::Compress::Base::Common::Parse_unsigned, 16 * 1024], + 'autoclose' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'strict' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'append' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'prime' => [IO::Compress::Base::Common::Parse_any, undef], + 'multistream' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'transparent' => [IO::Compress::Base::Common::Parse_any, 1], + 'scan' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'inputlength' => [IO::Compress::Base::Common::Parse_unsigned, undef], + 'binmodeout' => [IO::Compress::Base::Common::Parse_boolean, 0], + #'decode' => [IO::Compress::Base::Common::Parse_any, undef], + + #'consumeinput' => [IO::Compress::Base::Common::Parse_boolean, 0], + + $self->getExtraParams(), + + #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0, + # ContinueAfterEof + } ; + + $Valid->{trailingdata} = [IO::Compress::Base::Common::Parse_writable_scalar, undef] + if *$self->{OneShot} ; + + $got->parse($Valid, @_ ) + or $self->croakError("${class}: " . $got->getError()) ; + + $self->postCheckParams($got) + or $self->croakError("${class}: " . $self->error()) ; + + return $got; +} + +sub _create +{ + my $obj = shift; + my $got = shift; + my $append_mode = shift ; + + my $class = ref $obj; + $obj->croakError("$class: Missing Input parameter") + if ! @_ && ! $got ; + + my $inValue = shift ; + + *$obj->{OneShot} = 0 ; + + if (! $got) + { + $got = $obj->checkParams($class, undef, @_) + or return undef ; + } + + my $inType = whatIsInput($inValue, 1); + + $obj->ckInputParam($class, $inValue, 1) + or return undef ; + + *$obj->{InNew} = 1; + + $obj->ckParams($got) + or $obj->croakError("${class}: " . *$obj->{Error}); + + if ($inType eq 'buffer' || $inType eq 'code') { + *$obj->{Buffer} = $inValue ; + *$obj->{InputEvent} = $inValue + if $inType eq 'code' ; + } + else { + if ($inType eq 'handle') { + *$obj->{FH} = $inValue ; + *$obj->{Handle} = 1 ; + + # Need to rewind for Scan + *$obj->{FH}->seek(0, SEEK_SET) + if $got->getValue('scan'); + } + else { + no warnings ; + my $mode = '<'; + $mode = '+<' if $got->getValue('scan'); + *$obj->{StdIO} = ($inValue eq '-'); + *$obj->{FH} = new IO::File "$mode $inValue" + or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ; + } + + *$obj->{LineNo} = $. = 0; + setBinModeInput(*$obj->{FH}) ; + + my $buff = "" ; + *$obj->{Buffer} = \$buff ; + } + +# if ($got->getValue('decode')) { +# my $want_encoding = $got->getValue('decode'); +# *$obj->{Encoding} = IO::Compress::Base::Common::getEncoding($obj, $class, $want_encoding); +# } +# else { +# *$obj->{Encoding} = undef; +# } + + *$obj->{InputLength} = $got->parsed('inputlength') + ? $got->getValue('inputlength') + : undef ; + *$obj->{InputLengthRemaining} = $got->getValue('inputlength'); + *$obj->{BufferOffset} = 0 ; + *$obj->{AutoClose} = $got->getValue('autoclose'); + *$obj->{Strict} = $got->getValue('strict'); + *$obj->{BlockSize} = $got->getValue('blocksize'); + *$obj->{Append} = $got->getValue('append'); + *$obj->{AppendOutput} = $append_mode || $got->getValue('append'); + *$obj->{ConsumeInput} = $got->getValue('consumeinput'); + *$obj->{Transparent} = $got->getValue('transparent'); + *$obj->{MultiStream} = $got->getValue('multistream'); + + # TODO - move these two into RawDeflate + *$obj->{Scan} = $got->getValue('scan'); + *$obj->{ParseExtra} = $got->getValue('parseextra') + || $got->getValue('strict') ; + *$obj->{Type} = ''; + *$obj->{Prime} = $got->getValue('prime') || '' ; + *$obj->{Pending} = ''; + *$obj->{Plain} = 0; + *$obj->{PlainBytesRead} = 0; + *$obj->{InflatedBytesRead} = 0; + *$obj->{UnCompSize} = new U64; + *$obj->{CompSize} = new U64; + *$obj->{TotalInflatedBytesRead} = 0; + *$obj->{NewStream} = 0 ; + *$obj->{EventEof} = 0 ; + *$obj->{ClassName} = $class ; + *$obj->{Params} = $got ; + + if (*$obj->{ConsumeInput}) { + *$obj->{InNew} = 0; + *$obj->{Closed} = 0; + return $obj + } + + my $status = $obj->mkUncomp($got); + + return undef + unless defined $status; + + *$obj->{InNew} = 0; + *$obj->{Closed} = 0; + + if ($status) { + # Need to try uncompressing to catch the case + # where the compressed file uncompresses to an + # empty string - so eof is set immediately. + + my $out_buffer = ''; + + $status = $obj->read(\$out_buffer); + + if ($status < 0) { + *$obj->{ReadStatus} = [ $status, $obj->error(), $obj->errorNo() ]; + } + + $obj->ungetc($out_buffer) + if length $out_buffer; + } + else { + return undef + unless *$obj->{Transparent}; + + $obj->clearError(); + *$obj->{Type} = 'plain'; + *$obj->{Plain} = 1; + $obj->pushBack(*$obj->{HeaderPending}) ; + } + + push @{ *$obj->{InfoList} }, *$obj->{Info} ; + + $obj->saveStatus(STATUS_OK) ; + *$obj->{InNew} = 0; + *$obj->{Closed} = 0; + + return $obj; +} + +sub ckInputParam +{ + my $self = shift ; + my $from = shift ; + my $inType = whatIsInput($_[0], $_[1]); + + $self->croakError("$from: input parameter not a filename, filehandle, array ref or scalar ref") + if ! $inType ; + +# if ($inType eq 'filename' ) +# { +# return $self->saveErrorString(1, "$from: input filename is undef or null string", STATUS_ERROR) +# if ! defined $_[0] || $_[0] eq '' ; +# +# if ($_[0] ne '-' && ! -e $_[0] ) +# { +# return $self->saveErrorString(1, +# "input file '$_[0]' does not exist", STATUS_ERROR); +# } +# } + + return 1; +} + + +sub _inf +{ + my $obj = shift ; + + my $class = (caller)[0] ; + my $name = (caller(1))[3] ; + + $obj->croakError("$name: expected at least 1 parameters\n") + unless @_ >= 1 ; + + my $input = shift ; + my $haveOut = @_ ; + my $output = shift ; + + + my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output) + or return undef ; + + push @_, $output if $haveOut && $x->{Hash}; + + *$obj->{OneShot} = 1 ; + + my $got = $obj->checkParams($name, undef, @_) + or return undef ; + + if ($got->parsed('trailingdata')) + { +# my $value = $got->valueRef('TrailingData'); +# warn "TD $value "; +# #$value = $$value; +## warn "TD $value $$value "; +# +# return retErr($obj, "Parameter 'TrailingData' not writable") +# if readonly $$value ; +# +# if (ref $$value) +# { +# return retErr($obj,"Parameter 'TrailingData' not a scalar reference") +# if ref $$value ne 'SCALAR' ; +# +# *$obj->{TrailingData} = $$value ; +# } +# else +# { +# return retErr($obj,"Parameter 'TrailingData' not a scalar") +# if ref $value ne 'SCALAR' ; +# +# *$obj->{TrailingData} = $value ; +# } + + *$obj->{TrailingData} = $got->getValue('trailingdata'); + } + + *$obj->{MultiStream} = $got->getValue('multistream'); + $got->setValue('multistream', 0); + + $x->{Got} = $got ; + +# if ($x->{Hash}) +# { +# while (my($k, $v) = each %$input) +# { +# $v = \$input->{$k} +# unless defined $v ; +# +# $obj->_singleTarget($x, $k, $v, @_) +# or return undef ; +# } +# +# return keys %$input ; +# } + + if ($x->{GlobMap}) + { + $x->{oneInput} = 1 ; + foreach my $pair (@{ $x->{Pairs} }) + { + my ($from, $to) = @$pair ; + $obj->_singleTarget($x, $from, $to, @_) + or return undef ; + } + + return scalar @{ $x->{Pairs} } ; + } + + if (! $x->{oneOutput} ) + { + my $inFile = ($x->{inType} eq 'filenames' + || $x->{inType} eq 'filename'); + + $x->{inType} = $inFile ? 'filename' : 'buffer'; + + foreach my $in ($x->{oneInput} ? $input : @$input) + { + my $out ; + $x->{oneInput} = 1 ; + + $obj->_singleTarget($x, $in, $output, @_) + or return undef ; + } + + return 1 ; + } + + # finally the 1 to 1 and n to 1 + return $obj->_singleTarget($x, $input, $output, @_); + + croak "should not be here" ; +} + +sub retErr +{ + my $x = shift ; + my $string = shift ; + + ${ $x->{Error} } = $string ; + + return undef ; +} + +sub _singleTarget +{ + my $self = shift ; + my $x = shift ; + my $input = shift; + my $output = shift; + + my $buff = ''; + $x->{buff} = \$buff ; + + my $fh ; + if ($x->{outType} eq 'filename') { + my $mode = '>' ; + $mode = '>>' + if $x->{Got}->getValue('append') ; + $x->{fh} = new IO::File "$mode $output" + or return retErr($x, "cannot open file '$output': $!") ; + binmode $x->{fh} if $x->{Got}->valueOrDefault('binmodeout'); + + } + + elsif ($x->{outType} eq 'handle') { + $x->{fh} = $output; + binmode $x->{fh} if $x->{Got}->valueOrDefault('binmodeout'); + if ($x->{Got}->getValue('append')) { + seek($x->{fh}, 0, SEEK_END) + or return retErr($x, "Cannot seek to end of output filehandle: $!") ; + } + } + + + elsif ($x->{outType} eq 'buffer' ) + { + $$output = '' + unless $x->{Got}->getValue('append'); + $x->{buff} = $output ; + } + + if ($x->{oneInput}) + { + defined $self->_rd2($x, $input, $output) + or return undef; + } + else + { + for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) + { + defined $self->_rd2($x, $element, $output) + or return undef ; + } + } + + + if ( ($x->{outType} eq 'filename' && $output ne '-') || + ($x->{outType} eq 'handle' && $x->{Got}->getValue('autoclose'))) { + $x->{fh}->close() + or return retErr($x, $!); + delete $x->{fh}; + } + + return 1 ; +} + +sub _rd2 +{ + my $self = shift ; + my $x = shift ; + my $input = shift; + my $output = shift; + + my $z = IO::Compress::Base::Common::createSelfTiedObject($x->{Class}, *$self->{Error}); + + $z->_create($x->{Got}, 1, $input, @_) + or return undef ; + + my $status ; + my $fh = $x->{fh}; + + while (1) { + + while (($status = $z->read($x->{buff})) > 0) { + if ($fh) { + local $\; + print $fh ${ $x->{buff} } + or return $z->saveErrorString(undef, "Error writing to output file: $!", $!); + ${ $x->{buff} } = '' ; + } + } + + if (! $x->{oneOutput} ) { + my $ot = $x->{outType} ; + + if ($ot eq 'array') + { push @$output, $x->{buff} } + elsif ($ot eq 'hash') + { $output->{$input} = $x->{buff} } + + my $buff = ''; + $x->{buff} = \$buff; + } + + last if $status < 0 || $z->smartEof(); + + last + unless *$self->{MultiStream}; + + $status = $z->nextStream(); + + last + unless $status == 1 ; + } + + return $z->closeError(undef) + if $status < 0 ; + + ${ *$self->{TrailingData} } = $z->trailingData() + if defined *$self->{TrailingData} ; + + $z->close() + or return undef ; + + return 1 ; +} + +sub TIEHANDLE +{ + return $_[0] if ref($_[0]); + die "OOPS\n" ; + +} + +sub UNTIE +{ + my $self = shift ; +} + + +sub getHeaderInfo +{ + my $self = shift ; + wantarray ? @{ *$self->{InfoList} } : *$self->{Info}; +} + +sub readBlock +{ + my $self = shift ; + my $buff = shift ; + my $size = shift ; + + if (defined *$self->{CompressedInputLength}) { + if (*$self->{CompressedInputLengthRemaining} == 0) { + delete *$self->{CompressedInputLength}; + *$self->{CompressedInputLengthDone} = 1; + return STATUS_OK ; + } + $size = List::Util::min($size, *$self->{CompressedInputLengthRemaining} ); + *$self->{CompressedInputLengthRemaining} -= $size ; + } + + my $status = $self->smartRead($buff, $size) ; + return $self->saveErrorString(STATUS_ERROR, "Error Reading Data: $!", $!) + if $status == STATUS_ERROR ; + + if ($status == 0 ) { + *$self->{Closed} = 1 ; + *$self->{EndStream} = 1 ; + return $self->saveErrorString(STATUS_ERROR, "unexpected end of file", STATUS_ERROR); + } + + return STATUS_OK; +} + +sub postBlockChk +{ + return STATUS_OK; +} + +sub _raw_read +{ + # return codes + # >0 - ok, number of bytes read + # =0 - ok, eof + # <0 - not ok + + my $self = shift ; + + return G_EOF if *$self->{Closed} ; + return G_EOF if *$self->{EndStream} ; + + my $buffer = shift ; + my $scan_mode = shift ; + + if (*$self->{Plain}) { + my $tmp_buff ; + my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ; + + return $self->saveErrorString(G_ERR, "Error reading data: $!", $!) + if $len == STATUS_ERROR ; + + if ($len == 0 ) { + *$self->{EndStream} = 1 ; + } + else { + *$self->{PlainBytesRead} += $len ; + $$buffer .= $tmp_buff; + } + + return $len ; + } + + if (*$self->{NewStream}) { + + $self->gotoNextStream() > 0 + or return G_ERR; + + # For the headers that actually uncompressed data, put the + # uncompressed data into the output buffer. + $$buffer .= *$self->{Pending} ; + my $len = length *$self->{Pending} ; + *$self->{Pending} = ''; + return $len; + } + + my $temp_buf = ''; + my $outSize = 0; + my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ; + + return G_ERR + if $status == STATUS_ERROR ; + + my $buf_len = 0; + if ($status == STATUS_OK) { + my $beforeC_len = length $temp_buf; + my $before_len = defined $$buffer ? length $$buffer : 0 ; + $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer, + defined *$self->{CompressedInputLengthDone} || + $self->smartEof(), $outSize); + + # Remember the input buffer if it wasn't consumed completely + $self->pushBack($temp_buf) if *$self->{Uncomp}{ConsumesInput}; + + return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo}) + if $self->saveStatus($status) == STATUS_ERROR; + + $self->postBlockChk($buffer, $before_len) == STATUS_OK + or return G_ERR; + + $buf_len = defined $$buffer ? length($$buffer) - $before_len : 0; + + *$self->{CompSize}->add($beforeC_len - length $temp_buf) ; + + *$self->{InflatedBytesRead} += $buf_len ; + *$self->{TotalInflatedBytesRead} += $buf_len ; + *$self->{UnCompSize}->add($buf_len) ; + + $self->filterUncompressed($buffer, $before_len); + +# if (*$self->{Encoding}) { +# use Encode ; +# *$self->{PendingDecode} .= substr($$buffer, $before_len) ; +# my $got = *$self->{Encoding}->decode(*$self->{PendingDecode}, Encode::FB_QUIET) ; +# substr($$buffer, $before_len) = $got; +# } + } + + if ($status == STATUS_ENDSTREAM) { + + *$self->{EndStream} = 1 ; + + my $trailer; + my $trailer_size = *$self->{Info}{TrailerLength} ; + my $got = 0; + if (*$self->{Info}{TrailerLength}) + { + $got = $self->smartRead(\$trailer, $trailer_size) ; + } + + if ($got == $trailer_size) { + $self->chkTrailer($trailer) == STATUS_OK + or return G_ERR; + } + else { + return $self->TrailerError("trailer truncated. Expected " . + "$trailer_size bytes, got $got") + if *$self->{Strict}; + $self->pushBack($trailer) ; + } + + # TODO - if want file pointer, do it here + + if (! $self->smartEof()) { + *$self->{NewStream} = 1 ; + + if (*$self->{MultiStream}) { + *$self->{EndStream} = 0 ; + return $buf_len ; + } + } + + } + + + # return the number of uncompressed bytes read + return $buf_len ; +} + +sub reset +{ + my $self = shift ; + + return *$self->{Uncomp}->reset(); +} + +sub filterUncompressed +{ +} + +#sub isEndStream +#{ +# my $self = shift ; +# return *$self->{NewStream} || +# *$self->{EndStream} ; +#} + +sub nextStream +{ + my $self = shift ; + + my $status = $self->gotoNextStream(); + $status == 1 + or return $status ; + + *$self->{TotalInflatedBytesRead} = 0 ; + *$self->{LineNo} = $. = 0; + + return 1; +} + +sub gotoNextStream +{ + my $self = shift ; + + if (! *$self->{NewStream}) { + my $status = 1; + my $buffer ; + + # TODO - make this more efficient if know the offset for the end of + # the stream and seekable + $status = $self->read($buffer) + while $status > 0 ; + + return $status + if $status < 0; + } + + *$self->{NewStream} = 0 ; + *$self->{EndStream} = 0 ; + *$self->{CompressedInputLengthDone} = undef ; + *$self->{CompressedInputLength} = undef ; + $self->reset(); + *$self->{UnCompSize}->reset(); + *$self->{CompSize}->reset(); + + my $magic = $self->ckMagic(); + + if ( ! defined $magic) { + if (! *$self->{Transparent} || $self->eof()) + { + *$self->{EndStream} = 1 ; + return 0; + } + + $self->clearError(); + *$self->{Type} = 'plain'; + *$self->{Plain} = 1; + $self->pushBack(*$self->{HeaderPending}) ; + } + else + { + *$self->{Info} = $self->readHeader($magic); + + if ( ! defined *$self->{Info} ) { + *$self->{EndStream} = 1 ; + return -1; + } + } + + push @{ *$self->{InfoList} }, *$self->{Info} ; + + return 1; +} + +sub streamCount +{ + my $self = shift ; + return 1 if ! defined *$self->{InfoList}; + return scalar @{ *$self->{InfoList} } ; +} + +#sub read +#{ +# my $status = myRead(@_); +# return undef if $status < 0; +# return $status; +#} + +sub read +{ + # return codes + # >0 - ok, number of bytes read + # =0 - ok, eof + # <0 - not ok + + my $self = shift ; + + if (defined *$self->{ReadStatus} ) { + my $status = *$self->{ReadStatus}[0]; + $self->saveErrorString( @{ *$self->{ReadStatus} } ); + delete *$self->{ReadStatus} ; + return $status ; + } + + return G_EOF if *$self->{Closed} ; + + my $buffer ; + + if (ref $_[0] ) { + $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only") + if Scalar::Util::readonly(${ $_[0] }); + + $self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" ) + unless ref $_[0] eq 'SCALAR' ; + $buffer = $_[0] ; + } + else { + $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only") + if Scalar::Util::readonly($_[0]); + + $buffer = \$_[0] ; + } + + my $length = $_[1] ; + my $offset = $_[2] || 0; + + if (! *$self->{AppendOutput}) { + if (! $offset) { + $$buffer = '' ; + } + else { + if ($offset > length($$buffer)) { + $$buffer .= "\x00" x ($offset - length($$buffer)); + } + else { + substr($$buffer, $offset) = ''; + } + } + } + elsif (! defined $$buffer) { + $$buffer = '' ; + } + + return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; + + # the core read will return 0 if asked for 0 bytes + return 0 if defined $length && $length == 0 ; + + $length = $length || 0; + + $self->croakError(*$self->{ClassName} . "::read: length parameter is negative") + if $length < 0 ; + + # Short-circuit if this is a simple read, with no length + # or offset specified. + unless ( $length || $offset) { + if (length *$self->{Pending}) { + $$buffer .= *$self->{Pending} ; + my $len = length *$self->{Pending}; + *$self->{Pending} = '' ; + return $len ; + } + else { + my $len = 0; + $len = $self->_raw_read($buffer) + while ! *$self->{EndStream} && $len == 0 ; + return $len ; + } + } + + # Need to jump through more hoops - either length or offset + # or both are specified. + my $out_buffer = *$self->{Pending} ; + *$self->{Pending} = ''; + + + while (! *$self->{EndStream} && length($out_buffer) < $length) + { + my $buf_len = $self->_raw_read(\$out_buffer); + return $buf_len + if $buf_len < 0 ; + } + + $length = length $out_buffer + if length($out_buffer) < $length ; + + return 0 + if $length == 0 ; + + $$buffer = '' + if ! defined $$buffer; + + $offset = length $$buffer + if *$self->{AppendOutput} ; + + *$self->{Pending} = $out_buffer; + $out_buffer = \*$self->{Pending} ; + + substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ; + substr($$out_buffer, 0, $length) = '' ; + + return $length ; +} + +sub _getline +{ + my $self = shift ; + my $status = 0 ; + + # Slurp Mode + if ( ! defined $/ ) { + my $data ; + 1 while ($status = $self->read($data)) > 0 ; + return ($status, \$data); + } + + # Record Mode + if ( ref $/ eq 'SCALAR' && ${$/} =~ /^\d+$/ && ${$/} > 0) { + my $reclen = ${$/} ; + my $data ; + $status = $self->read($data, $reclen) ; + return ($status, \$data); + } + + # Paragraph Mode + if ( ! length $/ ) { + my $paragraph ; + while (($status = $self->read($paragraph)) > 0 ) { + if ($paragraph =~ s/^(.*?\n\n+)//s) { + *$self->{Pending} = $paragraph ; + my $par = $1 ; + return (1, \$par); + } + } + return ($status, \$paragraph); + } + + # $/ isn't empty, or a reference, so it's Line Mode. + { + my $line ; + my $p = \*$self->{Pending} ; + while (($status = $self->read($line)) > 0 ) { + my $offset = index($line, $/); + if ($offset >= 0) { + my $l = substr($line, 0, $offset + length $/ ); + substr($line, 0, $offset + length $/) = ''; + $$p = $line; + return (1, \$l); + } + } + + return ($status, \$line); + } +} + +sub getline +{ + my $self = shift; + + if (defined *$self->{ReadStatus} ) { + $self->saveErrorString( @{ *$self->{ReadStatus} } ); + delete *$self->{ReadStatus} ; + return undef; + } + + return undef + if *$self->{Closed} || (!length *$self->{Pending} && *$self->{EndStream}) ; + + my $current_append = *$self->{AppendOutput} ; + *$self->{AppendOutput} = 1; + + my ($status, $lineref) = $self->_getline(); + *$self->{AppendOutput} = $current_append; + + return undef + if $status < 0 || length $$lineref == 0 ; + + $. = ++ *$self->{LineNo} ; + + return $$lineref ; +} + +sub getlines +{ + my $self = shift; + $self->croakError(*$self->{ClassName} . + "::getlines: called in scalar context\n") unless wantarray; + my($line, @lines); + push(@lines, $line) + while defined($line = $self->getline); + return @lines; +} + +sub READLINE +{ + goto &getlines if wantarray; + goto &getline; +} + +sub getc +{ + my $self = shift; + my $buf; + return $buf if $self->read($buf, 1); + return undef; +} + +sub ungetc +{ + my $self = shift; + *$self->{Pending} = "" unless defined *$self->{Pending} ; + *$self->{Pending} = $_[0] . *$self->{Pending} ; +} + + +sub trailingData +{ + my $self = shift ; + + if (defined *$self->{FH} || defined *$self->{InputEvent} ) { + return *$self->{Prime} ; + } + else { + my $buf = *$self->{Buffer} ; + my $offset = *$self->{BufferOffset} ; + return substr($$buf, $offset) ; + } +} + + +sub eof +{ + my $self = shift ; + + return (*$self->{Closed} || + (!length *$self->{Pending} + && ( $self->smartEof() || *$self->{EndStream}))) ; +} + +sub tell +{ + my $self = shift ; + + my $in ; + if (*$self->{Plain}) { + $in = *$self->{PlainBytesRead} ; + } + else { + $in = *$self->{TotalInflatedBytesRead} ; + } + + my $pending = length *$self->{Pending} ; + + return 0 if $pending > $in ; + return $in - $pending ; +} + +sub close +{ + # todo - what to do if close is called before the end of the gzip file + # do we remember any trailing data? + my $self = shift ; + + return 1 if *$self->{Closed} ; + + untie *$self + if $] >= 5.008 ; + + my $status = 1 ; + + if (defined *$self->{FH}) { + if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { + local $.; + $! = 0 ; + $status = *$self->{FH}->close(); + return $self->saveErrorString(0, $!, $!) + if !*$self->{InNew} && $self->saveStatus($!) != 0 ; + } + delete *$self->{FH} ; + $! = 0 ; + } + *$self->{Closed} = 1 ; + + return 1; +} + +sub DESTROY +{ + my $self = shift ; + local ($., $@, $!, $^E, $?); + + $self->close() ; +} + +sub seek +{ + my $self = shift ; + my $position = shift; + my $whence = shift ; + + my $here = $self->tell() ; + my $target = 0 ; + + + if ($whence == SEEK_SET) { + $target = $position ; + } + elsif ($whence == SEEK_CUR) { + $target = $here + $position ; + } + elsif ($whence == SEEK_END) { + $target = $position ; + $self->croakError(*$self->{ClassName} . "::seek: SEEK_END not allowed") ; + } + else { + $self->croakError(*$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter"); + } + + # short circuit if seeking to current offset + if ($target == $here) { + # On ordinary filehandles, seeking to the current + # position also clears the EOF condition, so we + # emulate this behavior locally while simultaneously + # cascading it to the underlying filehandle + if (*$self->{Plain}) { + *$self->{EndStream} = 0; + seek(*$self->{FH},0,1) if *$self->{FH}; + } + return 1; + } + + # Outlaw any attempt to seek backwards + $self->croakError( *$self->{ClassName} ."::seek: cannot seek backwards") + if $target < $here ; + + # Walk the file to the new offset + my $offset = $target - $here ; + + my $got; + while (($got = $self->read(my $buffer, List::Util::min($offset, *$self->{BlockSize})) ) > 0) + { + $offset -= $got; + last if $offset == 0 ; + } + + $here = $self->tell() ; + return $offset == 0 ? 1 : 0 ; +} + +sub fileno +{ + my $self = shift ; + return defined *$self->{FH} + ? fileno *$self->{FH} + : undef ; +} + +sub binmode +{ + 1; +# my $self = shift ; +# return defined *$self->{FH} +# ? binmode *$self->{FH} +# : 1 ; +} + +sub opened +{ + my $self = shift ; + return ! *$self->{Closed} ; +} + +sub autoflush +{ + my $self = shift ; + return defined *$self->{FH} + ? *$self->{FH}->autoflush(@_) + : undef ; +} + +sub input_line_number +{ + my $self = shift ; + my $last = *$self->{LineNo}; + $. = *$self->{LineNo} = $_[1] if @_ ; + return $last; +} + + +*BINMODE = \&binmode; +*SEEK = \&seek; +*READ = \&read; +*sysread = \&read; +*TELL = \&tell; +*EOF = \&eof; + +*FILENO = \&fileno; +*CLOSE = \&close; + +sub _notAvailable +{ + my $name = shift ; + return sub { croak "$name Not Available: File opened only for intput" ; } ; +} + + +*print = _notAvailable('print'); +*PRINT = _notAvailable('print'); +*printf = _notAvailable('printf'); +*PRINTF = _notAvailable('printf'); +*write = _notAvailable('write'); +*WRITE = _notAvailable('write'); + +#*sysread = \&read; +#*syswrite = \&_notAvailable; + + + +package IO::Uncompress::Base ; + + +1 ; +__END__ + +=head1 NAME + +IO::Uncompress::Base - Base Class for IO::Uncompress modules + +=head1 SYNOPSIS + + use IO::Uncompress::Base ; + +=head1 DESCRIPTION + +This module is not intended for direct use in application code. Its sole +purpose is to be sub-classed by IO::Uncompress modules. + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm new file mode 100644 index 0000000000..26556b7625 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm @@ -0,0 +1,910 @@ +package IO::Uncompress::Bunzip2 ; + +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.074 qw(:Status ); + +use IO::Uncompress::Base 2.074 ; +use IO::Uncompress::Adapter::Bunzip2 2.074 ; + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error); + +$VERSION = '2.074'; +$Bunzip2Error = ''; + +@ISA = qw(IO::Uncompress::Base Exporter); +@EXPORT_OK = qw( $Bunzip2Error bunzip2 ) ; +#%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +#Exporter::export_ok_tags('all'); + + +sub new +{ + my $class = shift ; + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$Bunzip2Error); + + $obj->_create(undef, 0, @_); +} + +sub bunzip2 +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$Bunzip2Error); + return $obj->_inf(@_); +} + +sub getExtraParams +{ + return ( + 'verbosity' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'small' => [IO::Compress::Base::Common::Parse_boolean, 0], + ); +} + + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + return 1; +} + +sub mkUncomp +{ + my $self = shift ; + my $got = shift ; + + my $magic = $self->ckMagic() + or return 0; + + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + my $Small = $got->getValue('small'); + my $Verbosity = $got->getValue('verbosity'); + + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Bunzip2::mkUncompObject( + $Small, $Verbosity); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + return 1; + +} + + +sub ckMagic +{ + my $self = shift; + + my $magic ; + $self->smartReadExact(\$magic, 4); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Header size is " . + 4 . " bytes") + if length $magic != 4; + + return $self->HeaderError("Bad Magic.") + if ! isBzip2Magic($magic) ; + + + *$self->{Type} = 'bzip2'; + return $magic; +} + +sub readHeader +{ + my $self = shift; + my $magic = shift ; + + $self->pushBack($magic); + *$self->{HeaderPending} = ''; + + + return { + 'Type' => 'bzip2', + 'FingerprintLength' => 4, + 'HeaderLength' => 4, + 'TrailerLength' => 0, + 'Header' => '$magic' + }; + +} + +sub chkTrailer +{ + return STATUS_OK; +} + + + +sub isBzip2Magic +{ + my $buffer = shift ; + return $buffer =~ /^BZh\d$/; +} + +1 ; + +__END__ + + +=head1 NAME + +IO::Uncompress::Bunzip2 - Read bzip2 files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; + + my $status = bunzip2 $input => $output [,OPTS] + or die "bunzip2 failed: $Bunzip2Error\n"; + + my $z = new IO::Uncompress::Bunzip2 $input [OPTS] + or die "bunzip2 failed: $Bunzip2Error\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $Bunzip2Error ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + +=head1 DESCRIPTION + +This module provides a Perl interface that allows the reading of +bzip2 files/buffers. + +For writing bzip2 files/buffers, see the companion module IO::Compress::Bzip2. + +=head1 Functional Interface + +A top-level function, C<bunzip2>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; + + bunzip2 $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "bunzip2 failed: $Bunzip2Error\n"; + +The functional interface needs Perl5.005 or better. + +=head2 bunzip2 $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<bunzip2> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<bunzip2> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the uncompressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +uncompressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +uncompressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +uncompressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the uncompressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<bunzip2> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple compressed +files/buffers and C<$output_filename_or_reference> is +a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<bunzip2>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<bunzip2> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<bunzip2> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all uncompressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +uncompressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any uncompressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any uncompressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all uncompressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any uncompressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all uncompressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any uncompressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any uncompressed data is output. + +Defaults to 0. + +=item C<< MultiStream => 0|1 >> + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt.bz2> and write the +uncompressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; + + my $input = "file1.txt.bz2"; + my $output = "file1.txt"; + bunzip2 $input => $output + or die "bunzip2 failed: $Bunzip2Error\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.bz2" + or die "Cannot open 'file1.txt.bz2': $!\n" ; + my $buffer ; + bunzip2 $input => \$buffer + or die "bunzip2 failed: $Bunzip2Error\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.bz2" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; + + bunzip2 '</my/home/*.txt.bz2>' => '</my/home/#1.txt>' + or die "bunzip2 failed: $Bunzip2Error\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; + + for my $input ( glob "/my/home/*.txt.bz2" ) + { + my $output = $input; + $output =~ s/.bz2// ; + bunzip2 $input => $output + or die "Error compressing '$input': $Bunzip2Error\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::Bunzip2 is shown below + + my $z = new IO::Uncompress::Bunzip2 $input [OPTS] + or die "IO::Uncompress::Bunzip2 failed: $Bunzip2Error\n"; + +Returns an C<IO::Uncompress::Bunzip2> object on success and undef on failure. +The variable C<$Bunzip2Error> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::Bunzip2 can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$input>. + +=back + +=head2 Constructor Options + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::Bunzip2 object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/buffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::Bunzip2 will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + +This option is a no-op. + +=item C<< Small => 0|1 >> + +When non-zero this options will make bzip2 use a decompression algorithm +that uses less memory at the expense of increasing the amount of time +taken for decompression. + +Default is 0. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size of the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the end of the compressed input stream has been reached. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + +Note that the implementation of C<seek> in this module does not provide +true random access to a compressed file/buffer. It works by uncompressing +data from the current offset in the file/buffer until it reaches the +uncompressed offset specified in the parameters to C<seek>. For very small +files this may be acceptable behaviour. For large files it may cause an +unacceptable delay. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to determine what constitutes a line +terminator. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::Bunzip2 object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::Bunzip2 +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::Bunzip2 at present. + +=over 5 + +=item :all + +Imports C<bunzip2> and C<$Bunzip2Error>. +Same as doing this + + use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; + +=back + +=head1 EXAMPLES + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +The primary site for the bzip2 program is L<http://www.bzip.org>. + +See the module L<Compress::Bzip2|Compress::Bzip2> + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm new file mode 100644 index 0000000000..90af4b1b62 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm @@ -0,0 +1,1125 @@ + +package IO::Uncompress::Gunzip ; + +require 5.006 ; + +# for RFC1952 + +use strict ; +use warnings; +use bytes; + +use IO::Uncompress::RawInflate 2.074 ; + +use Compress::Raw::Zlib 2.074 () ; +use IO::Compress::Base::Common 2.074 qw(:Status ); +use IO::Compress::Gzip::Constants 2.074 ; +use IO::Compress::Zlib::Extra 2.074 ; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GunzipError); + +@ISA = qw(IO::Uncompress::RawInflate Exporter); +@EXPORT_OK = qw( $GunzipError gunzip ); +%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + +$GunzipError = ''; + +$VERSION = '2.074'; + +sub new +{ + my $class = shift ; + $GunzipError = ''; + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$GunzipError); + + $obj->_create(undef, 0, @_); +} + +sub gunzip +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$GunzipError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + return ( 'parseextra' => [IO::Compress::Base::Common::Parse_boolean, 0] ) ; +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # gunzip always needs crc32 + $got->setValue('crc32' => 1); + + return 1; +} + +sub ckMagic +{ + my $self = shift; + + my $magic ; + $self->smartReadExact(\$magic, GZIP_ID_SIZE); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Minimum header size is " . + GZIP_MIN_HEADER_SIZE . " bytes") + if length $magic != GZIP_ID_SIZE ; + + return $self->HeaderError("Bad Magic") + if ! isGzipMagic($magic) ; + + *$self->{Type} = 'rfc1952'; + + return $magic ; +} + +sub readHeader +{ + my $self = shift; + my $magic = shift; + + return $self->_readGzipHeader($magic); +} + +sub chkTrailer +{ + my $self = shift; + my $trailer = shift; + + # Check CRC & ISIZE + my ($CRC32, $ISIZE) = unpack("V V", $trailer) ; + *$self->{Info}{CRC32} = $CRC32; + *$self->{Info}{ISIZE} = $ISIZE; + + if (*$self->{Strict}) { + return $self->TrailerError("CRC mismatch") + if $CRC32 != *$self->{Uncomp}->crc32() ; + + my $exp_isize = *$self->{UnCompSize}->get32bit(); + return $self->TrailerError("ISIZE mismatch. Got $ISIZE" + . ", expected $exp_isize") + if $ISIZE != $exp_isize ; + } + + return STATUS_OK; +} + +sub isGzipMagic +{ + my $buffer = shift ; + return 0 if length $buffer < GZIP_ID_SIZE ; + my ($id1, $id2) = unpack("C C", $buffer) ; + return $id1 == GZIP_ID1 && $id2 == GZIP_ID2 ; +} + +sub _readFullGzipHeader($) +{ + my ($self) = @_ ; + my $magic = '' ; + + $self->smartReadExact(\$magic, GZIP_ID_SIZE); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Minimum header size is " . + GZIP_MIN_HEADER_SIZE . " bytes") + if length $magic != GZIP_ID_SIZE ; + + + return $self->HeaderError("Bad Magic") + if ! isGzipMagic($magic) ; + + my $status = $self->_readGzipHeader($magic); + delete *$self->{Transparent} if ! defined $status ; + return $status ; +} + +sub _readGzipHeader($) +{ + my ($self, $magic) = @_ ; + my ($HeaderCRC) ; + my ($buffer) = '' ; + + $self->smartReadExact(\$buffer, GZIP_MIN_HEADER_SIZE - GZIP_ID_SIZE) + or return $self->HeaderError("Minimum header size is " . + GZIP_MIN_HEADER_SIZE . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + # now split out the various parts + my ($cm, $flag, $mtime, $xfl, $os) = unpack("C C V C C", $buffer) ; + + $cm == GZIP_CM_DEFLATED + or return $self->HeaderError("Not Deflate (CM is $cm)") ; + + # check for use of reserved bits + return $self->HeaderError("Use of Reserved Bits in FLG field.") + if $flag & GZIP_FLG_RESERVED ; + + my $EXTRA ; + my @EXTRA = () ; + if ($flag & GZIP_FLG_FEXTRA) { + $EXTRA = "" ; + $self->smartReadExact(\$buffer, GZIP_FEXTRA_HEADER_SIZE) + or return $self->TruncatedHeader("FEXTRA Length") ; + + my ($XLEN) = unpack("v", $buffer) ; + $self->smartReadExact(\$EXTRA, $XLEN) + or return $self->TruncatedHeader("FEXTRA Body"); + $keep .= $buffer . $EXTRA ; + + if ($XLEN && *$self->{'ParseExtra'}) { + my $bad = IO::Compress::Zlib::Extra::parseRawExtra($EXTRA, + \@EXTRA, 1, 1); + return $self->HeaderError($bad) + if defined $bad; + } + } + + my $origname ; + if ($flag & GZIP_FLG_FNAME) { + $origname = "" ; + while (1) { + $self->smartReadExact(\$buffer, 1) + or return $self->TruncatedHeader("FNAME"); + last if $buffer eq GZIP_NULL_BYTE ; + $origname .= $buffer + } + $keep .= $origname . GZIP_NULL_BYTE ; + + return $self->HeaderError("Non ISO 8859-1 Character found in Name") + if *$self->{Strict} && $origname =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ; + } + + my $comment ; + if ($flag & GZIP_FLG_FCOMMENT) { + $comment = ""; + while (1) { + $self->smartReadExact(\$buffer, 1) + or return $self->TruncatedHeader("FCOMMENT"); + last if $buffer eq GZIP_NULL_BYTE ; + $comment .= $buffer + } + $keep .= $comment . GZIP_NULL_BYTE ; + + return $self->HeaderError("Non ISO 8859-1 Character found in Comment") + if *$self->{Strict} && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o ; + } + + if ($flag & GZIP_FLG_FHCRC) { + $self->smartReadExact(\$buffer, GZIP_FHCRC_SIZE) + or return $self->TruncatedHeader("FHCRC"); + + $HeaderCRC = unpack("v", $buffer) ; + my $crc16 = Compress::Raw::Zlib::crc32($keep) & 0xFF ; + + return $self->HeaderError("CRC16 mismatch.") + if *$self->{Strict} && $crc16 != $HeaderCRC; + + $keep .= $buffer ; + } + + # Assume compression method is deflated for xfl tests + #if ($xfl) { + #} + + *$self->{Type} = 'rfc1952'; + + return { + 'Type' => 'rfc1952', + 'FingerprintLength' => 2, + 'HeaderLength' => length $keep, + 'TrailerLength' => GZIP_TRAILER_SIZE, + 'Header' => $keep, + 'isMinimalHeader' => $keep eq GZIP_MINIMUM_HEADER ? 1 : 0, + + 'MethodID' => $cm, + 'MethodName' => $cm == GZIP_CM_DEFLATED ? "Deflated" : "Unknown" , + 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0, + 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0, + 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0, + 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0, + 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0, + 'Name' => $origname, + 'Comment' => $comment, + 'Time' => $mtime, + 'OsID' => $os, + 'OsName' => defined $GZIP_OS_Names{$os} + ? $GZIP_OS_Names{$os} : "Unknown", + 'HeaderCRC' => $HeaderCRC, + 'Flags' => $flag, + 'ExtraFlags' => $xfl, + 'ExtraFieldRaw' => $EXTRA, + 'ExtraField' => [ @EXTRA ], + + + #'CompSize'=> $compsize, + #'CRC32'=> $CRC32, + #'OrigSize'=> $ISIZE, + } +} + + +1; + +__END__ + + +=head1 NAME + +IO::Uncompress::Gunzip - Read RFC 1952 files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + my $status = gunzip $input => $output [,OPTS] + or die "gunzip failed: $GunzipError\n"; + + my $z = new IO::Uncompress::Gunzip $input [OPTS] + or die "gunzip failed: $GunzipError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $status = $z->inflateSync() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $GunzipError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + +=head1 DESCRIPTION + +This module provides a Perl interface that allows the reading of +files/buffers that conform to RFC 1952. + +For writing RFC 1952 files/buffers, see the companion module IO::Compress::Gzip. + +=head1 Functional Interface + +A top-level function, C<gunzip>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + gunzip $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "gunzip failed: $GunzipError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 gunzip $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<gunzip> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<gunzip> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the uncompressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +uncompressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +uncompressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +uncompressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the uncompressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<gunzip> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple compressed +files/buffers and C<$output_filename_or_reference> is +a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<gunzip>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<gunzip> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<gunzip> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all uncompressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +uncompressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any uncompressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any uncompressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all uncompressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any uncompressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all uncompressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any uncompressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any uncompressed data is output. + +Defaults to 0. + +=item C<< MultiStream => 0|1 >> + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt.gz> and write the +uncompressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + my $input = "file1.txt.gz"; + my $output = "file1.txt"; + gunzip $input => $output + or die "gunzip failed: $GunzipError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.gz" + or die "Cannot open 'file1.txt.gz': $!\n" ; + my $buffer ; + gunzip $input => \$buffer + or die "gunzip failed: $GunzipError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.gz" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + gunzip '</my/home/*.txt.gz>' => '</my/home/#1.txt>' + or die "gunzip failed: $GunzipError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + + for my $input ( glob "/my/home/*.txt.gz" ) + { + my $output = $input; + $output =~ s/.gz// ; + gunzip $input => $output + or die "Error compressing '$input': $GunzipError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::Gunzip is shown below + + my $z = new IO::Uncompress::Gunzip $input [OPTS] + or die "IO::Uncompress::Gunzip failed: $GunzipError\n"; + +Returns an C<IO::Uncompress::Gunzip> object on success and undef on failure. +The variable C<$GunzipError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::Gunzip can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$input>. + +=back + +=head2 Constructor Options + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::Gunzip object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/buffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::Gunzip will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + +=over 5 + +=item 1 + +If the FHCRC bit is set in the gzip FLG header byte, the CRC16 bytes in the +header must match the crc16 value of the gzip header actually read. + +=item 2 + +If the gzip header contains a name field (FNAME) it consists solely of ISO +8859-1 characters. + +=item 3 + +If the gzip header contains a comment field (FCOMMENT) it consists solely +of ISO 8859-1 characters plus line-feed. + +=item 4 + +If the gzip FEXTRA header field is present it must conform to the sub-field +structure as defined in RFC 1952. + +=item 5 + +The CRC32 and ISIZE trailer fields must be present. + +=item 6 + +The value of the CRC32 field read must match the crc32 value of the +uncompressed data actually contained in the gzip file. + +=item 7 + +The value of the ISIZE fields read must match the length of the +uncompressed data actually read from the file. + +=back + +=item C<< ParseExtra => 0|1 >> +If the gzip FEXTRA header field is present and this option is set, it will +force the module to check that it conforms to the sub-field structure as +defined in RFC 1952. + +If the C<Strict> is on it will automatically enable this option. + +Defaults to 0. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size of the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + +=over 5 + +=item Name + +The contents of the Name header field, if present. If no name is +present, the value will be undef. Note this is different from a zero length +name, which will return an empty string. + +=item Comment + +The contents of the Comment header field, if present. If no comment is +present, the value will be undef. Note this is different from a zero length +comment, which will return an empty string. + +=back + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the end of the compressed input stream has been reached. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + +Note that the implementation of C<seek> in this module does not provide +true random access to a compressed file/buffer. It works by uncompressing +data from the current offset in the file/buffer until it reaches the +uncompressed offset specified in the parameters to C<seek>. For very small +files this may be acceptable behaviour. For large files it may cause an +unacceptable delay. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to determine what constitutes a line +terminator. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::Gunzip object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::Gunzip +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::Gunzip at present. + +=over 5 + +=item :all + +Imports C<gunzip> and C<$GunzipError>. +Same as doing this + + use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; + +=back + +=head1 EXAMPLES + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +L<http://www.faqs.org/rfcs/rfc1950.html>, +L<http://www.faqs.org/rfcs/rfc1951.html> and +L<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +L<http://www.zlib.org>. + +The primary site for gzip is L<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm new file mode 100644 index 0000000000..4e1b246fac --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm @@ -0,0 +1,997 @@ +package IO::Uncompress::Inflate ; +# for RFC1950 + +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.074 qw(:Status ); +use IO::Compress::Zlib::Constants 2.074 ; + +use IO::Uncompress::RawInflate 2.074 ; + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError); + +$VERSION = '2.074'; +$InflateError = ''; + +@ISA = qw(IO::Uncompress::RawInflate Exporter); +@EXPORT_OK = qw( $InflateError inflate ) ; +%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + +sub new +{ + my $class = shift ; + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$InflateError); + + $obj->_create(undef, 0, @_); +} + +sub inflate +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$InflateError); + return $obj->_inf(@_); +} + +sub getExtraParams +{ + return (); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # gunzip always needs adler32 + $got->setValue('adler32' => 1); + + return 1; +} + +sub ckMagic +{ + my $self = shift; + + my $magic ; + $self->smartReadExact(\$magic, ZLIB_HEADER_SIZE); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Header size is " . + ZLIB_HEADER_SIZE . " bytes") + if length $magic != ZLIB_HEADER_SIZE; + + #return $self->HeaderError("CRC mismatch.") + return undef + if ! $self->isZlibMagic($magic) ; + + *$self->{Type} = 'rfc1950'; + return $magic; +} + +sub readHeader +{ + my $self = shift; + my $magic = shift ; + + return $self->_readDeflateHeader($magic) ; +} + +sub chkTrailer +{ + my $self = shift; + my $trailer = shift; + + my $ADLER32 = unpack("N", $trailer) ; + *$self->{Info}{ADLER32} = $ADLER32; + return $self->TrailerError("CRC mismatch") + if *$self->{Strict} && $ADLER32 != *$self->{Uncomp}->adler32() ; + + return STATUS_OK; +} + + + +sub isZlibMagic +{ + my $self = shift; + my $buffer = shift ; + + return 0 + if length $buffer < ZLIB_HEADER_SIZE ; + + my $hdr = unpack("n", $buffer) ; + #return 0 if $hdr % 31 != 0 ; + return $self->HeaderError("CRC mismatch.") + if $hdr % 31 != 0 ; + + my ($CMF, $FLG) = unpack "C C", $buffer; + my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ; + + # Only Deflate supported + return $self->HeaderError("Not Deflate (CM is $cm)") + if $cm != ZLIB_CMF_CM_DEFLATED ; + + # Max window value is 7 for Deflate. + my $cinfo = bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS) ; + return $self->HeaderError("CINFO > " . ZLIB_CMF_CINFO_MAX . + " (CINFO is $cinfo)") + if $cinfo > ZLIB_CMF_CINFO_MAX ; + + return 1; +} + +sub bits +{ + my $data = shift ; + my $offset = shift ; + my $mask = shift ; + + ($data >> $offset ) & $mask & 0xFF ; +} + + +sub _readDeflateHeader +{ + my ($self, $buffer) = @_ ; + +# if (! $buffer) { +# $self->smartReadExact(\$buffer, ZLIB_HEADER_SIZE); +# +# *$self->{HeaderPending} = $buffer ; +# +# return $self->HeaderError("Header size is " . +# ZLIB_HEADER_SIZE . " bytes") +# if length $buffer != ZLIB_HEADER_SIZE; +# +# return $self->HeaderError("CRC mismatch.") +# if ! isZlibMagic($buffer) ; +# } + + my ($CMF, $FLG) = unpack "C C", $buffer; + my $FDICT = bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ), + + my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ; + $cm == ZLIB_CMF_CM_DEFLATED + or return $self->HeaderError("Not Deflate (CM is $cm)") ; + + my $DICTID; + if ($FDICT) { + $self->smartReadExact(\$buffer, ZLIB_FDICT_SIZE) + or return $self->TruncatedHeader("FDICT"); + + $DICTID = unpack("N", $buffer) ; + } + + *$self->{Type} = 'rfc1950'; + + return { + 'Type' => 'rfc1950', + 'FingerprintLength' => ZLIB_HEADER_SIZE, + 'HeaderLength' => ZLIB_HEADER_SIZE, + 'TrailerLength' => ZLIB_TRAILER_SIZE, + 'Header' => $buffer, + + CMF => $CMF , + CM => bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS ), + CINFO => bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS ), + FLG => $FLG , + FCHECK => bits($FLG, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS), + FDICT => bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ), + FLEVEL => bits($FLG, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS ), + DICTID => $DICTID , + + }; +} + + + + +1 ; + +__END__ + + +=head1 NAME + +IO::Uncompress::Inflate - Read RFC 1950 files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + my $status = inflate $input => $output [,OPTS] + or die "inflate failed: $InflateError\n"; + + my $z = new IO::Uncompress::Inflate $input [OPTS] + or die "inflate failed: $InflateError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $status = $z->inflateSync() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $InflateError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + +=head1 DESCRIPTION + +This module provides a Perl interface that allows the reading of +files/buffers that conform to RFC 1950. + +For writing RFC 1950 files/buffers, see the companion module IO::Compress::Deflate. + +=head1 Functional Interface + +A top-level function, C<inflate>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + inflate $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "inflate failed: $InflateError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 inflate $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<inflate> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<inflate> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the uncompressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +uncompressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +uncompressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +uncompressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the uncompressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<inflate> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple compressed +files/buffers and C<$output_filename_or_reference> is +a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<inflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<inflate> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<inflate> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all uncompressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +uncompressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any uncompressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any uncompressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all uncompressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any uncompressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all uncompressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any uncompressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any uncompressed data is output. + +Defaults to 0. + +=item C<< MultiStream => 0|1 >> + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt.1950> and write the +uncompressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + my $input = "file1.txt.1950"; + my $output = "file1.txt"; + inflate $input => $output + or die "inflate failed: $InflateError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.1950" + or die "Cannot open 'file1.txt.1950': $!\n" ; + my $buffer ; + inflate $input => \$buffer + or die "inflate failed: $InflateError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.1950" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + inflate '</my/home/*.txt.1950>' => '</my/home/#1.txt>' + or die "inflate failed: $InflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + + for my $input ( glob "/my/home/*.txt.1950" ) + { + my $output = $input; + $output =~ s/.1950// ; + inflate $input => $output + or die "Error compressing '$input': $InflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::Inflate is shown below + + my $z = new IO::Uncompress::Inflate $input [OPTS] + or die "IO::Uncompress::Inflate failed: $InflateError\n"; + +Returns an C<IO::Uncompress::Inflate> object on success and undef on failure. +The variable C<$InflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::Inflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$input>. + +=back + +=head2 Constructor Options + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::Inflate object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/buffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::Inflate will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + +=over 5 + +=item 1 + +The ADLER32 checksum field must be present. + +=item 2 + +The value of the ADLER32 field read must match the adler32 value of the +uncompressed data actually contained in the file. + +=back + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size of the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the end of the compressed input stream has been reached. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + +Note that the implementation of C<seek> in this module does not provide +true random access to a compressed file/buffer. It works by uncompressing +data from the current offset in the file/buffer until it reaches the +uncompressed offset specified in the parameters to C<seek>. For very small +files this may be acceptable behaviour. For large files it may cause an +unacceptable delay. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to determine what constitutes a line +terminator. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::Inflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::Inflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::Inflate at present. + +=over 5 + +=item :all + +Imports C<inflate> and C<$InflateError>. +Same as doing this + + use IO::Uncompress::Inflate qw(inflate $InflateError) ; + +=back + +=head1 EXAMPLES + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +L<http://www.faqs.org/rfcs/rfc1950.html>, +L<http://www.faqs.org/rfcs/rfc1951.html> and +L<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +L<http://www.zlib.org>. + +The primary site for gzip is L<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm new file mode 100644 index 0000000000..831940301d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm @@ -0,0 +1,1125 @@ +package IO::Uncompress::RawInflate ; +# for RFC1951 + +use strict ; +use warnings; +use bytes; + +use Compress::Raw::Zlib 2.074 ; +use IO::Compress::Base::Common 2.074 qw(:Status ); + +use IO::Uncompress::Base 2.074 ; +use IO::Uncompress::Adapter::Inflate 2.074 ; + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError); + +$VERSION = '2.074'; +$RawInflateError = ''; + +@ISA = qw(IO::Uncompress::Base Exporter); +@EXPORT_OK = qw( $RawInflateError rawinflate ) ; +%DEFLATE_CONSTANTS = (); +%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + +#{ +# # Execute at runtime +# my %bad; +# for my $module (qw(Compress::Raw::Zlib IO::Compress::Base::Common IO::Uncompress::Base IO::Uncompress::Adapter::Inflate)) +# { +# my $ver = ${ $module . "::VERSION"} ; +# +# $bad{$module} = $ver +# if $ver ne $VERSION; +# } +# +# if (keys %bad) +# { +# my $string = join "\n", map { "$_ $bad{$_}" } keys %bad; +# die caller(0)[0] . "needs version $VERSION mismatch\n$string\n"; +# } +#} + +sub new +{ + my $class = shift ; + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$RawInflateError); + $obj->_create(undef, 0, @_); +} + +sub rawinflate +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$RawInflateError); + return $obj->_inf(@_); +} + +sub getExtraParams +{ + return (); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + return 1; +} + +sub mkUncomp +{ + my $self = shift ; + my $got = shift ; + + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject( + $got->getValue('crc32'), + $got->getValue('adler32'), + $got->getValue('scan'), + ); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + my $magic = $self->ckMagic() + or return 0; + + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + return 1; + +} + + +sub ckMagic +{ + my $self = shift; + + return $self->_isRaw() ; +} + +sub readHeader +{ + my $self = shift; + my $magic = shift ; + + return { + 'Type' => 'rfc1951', + 'FingerprintLength' => 0, + 'HeaderLength' => 0, + 'TrailerLength' => 0, + 'Header' => '' + }; +} + +sub chkTrailer +{ + return STATUS_OK ; +} + +sub _isRaw +{ + my $self = shift ; + + my $got = $self->_isRawx(@_); + + if ($got) { + *$self->{Pending} = *$self->{HeaderPending} ; + } + else { + $self->pushBack(*$self->{HeaderPending}); + *$self->{Uncomp}->reset(); + } + *$self->{HeaderPending} = ''; + + return $got ; +} + +sub _isRawx +{ + my $self = shift ; + my $magic = shift ; + + $magic = '' unless defined $magic ; + + my $buffer = ''; + + $self->smartRead(\$buffer, *$self->{BlockSize}) >= 0 + or return $self->saveErrorString(undef, "No data to read"); + + my $temp_buf = $magic . $buffer ; + *$self->{HeaderPending} = $temp_buf ; + $buffer = ''; + my $status = *$self->{Uncomp}->uncompr(\$temp_buf, \$buffer, $self->smartEof()) ; + + return $self->saveErrorString(undef, *$self->{Uncomp}{Error}, STATUS_ERROR) + if $status == STATUS_ERROR; + + $self->pushBack($temp_buf) ; + + return $self->saveErrorString(undef, "unexpected end of file", STATUS_ERROR) + if $self->smartEof() && $status != STATUS_ENDSTREAM; + + #my $buf_len = *$self->{Uncomp}->uncompressedBytes(); + my $buf_len = length $buffer; + + if ($status == STATUS_ENDSTREAM) { + if (*$self->{MultiStream} + && (length $temp_buf || ! $self->smartEof())){ + *$self->{NewStream} = 1 ; + *$self->{EndStream} = 0 ; + } + else { + *$self->{EndStream} = 1 ; + } + } + *$self->{HeaderPending} = $buffer ; + *$self->{InflatedBytesRead} = $buf_len ; + *$self->{TotalInflatedBytesRead} += $buf_len ; + *$self->{Type} = 'rfc1951'; + + $self->saveStatus(STATUS_OK); + + return { + 'Type' => 'rfc1951', + 'HeaderLength' => 0, + 'TrailerLength' => 0, + 'Header' => '' + }; +} + + +sub inflateSync +{ + my $self = shift ; + + # inflateSync is a no-op in Plain mode + return 1 + if *$self->{Plain} ; + + return 0 if *$self->{Closed} ; + #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ; + return 0 if ! length *$self->{Pending} && *$self->{EndStream} ; + + # Disable CRC check + *$self->{Strict} = 0 ; + + my $status ; + while (1) + { + my $temp_buf ; + + if (length *$self->{Pending} ) + { + $temp_buf = *$self->{Pending} ; + *$self->{Pending} = ''; + } + else + { + $status = $self->smartRead(\$temp_buf, *$self->{BlockSize}) ; + return $self->saveErrorString(0, "Error Reading Data") + if $status < 0 ; + + if ($status == 0 ) { + *$self->{EndStream} = 1 ; + return $self->saveErrorString(0, "unexpected end of file", STATUS_ERROR); + } + } + + $status = *$self->{Uncomp}->sync($temp_buf) ; + + if ($status == STATUS_OK) + { + *$self->{Pending} .= $temp_buf ; + return 1 ; + } + + last unless $status == STATUS_ERROR ; + } + + return 0; +} + +#sub performScan +#{ +# my $self = shift ; +# +# my $status ; +# my $end_offset = 0; +# +# $status = $self->scan() +# #or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $self->errorNo) ; +# or return $self->saveErrorString(G_ERR, "Error Scanning: $status") +# +# $status = $self->zap($end_offset) +# or return $self->saveErrorString(G_ERR, "Error Zapping: $status"); +# #or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $self->errorNo) ; +# +# #(*$obj->{Deflate}, $status) = $inf->createDeflate(); +# +## *$obj->{Header} = *$inf->{Info}{Header}; +## *$obj->{UnCompSize_32bit} = +## *$obj->{BytesWritten} = *$inf->{UnCompSize_32bit} ; +## *$obj->{CompSize_32bit} = *$inf->{CompSize_32bit} ; +# +# +## if ( $outType eq 'buffer') +## { substr( ${ *$self->{Buffer} }, $end_offset) = '' } +## elsif ($outType eq 'handle' || $outType eq 'filename') { +## *$self->{FH} = *$inf->{FH} ; +## delete *$inf->{FH}; +## *$obj->{FH}->flush() ; +## *$obj->{Handle} = 1 if $outType eq 'handle'; +## +## #seek(*$obj->{FH}, $end_offset, SEEK_SET) +## *$obj->{FH}->seek($end_offset, SEEK_SET) +## or return $obj->saveErrorString(undef, $!, $!) ; +## } +# +#} + +sub scan +{ + my $self = shift ; + + return 1 if *$self->{Closed} ; + return 1 if !length *$self->{Pending} && *$self->{EndStream} ; + + my $buffer = '' ; + my $len = 0; + + $len = $self->_raw_read(\$buffer, 1) + while ! *$self->{EndStream} && $len >= 0 ; + + #return $len if $len < 0 ? $len : 0 ; + return $len < 0 ? 0 : 1 ; +} + +sub zap +{ + my $self = shift ; + + my $headerLength = *$self->{Info}{HeaderLength}; + my $block_offset = $headerLength + *$self->{Uncomp}->getLastBlockOffset(); + $_[0] = $headerLength + *$self->{Uncomp}->getEndOffset(); + #printf "# End $_[0], headerlen $headerLength \n";; + #printf "# block_offset $block_offset %x\n", $block_offset; + my $byte ; + ( $self->smartSeek($block_offset) && + $self->smartRead(\$byte, 1) ) + or return $self->saveErrorString(0, $!, $!); + + #printf "#byte is %x\n", unpack('C*',$byte); + *$self->{Uncomp}->resetLastBlockByte($byte); + #printf "#to byte is %x\n", unpack('C*',$byte); + + ( $self->smartSeek($block_offset) && + $self->smartWrite($byte) ) + or return $self->saveErrorString(0, $!, $!); + + #$self->smartSeek($end_offset, 1); + + return 1 ; +} + +sub createDeflate +{ + my $self = shift ; + my ($def, $status) = *$self->{Uncomp}->createDeflateStream( + -AppendOutput => 1, + -WindowBits => - MAX_WBITS, + -CRC32 => *$self->{Params}->getValue('crc32'), + -ADLER32 => *$self->{Params}->getValue('adler32'), + ); + + return wantarray ? ($status, $def) : $def ; +} + + +1; + +__END__ + + +=head1 NAME + +IO::Uncompress::RawInflate - Read RFC 1951 files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + my $status = rawinflate $input => $output [,OPTS] + or die "rawinflate failed: $RawInflateError\n"; + + my $z = new IO::Uncompress::RawInflate $input [OPTS] + or die "rawinflate failed: $RawInflateError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $status = $z->inflateSync() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $RawInflateError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + +=head1 DESCRIPTION + +This module provides a Perl interface that allows the reading of +files/buffers that conform to RFC 1951. + +For writing RFC 1951 files/buffers, see the companion module IO::Compress::RawDeflate. + +=head1 Functional Interface + +A top-level function, C<rawinflate>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + rawinflate $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "rawinflate failed: $RawInflateError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 rawinflate $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<rawinflate> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<rawinflate> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the uncompressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +uncompressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +uncompressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +uncompressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the uncompressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<rawinflate> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple compressed +files/buffers and C<$output_filename_or_reference> is +a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<rawinflate>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<rawinflate> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<rawinflate> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all uncompressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +uncompressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any uncompressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any uncompressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all uncompressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any uncompressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all uncompressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any uncompressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any uncompressed data is output. + +Defaults to 0. + +=item C<< MultiStream => 0|1 >> + +This option is a no-op. + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + +=back + +=head2 Examples + +To read the contents of the file C<file1.txt.1951> and write the +uncompressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + my $input = "file1.txt.1951"; + my $output = "file1.txt"; + rawinflate $input => $output + or die "rawinflate failed: $RawInflateError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.1951" + or die "Cannot open 'file1.txt.1951': $!\n" ; + my $buffer ; + rawinflate $input => \$buffer + or die "rawinflate failed: $RawInflateError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.1951" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + rawinflate '</my/home/*.txt.1951>' => '</my/home/#1.txt>' + or die "rawinflate failed: $RawInflateError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + + for my $input ( glob "/my/home/*.txt.1951" ) + { + my $output = $input; + $output =~ s/.1951// ; + rawinflate $input => $output + or die "Error compressing '$input': $RawInflateError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::RawInflate is shown below + + my $z = new IO::Uncompress::RawInflate $input [OPTS] + or die "IO::Uncompress::RawInflate failed: $RawInflateError\n"; + +Returns an C<IO::Uncompress::RawInflate> object on success and undef on failure. +The variable C<$RawInflateError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::RawInflate can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$input>. + +=back + +=head2 Constructor Options + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::RawInflate object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/buffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::RawInflate will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + +This option is a no-op. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size of the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the end of the compressed input stream has been reached. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + +Note that the implementation of C<seek> in this module does not provide +true random access to a compressed file/buffer. It works by uncompressing +data from the current offset in the file/buffer until it reaches the +uncompressed offset specified in the parameters to C<seek>. For very small +files this may be acceptable behaviour. For large files it may cause an +unacceptable delay. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to determine what constitutes a line +terminator. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::RawInflate object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::RawInflate +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::RawInflate at present. + +=over 5 + +=item :all + +Imports C<rawinflate> and C<$RawInflateError>. +Same as doing this + + use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; + +=back + +=head1 EXAMPLES + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +L<http://www.faqs.org/rfcs/rfc1950.html>, +L<http://www.faqs.org/rfcs/rfc1951.html> and +L<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +L<http://www.zlib.org>. + +The primary site for gzip is L<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm new file mode 100644 index 0000000000..5a35e018a6 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm @@ -0,0 +1,1868 @@ +package IO::Uncompress::Unzip; + +require 5.006 ; + +# for RFC1952 + +use strict ; +use warnings; +use bytes; + +use IO::File; +use IO::Uncompress::RawInflate 2.074 ; +use IO::Compress::Base::Common 2.074 qw(:Status ); +use IO::Uncompress::Adapter::Inflate 2.074 ; +use IO::Uncompress::Adapter::Identity 2.074 ; +use IO::Compress::Zlib::Extra 2.074 ; +use IO::Compress::Zip::Constants 2.074 ; + +use Compress::Raw::Zlib 2.074 () ; + +BEGIN +{ + eval{ require IO::Uncompress::Adapter::Bunzip2 ; + import IO::Uncompress::Adapter::Bunzip2 } ; + eval{ require IO::Uncompress::Adapter::UnLzma ; + import IO::Uncompress::Adapter::UnLzma } ; +} + + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError, %headerLookup); + +$VERSION = '2.074'; +$UnzipError = ''; + +@ISA = qw(IO::Uncompress::RawInflate Exporter); +@EXPORT_OK = qw( $UnzipError unzip ); +%EXPORT_TAGS = %IO::Uncompress::RawInflate::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + +%headerLookup = ( + ZIP_CENTRAL_HDR_SIG, \&skipCentralDirectory, + ZIP_END_CENTRAL_HDR_SIG, \&skipEndCentralDirectory, + ZIP64_END_CENTRAL_REC_HDR_SIG, \&skipCentralDirectory64Rec, + ZIP64_END_CENTRAL_LOC_HDR_SIG, \&skipCentralDirectory64Loc, + ZIP64_ARCHIVE_EXTRA_SIG, \&skipArchiveExtra, + ZIP64_DIGITAL_SIGNATURE_SIG, \&skipDigitalSignature, + ); + +sub new +{ + my $class = shift ; + my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$UnzipError); + $obj->_create(undef, 0, @_); +} + +sub unzip +{ + my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$UnzipError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + + return ( +# # Zip header fields + 'name' => [IO::Compress::Base::Common::Parse_any, undef], + + 'stream' => [IO::Compress::Base::Common::Parse_boolean, 0], + + # TODO - This means reading the central directory to get + # 1. the local header offsets + # 2. The compressed data length + ); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # unzip always needs crc32 + $got->setValue('crc32' => 1); + + *$self->{UnzipData}{Name} = $got->getValue('name'); + + return 1; +} + +sub mkUncomp +{ + my $self = shift ; + my $got = shift ; + + my $magic = $self->ckMagic() + or return 0; + + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + return 1; + +} + +sub ckMagic +{ + my $self = shift; + + my $magic ; + $self->smartReadExact(\$magic, 4); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Minimum header size is " . + 4 . " bytes") + if length $magic != 4 ; + + return $self->HeaderError("Bad Magic") + if ! _isZipMagic($magic) ; + + *$self->{Type} = 'zip'; + + return $magic ; +} + + +sub fastForward +{ + my $self = shift; + my $offset = shift; + + # TODO - if Stream isn't enabled & reading from file, use seek + + my $buffer = ''; + my $c = 1024 * 16; + + while ($offset > 0) + { + $c = length $offset + if length $offset < $c ; + + $offset -= $c; + + $self->smartReadExact(\$buffer, $c) + or return 0; + } + + return 1; +} + + +sub readHeader +{ + my $self = shift; + my $magic = shift ; + + my $name = *$self->{UnzipData}{Name} ; + my $hdr = $self->_readZipHeader($magic) ; + + while (defined $hdr) + { + if (! defined $name || $hdr->{Name} eq $name) + { + return $hdr ; + } + + # skip the data + # TODO - when Stream is off, use seek + my $buffer; + if (*$self->{ZipData}{Streaming}) { + + while (1) { + + my $b; + my $status = $self->smartRead(\$b, 1024 * 16); + return undef + if $status <= 0 ; + + my $temp_buf; + my $out; + $status = *$self->{Uncomp}->uncompr(\$b, \$temp_buf, 0, $out); + + return $self->saveErrorString(undef, *$self->{Uncomp}{Error}, + *$self->{Uncomp}{ErrorNo}) + if $self->saveStatus($status) == STATUS_ERROR; + + if ($status == STATUS_ENDSTREAM) { + *$self->{Uncomp}->reset(); + $self->pushBack($b) ; + last; + } + } + + # skip the trailer + $self->smartReadExact(\$buffer, $hdr->{TrailerLength}) + or return $self->saveErrorString(undef, "Truncated file"); + } + else { + my $c = $hdr->{CompressedLength}->get64bit(); + $self->fastForward($c) + or return $self->saveErrorString(undef, "Truncated file"); + $buffer = ''; + } + + $self->chkTrailer($buffer) == STATUS_OK + or return $self->saveErrorString(undef, "Truncated file"); + + $hdr = $self->_readFullZipHeader(); + + return $self->saveErrorString(undef, "Cannot find '$name'") + if $self->smartEof(); + } + + return undef; +} + +sub chkTrailer +{ + my $self = shift; + my $trailer = shift; + + my ($sig, $CRC32, $cSize, $uSize) ; + my ($cSizeHi, $uSizeHi) = (0, 0); + if (*$self->{ZipData}{Streaming}) { + $sig = unpack ("V", substr($trailer, 0, 4)); + $CRC32 = unpack ("V", substr($trailer, 4, 4)); + + if (*$self->{ZipData}{Zip64} ) { + $cSize = U64::newUnpack_V64 substr($trailer, 8, 8); + $uSize = U64::newUnpack_V64 substr($trailer, 16, 8); + } + else { + $cSize = U64::newUnpack_V32 substr($trailer, 8, 4); + $uSize = U64::newUnpack_V32 substr($trailer, 12, 4); + } + + return $self->TrailerError("Data Descriptor signature, got $sig") + if $sig != ZIP_DATA_HDR_SIG; + } + else { + ($CRC32, $cSize, $uSize) = + (*$self->{ZipData}{Crc32}, + *$self->{ZipData}{CompressedLen}, + *$self->{ZipData}{UnCompressedLen}); + } + + *$self->{Info}{CRC32} = *$self->{ZipData}{CRC32} ; + *$self->{Info}{CompressedLength} = $cSize->get64bit(); + *$self->{Info}{UncompressedLength} = $uSize->get64bit(); + + if (*$self->{Strict}) { + return $self->TrailerError("CRC mismatch") + if $CRC32 != *$self->{ZipData}{CRC32} ; + + return $self->TrailerError("CSIZE mismatch.") + if ! $cSize->equal(*$self->{CompSize}); + + return $self->TrailerError("USIZE mismatch.") + if ! $uSize->equal(*$self->{UnCompSize}); + } + + my $reachedEnd = STATUS_ERROR ; + # check for central directory or end of central directory + while (1) + { + my $magic ; + my $got = $self->smartRead(\$magic, 4); + + return $self->saveErrorString(STATUS_ERROR, "Truncated file") + if $got != 4 && *$self->{Strict}; + + if ($got == 0) { + return STATUS_EOF ; + } + elsif ($got < 0) { + return STATUS_ERROR ; + } + elsif ($got < 4) { + $self->pushBack($magic) ; + return STATUS_OK ; + } + + my $sig = unpack("V", $magic) ; + + my $hdr; + if ($hdr = $headerLookup{$sig}) + { + if (&$hdr($self, $magic) != STATUS_OK ) { + if (*$self->{Strict}) { + return STATUS_ERROR ; + } + else { + $self->clearError(); + return STATUS_OK ; + } + } + + if ($sig == ZIP_END_CENTRAL_HDR_SIG) + { + return STATUS_OK ; + last; + } + } + elsif ($sig == ZIP_LOCAL_HDR_SIG) + { + $self->pushBack($magic) ; + return STATUS_OK ; + } + else + { + # put the data back + $self->pushBack($magic) ; + last; + } + } + + return $reachedEnd ; +} + +sub skipCentralDirectory +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 46 - 4) + or return $self->TrailerError("Minimum header size is " . + 46 . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + #my $versionMadeBy = unpack ("v", substr($buffer, 4-4, 2)); + #my $extractVersion = unpack ("v", substr($buffer, 6-4, 2)); + #my $gpFlag = unpack ("v", substr($buffer, 8-4, 2)); + #my $compressedMethod = unpack ("v", substr($buffer, 10-4, 2)); + #my $lastModTime = unpack ("V", substr($buffer, 12-4, 4)); + #my $crc32 = unpack ("V", substr($buffer, 16-4, 4)); + my $compressedLength = unpack ("V", substr($buffer, 20-4, 4)); + my $uncompressedLength = unpack ("V", substr($buffer, 24-4, 4)); + my $filename_length = unpack ("v", substr($buffer, 28-4, 2)); + my $extra_length = unpack ("v", substr($buffer, 30-4, 2)); + my $comment_length = unpack ("v", substr($buffer, 32-4, 2)); + #my $disk_start = unpack ("v", substr($buffer, 34-4, 2)); + #my $int_file_attrib = unpack ("v", substr($buffer, 36-4, 2)); + #my $ext_file_attrib = unpack ("V", substr($buffer, 38-4, 2)); + #my $lcl_hdr_offset = unpack ("V", substr($buffer, 42-4, 2)); + + + my $filename; + my $extraField; + my $comment ; + if ($filename_length) + { + $self->smartReadExact(\$filename, $filename_length) + or return $self->TruncatedTrailer("filename"); + $keep .= $filename ; + } + + if ($extra_length) + { + $self->smartReadExact(\$extraField, $extra_length) + or return $self->TruncatedTrailer("extra"); + $keep .= $extraField ; + } + + if ($comment_length) + { + $self->smartReadExact(\$comment, $comment_length) + or return $self->TruncatedTrailer("comment"); + $keep .= $comment ; + } + + return STATUS_OK ; +} + +sub skipArchiveExtra +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 4) + or return $self->TrailerError("Minimum header size is " . + 4 . " bytes") ; + + my $keep = $magic . $buffer ; + + my $size = unpack ("V", $buffer); + + $self->smartReadExact(\$buffer, $size) + or return $self->TrailerError("Minimum header size is " . + $size . " bytes") ; + + $keep .= $buffer ; + *$self->{HeaderPending} = $keep ; + + return STATUS_OK ; +} + + +sub skipCentralDirectory64Rec +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 8) + or return $self->TrailerError("Minimum header size is " . + 8 . " bytes") ; + + my $keep = $magic . $buffer ; + + my ($sizeLo, $sizeHi) = unpack ("V V", $buffer); + my $size = $sizeHi * U64::MAX32 + $sizeLo; + + $self->fastForward($size) + or return $self->TrailerError("Minimum header size is " . + $size . " bytes") ; + + #$keep .= $buffer ; + #*$self->{HeaderPending} = $keep ; + + #my $versionMadeBy = unpack ("v", substr($buffer, 0, 2)); + #my $extractVersion = unpack ("v", substr($buffer, 2, 2)); + #my $diskNumber = unpack ("V", substr($buffer, 4, 4)); + #my $cntrlDirDiskNo = unpack ("V", substr($buffer, 8, 4)); + #my $entriesInThisCD = unpack ("V V", substr($buffer, 12, 8)); + #my $entriesInCD = unpack ("V V", substr($buffer, 20, 8)); + #my $sizeOfCD = unpack ("V V", substr($buffer, 28, 8)); + #my $offsetToCD = unpack ("V V", substr($buffer, 36, 8)); + + return STATUS_OK ; +} + +sub skipCentralDirectory64Loc +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 20 - 4) + or return $self->TrailerError("Minimum header size is " . + 20 . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + #my $startCdDisk = unpack ("V", substr($buffer, 4-4, 4)); + #my $offsetToCD = unpack ("V V", substr($buffer, 8-4, 8)); + #my $diskCount = unpack ("V", substr($buffer, 16-4, 4)); + + return STATUS_OK ; +} + +sub skipEndCentralDirectory +{ + my $self = shift; + my $magic = shift ; + + my $buffer; + $self->smartReadExact(\$buffer, 22 - 4) + or return $self->TrailerError("Minimum header size is " . + 22 . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + #my $diskNumber = unpack ("v", substr($buffer, 4-4, 2)); + #my $cntrlDirDiskNo = unpack ("v", substr($buffer, 6-4, 2)); + #my $entriesInThisCD = unpack ("v", substr($buffer, 8-4, 2)); + #my $entriesInCD = unpack ("v", substr($buffer, 10-4, 2)); + #my $sizeOfCD = unpack ("V", substr($buffer, 12-4, 4)); + #my $offsetToCD = unpack ("V", substr($buffer, 16-4, 4)); + my $comment_length = unpack ("v", substr($buffer, 20-4, 2)); + + + my $comment ; + if ($comment_length) + { + $self->smartReadExact(\$comment, $comment_length) + or return $self->TruncatedTrailer("comment"); + $keep .= $comment ; + } + + return STATUS_OK ; +} + + +sub _isZipMagic +{ + my $buffer = shift ; + return 0 if length $buffer < 4 ; + my $sig = unpack("V", $buffer) ; + return $sig == ZIP_LOCAL_HDR_SIG ; +} + + +sub _readFullZipHeader($) +{ + my ($self) = @_ ; + my $magic = '' ; + + $self->smartReadExact(\$magic, 4); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Minimum header size is " . + 30 . " bytes") + if length $magic != 4 ; + + + return $self->HeaderError("Bad Magic") + if ! _isZipMagic($magic) ; + + my $status = $self->_readZipHeader($magic); + delete *$self->{Transparent} if ! defined $status ; + return $status ; +} + +sub _readZipHeader($) +{ + my ($self, $magic) = @_ ; + my ($HeaderCRC) ; + my ($buffer) = '' ; + + $self->smartReadExact(\$buffer, 30 - 4) + or return $self->HeaderError("Minimum header size is " . + 30 . " bytes") ; + + my $keep = $magic . $buffer ; + *$self->{HeaderPending} = $keep ; + + my $extractVersion = unpack ("v", substr($buffer, 4-4, 2)); + my $gpFlag = unpack ("v", substr($buffer, 6-4, 2)); + my $compressedMethod = unpack ("v", substr($buffer, 8-4, 2)); + my $lastModTime = unpack ("V", substr($buffer, 10-4, 4)); + my $crc32 = unpack ("V", substr($buffer, 14-4, 4)); + my $compressedLength = U64::newUnpack_V32 substr($buffer, 18-4, 4); + my $uncompressedLength = U64::newUnpack_V32 substr($buffer, 22-4, 4); + my $filename_length = unpack ("v", substr($buffer, 26-4, 2)); + my $extra_length = unpack ("v", substr($buffer, 28-4, 2)); + + my $filename; + my $extraField; + my @EXTRA = (); + my $streamingMode = ($gpFlag & ZIP_GP_FLAG_STREAMING_MASK) ? 1 : 0 ; + + return $self->HeaderError("Encrypted content not supported") + if $gpFlag & (ZIP_GP_FLAG_ENCRYPTED_MASK|ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK); + + return $self->HeaderError("Patch content not supported") + if $gpFlag & ZIP_GP_FLAG_PATCHED_MASK; + + *$self->{ZipData}{Streaming} = $streamingMode; + + + if ($filename_length) + { + $self->smartReadExact(\$filename, $filename_length) + or return $self->TruncatedHeader("Filename"); + $keep .= $filename ; + } + + my $zip64 = 0 ; + + if ($extra_length) + { + $self->smartReadExact(\$extraField, $extra_length) + or return $self->TruncatedHeader("Extra Field"); + + my $bad = IO::Compress::Zlib::Extra::parseRawExtra($extraField, + \@EXTRA, 1, 0); + return $self->HeaderError($bad) + if defined $bad; + + $keep .= $extraField ; + + my %Extra ; + for (@EXTRA) + { + $Extra{$_->[0]} = \$_->[1]; + } + + if (defined $Extra{ZIP_EXTRA_ID_ZIP64()}) + { + $zip64 = 1 ; + + my $buff = ${ $Extra{ZIP_EXTRA_ID_ZIP64()} }; + + # This code assumes that all the fields in the Zip64 + # extra field aren't necessarily present. The spec says that + # they only exist if the equivalent local headers are -1. + + if (! $streamingMode) { + my $offset = 0 ; + + if (U64::full32 $uncompressedLength->get32bit() ) { + $uncompressedLength + = U64::newUnpack_V64 substr($buff, 0, 8); + + $offset += 8 ; + } + + if (U64::full32 $compressedLength->get32bit() ) { + + $compressedLength + = U64::newUnpack_V64 substr($buff, $offset, 8); + + $offset += 8 ; + } + } + } + } + + *$self->{ZipData}{Zip64} = $zip64; + + if (! $streamingMode) { + *$self->{ZipData}{Streaming} = 0; + *$self->{ZipData}{Crc32} = $crc32; + *$self->{ZipData}{CompressedLen} = $compressedLength; + *$self->{ZipData}{UnCompressedLen} = $uncompressedLength; + *$self->{CompressedInputLengthRemaining} = + *$self->{CompressedInputLength} = $compressedLength->get64bit(); + } + + *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(undef); + *$self->{ZipData}{Method} = $compressedMethod; + if ($compressedMethod == ZIP_CM_DEFLATE) + { + *$self->{Type} = 'zip-deflate'; + my $obj = IO::Uncompress::Adapter::Inflate::mkUncompObject(1,0,0); + + *$self->{Uncomp} = $obj; + } + elsif ($compressedMethod == ZIP_CM_BZIP2) + { + return $self->HeaderError("Unsupported Compression format $compressedMethod") + if ! defined $IO::Uncompress::Adapter::Bunzip2::VERSION ; + + *$self->{Type} = 'zip-bzip2'; + + my $obj = IO::Uncompress::Adapter::Bunzip2::mkUncompObject(); + + *$self->{Uncomp} = $obj; + } + elsif ($compressedMethod == ZIP_CM_LZMA) + { + return $self->HeaderError("Unsupported Compression format $compressedMethod") + if ! defined $IO::Uncompress::Adapter::UnLzma::VERSION ; + + *$self->{Type} = 'zip-lzma'; + my $LzmaHeader; + $self->smartReadExact(\$LzmaHeader, 4) + or return $self->saveErrorString(undef, "Truncated file"); + my ($verHi, $verLo) = unpack ("CC", substr($LzmaHeader, 0, 2)); + my $LzmaPropertiesSize = unpack ("v", substr($LzmaHeader, 2, 2)); + + + my $LzmaPropertyData; + $self->smartReadExact(\$LzmaPropertyData, $LzmaPropertiesSize) + or return $self->saveErrorString(undef, "Truncated file"); + + if (! $streamingMode) { + *$self->{ZipData}{CompressedLen}->subtract(4 + $LzmaPropertiesSize) ; + *$self->{CompressedInputLengthRemaining} = + *$self->{CompressedInputLength} = *$self->{ZipData}{CompressedLen}->get64bit(); + } + + my $obj = + IO::Uncompress::Adapter::UnLzma::mkUncompZipObject($LzmaPropertyData); + + *$self->{Uncomp} = $obj; + } + elsif ($compressedMethod == ZIP_CM_STORE) + { + *$self->{Type} = 'zip-stored'; + + my $obj = + IO::Uncompress::Adapter::Identity::mkUncompObject($streamingMode, + $zip64); + + *$self->{Uncomp} = $obj; + } + else + { + return $self->HeaderError("Unsupported Compression format $compressedMethod"); + } + + return { + 'Type' => 'zip', + 'FingerprintLength' => 4, + #'HeaderLength' => $compressedMethod == 8 ? length $keep : 0, + 'HeaderLength' => length $keep, + 'Zip64' => $zip64, + 'TrailerLength' => ! $streamingMode ? 0 : $zip64 ? 24 : 16, + 'Header' => $keep, + 'CompressedLength' => $compressedLength , + 'UncompressedLength' => $uncompressedLength , + 'CRC32' => $crc32 , + 'Name' => $filename, + 'Time' => _dosToUnixTime($lastModTime), + 'Stream' => $streamingMode, + + 'MethodID' => $compressedMethod, + 'MethodName' => $compressedMethod == ZIP_CM_DEFLATE + ? "Deflated" + : $compressedMethod == ZIP_CM_BZIP2 + ? "Bzip2" + : $compressedMethod == ZIP_CM_LZMA + ? "Lzma" + : $compressedMethod == ZIP_CM_STORE + ? "Stored" + : "Unknown" , + +# 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0, +# 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0, +# 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0, +# 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0, +# 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0, +# 'Comment' => $comment, +# 'OsID' => $os, +# 'OsName' => defined $GZIP_OS_Names{$os} +# ? $GZIP_OS_Names{$os} : "Unknown", +# 'HeaderCRC' => $HeaderCRC, +# 'Flags' => $flag, +# 'ExtraFlags' => $xfl, + 'ExtraFieldRaw' => $extraField, + 'ExtraField' => [ @EXTRA ], + + + } +} + +sub filterUncompressed +{ + my $self = shift ; + + if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { + *$self->{ZipData}{CRC32} = *$self->{Uncomp}->crc32() ; + } + else { + *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(${$_[0]}, *$self->{ZipData}{CRC32}, $_[1]); + } +} + + +# from Archive::Zip & info-zip +sub _dosToUnixTime +{ + my $dt = shift; + + my $year = ( ( $dt >> 25 ) & 0x7f ) + 80; + my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1; + my $mday = ( ( $dt >> 16 ) & 0x1f ); + + my $hour = ( ( $dt >> 11 ) & 0x1f ); + my $min = ( ( $dt >> 5 ) & 0x3f ); + my $sec = ( ( $dt << 1 ) & 0x3e ); + + + use POSIX 'mktime'; + + my $time_t = mktime( $sec, $min, $hour, $mday, $mon, $year, 0, 0, -1 ); + return 0 if ! defined $time_t; + return $time_t; +} + +#sub scanCentralDirectory +#{ +# # Use cases +# # 1 32-bit CD +# # 2 64-bit CD +# +# my $self = shift ; +# +# my @CD = (); +# my $offset = $self->findCentralDirectoryOffset(); +# +# return 0 +# if ! defined $offset; +# +# $self->smarkSeek($offset, 0, SEEK_SET) ; +# +# # Now walk the Central Directory Records +# my $buffer ; +# while ($self->smartReadExact(\$buffer, 46) && +# unpack("V", $buffer) == ZIP_CENTRAL_HDR_SIG) { +# +# my $compressedLength = unpack ("V", substr($buffer, 20, 4)); +# my $filename_length = unpack ("v", substr($buffer, 28, 2)); +# my $extra_length = unpack ("v", substr($buffer, 30, 2)); +# my $comment_length = unpack ("v", substr($buffer, 32, 2)); +# +# $self->smarkSeek($filename_length + $extra_length + $comment_length, 0, SEEK_CUR) +# if $extra_length || $comment_length || $filename_length; +# push @CD, $compressedLength ; +# } +# +#} +# +#sub findCentralDirectoryOffset +#{ +# my $self = shift ; +# +# # Most common use-case is where there is no comment, so +# # know exactly where the end of central directory record +# # should be. +# +# $self->smarkSeek(-22, 0, SEEK_END) ; +# +# my $buffer; +# $self->smartReadExact(\$buffer, 22) ; +# +# my $zip64 = 0; +# my $centralDirOffset ; +# if ( unpack("V", $buffer) == ZIP_END_CENTRAL_HDR_SIG ) { +# $centralDirOffset = unpack ("V", substr($buffer, 16, 2)); +# } +# else { +# die "xxxx"; +# } +# +# return $centralDirOffset ; +#} +# +#sub is84BitCD +#{ +# # TODO +# my $self = shift ; +#} + + +sub skip +{ + my $self = shift; + my $size = shift; + + use Fcntl qw(SEEK_CUR); + if (ref $size eq 'U64') { + $self->smartSeek($size->get64bit(), SEEK_CUR); + } + else { + $self->smartSeek($size, SEEK_CUR); + } + +} + + +sub scanCentralDirectory +{ + my $self = shift; + + my $here = $self->tell(); + + # Use cases + # 1 32-bit CD + # 2 64-bit CD + + my @CD = (); + my $offset = $self->findCentralDirectoryOffset(); + + return () + if ! defined $offset; + + $self->smarkSeek($offset, 0, SEEK_SET) ; + + # Now walk the Central Directory Records + my $buffer ; + while ($self->smartReadExact(\$buffer, 46) && + unpack("V", $buffer) == ZIP_CENTRAL_HDR_SIG) { + + my $compressedLength = unpack("V", substr($buffer, 20, 4)); + my $uncompressedLength = unpack("V", substr($buffer, 24, 4)); + my $filename_length = unpack("v", substr($buffer, 28, 2)); + my $extra_length = unpack("v", substr($buffer, 30, 2)); + my $comment_length = unpack("v", substr($buffer, 32, 2)); + + $self->skip($filename_length ) ; + + my $v64 = new U64 $compressedLength ; + + if (U64::full32 $compressedLength ) { + $self->smartReadExact(\$buffer, $extra_length) ; + die "xxx $offset $comment_length $filename_length $extra_length" . length($buffer) + if length($buffer) != $extra_length; + my $got = $self->get64Extra($buffer, U64::full32 $uncompressedLength); + + # If not Zip64 extra field, assume size is 0xFFFFFFFF + $v64 = $got if defined $got; + } + else { + $self->skip($extra_length) ; + } + + $self->skip($comment_length ) ; + + push @CD, $v64 ; + } + + $self->smartSeek($here, 0, SEEK_SET) ; + + return @CD; +} + +sub get64Extra +{ + my $self = shift ; + + my $buffer = shift; + my $is_uncomp = shift ; + + my $extra = IO::Compress::Zlib::Extra::findID(0x0001, $buffer); + + if (! defined $extra) + { + return undef; + } + else + { + my $u64 = U64::newUnpack_V64(substr($extra, $is_uncomp ? 8 : 0)) ; + return $u64; + } +} + +sub offsetFromZip64 +{ + my $self = shift ; + my $here = shift; + + $self->smartSeek($here - 20, 0, SEEK_SET) + or die "xx $!" ; + + my $buffer; + my $got = 0; + $self->smartReadExact(\$buffer, 20) + or die "xxx $here $got $!" ; + + if ( unpack("V", $buffer) == ZIP64_END_CENTRAL_LOC_HDR_SIG ) { + my $cd64 = U64::Value_VV64 substr($buffer, 8, 8); + + $self->smartSeek($cd64, 0, SEEK_SET) ; + + $self->smartReadExact(\$buffer, 4) + or die "xxx" ; + + if ( unpack("V", $buffer) == ZIP64_END_CENTRAL_REC_HDR_SIG ) { + + $self->smartReadExact(\$buffer, 8) + or die "xxx" ; + my $size = U64::Value_VV64($buffer); + $self->smartReadExact(\$buffer, $size) + or die "xxx" ; + + my $cd64 = U64::Value_VV64 substr($buffer, 36, 8); + + return $cd64 ; + } + + die "zzz"; + } + + die "zzz"; +} + +use constant Pack_ZIP_END_CENTRAL_HDR_SIG => pack("V", ZIP_END_CENTRAL_HDR_SIG); + +sub findCentralDirectoryOffset +{ + my $self = shift ; + + # Most common use-case is where there is no comment, so + # know exactly where the end of central directory record + # should be. + + $self->smartSeek(-22, 0, SEEK_END) ; + my $here = $self->tell(); + + my $buffer; + $self->smartReadExact(\$buffer, 22) + or die "xxx" ; + + my $zip64 = 0; + my $centralDirOffset ; + if ( unpack("V", $buffer) == ZIP_END_CENTRAL_HDR_SIG ) { + $centralDirOffset = unpack("V", substr($buffer, 16, 4)); + } + else { + $self->smartSeek(0, 0, SEEK_END) ; + + my $fileLen = $self->tell(); + my $want = 0 ; + + while(1) { + $want += 1024; + my $seekTo = $fileLen - $want; + if ($seekTo < 0 ) { + $seekTo = 0; + $want = $fileLen ; + } + $self->smartSeek( $seekTo, 0, SEEK_SET) + or die "xxx $!" ; + my $got; + $self->smartReadExact($buffer, $want) + or die "xxx " ; + my $pos = rindex( $buffer, Pack_ZIP_END_CENTRAL_HDR_SIG); + + if ($pos >= 0) { + #$here = $self->tell(); + $here = $seekTo + $pos ; + $centralDirOffset = unpack("V", substr($buffer, $pos + 16, 4)); + last ; + } + + return undef + if $want == $fileLen; + } + } + + $centralDirOffset = $self->offsetFromZip64($here) + if U64::full32 $centralDirOffset ; + + return $centralDirOffset ; +} + +1; + +__END__ + + +=head1 NAME + +IO::Uncompress::Unzip - Read zip files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + my $status = unzip $input => $output [,OPTS] + or die "unzip failed: $UnzipError\n"; + + my $z = new IO::Uncompress::Unzip $input [OPTS] + or die "unzip failed: $UnzipError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $status = $z->inflateSync() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $UnzipError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + +=head1 DESCRIPTION + +This module provides a Perl interface that allows the reading of +zlib files/buffers. + +For writing zip files/buffers, see the companion module IO::Compress::Zip. + +=head1 Functional Interface + +A top-level function, C<unzip>, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L</"OO Interface"> +section. + + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + unzip $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "unzip failed: $UnzipError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 unzip $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C<unzip> expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<unzip> will assume that it is an +I<input fileglob string>. The input is the list of files that match the +fileglob. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the uncompressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +uncompressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +uncompressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +uncompressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the uncompressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C<unzip> will assume that it is an +I<output fileglob string>. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C<undef> will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple compressed +files/buffers and C<$output_filename_or_reference> is +a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C<unzip>, +C<OPTS>, are the same as those used with the OO interface defined in the +L</"Constructor Options"> section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C<unzip> that are filehandles. + +If C<AutoClose> is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C<unzip> has +completed. + +This parameter defaults to 0. + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C<binmode> before writing to the +file. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C<Append> is enabled, all uncompressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +uncompressed data is written to it. + +=item * A Filename + +If C<Append> is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any uncompressed +data is written to it. + +=item * A Filehandle + +If C<Append> is enabled, the filehandle will be positioned to the end of +the file via a call to C<seek> before any uncompressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C<Append> is specified, and set to true, it will I<append> all uncompressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any uncompressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all uncompressed data will be +appended to the existing buffer. + +Conversely when C<Append> is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any uncompressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any uncompressed data is output. + +Defaults to 0. + +=item C<< MultiStream => 0|1 >> + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option. + +=back + +=head2 Examples + +Say you have a zip file, C<file1.zip>, that only contains a +single member, you can read it and write the uncompressed data to the +file C<file1.txt> like this. + + use strict ; + use warnings ; + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + my $input = "file1.zip"; + my $output = "file1.txt"; + unzip $input => $output + or die "unzip failed: $UnzipError\n"; + +If you have a zip file that contains multiple members and want to read a +specific member from the file, say C<"data1">, use the C<Name> option + + use strict ; + use warnings ; + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + my $input = "file1.zip"; + my $output = "file1.txt"; + unzip $input => $output, Name => "data1" + or die "unzip failed: $UnzipError\n"; + +Alternatively, if you want to read the C<"data1"> member into memory, use +a scalar reference for the C<output> parameter. + + use strict ; + use warnings ; + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + my $input = "file1.zip"; + my $output ; + unzip $input => \$output, Name => "data1" + or die "unzip failed: $UnzipError\n"; + # $output now contains the uncompressed data + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + use IO::File ; + + my $input = new IO::File "<file1.zip" + or die "Cannot open 'file1.zip': $!\n" ; + my $buffer ; + unzip $input => \$buffer + or die "unzip failed: $UnzipError\n"; + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::Unzip is shown below + + my $z = new IO::Uncompress::Unzip $input [OPTS] + or die "IO::Uncompress::Unzip failed: $UnzipError\n"; + +Returns an C<IO::Uncompress::Unzip> object on success and undef on failure. +The variable C<$UnzipError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::Unzip can be used exactly like an L<IO::File|IO::File> filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$input>. + +=back + +=head2 Constructor Options + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< Name => "membername" >> + +Open "membername" from the zip file for reading. + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C<close> method is called or the IO::Uncompress::Unzip object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + +Treats the complete zip file/buffer as a single compressed data +stream. When reading in multi-stream mode each member of the zip +file/buffer will be uncompressed in turn until the end of the file/buffer +is encountered. + +This parameter defaults to 0. + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I<primed> with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/buffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::Unzip will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C<read> method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C<read> method. + +If set to 0, the contents of the output parameter of the C<read> method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size of the compressed block is +determined by the C<Buffer> option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C<Append> parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C<read> method and the +previous one, is that this one will attempt to return I<exactly> C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + +=head2 inflateSync + +Usage is + + $status = $z->inflateSync() + +TODO + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the end of the compressed input stream has been reached. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C<seek> functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + +Note that the implementation of C<seek> in this module does not provide +true random access to a compressed file/buffer. It works by uncompressing +data from the current offset in the file/buffer until it reaches the +uncompressed offset specified in the parameters to C<seek>. For very small +files this may be acceptable behaviour. For large files it may cause an +unacceptable delay. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C<EXPR> is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C<undef>. + +B<Note> that the special variable C<$|> B<cannot> be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +Returns the current uncompressed line number. If C<EXPR> is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to determine what constitutes a line +terminator. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C<fileno> +will return the underlying file descriptor. Once the C<close> method is +called C<fileno> will return C<undef>. + +If the C<$z> object is associated with a buffer, this method will return +C<undef>. + +=head2 close + + $z->close() ; + close $z ; + +Closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::Unzip object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C<close> method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C<close> explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C<AutoClose> option has been enabled when the IO::Uncompress::Unzip +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C<trailingData> will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C<trailingData> will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C<trailingData> if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C<trailingData> by setting the +C<InputLength> option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::Unzip at present. + +=over 5 + +=item :all + +Imports C<unzip> and C<$UnzipError>. +Same as doing this + + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + +=back + +=head1 EXAMPLES + +=head2 Working with Net::FTP + +See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> + +=head2 Walking through a zip file + +The code below can be used to traverse a zip file, one compressed data +stream at a time. + + use IO::Uncompress::Unzip qw($UnzipError); + + my $zipfile = "somefile.zip"; + my $u = new IO::Uncompress::Unzip $zipfile + or die "Cannot open $zipfile: $UnzipError"; + + my $status; + for ($status = 1; $status > 0; $status = $u->nextStream()) + { + + my $name = $u->getHeaderInfo()->{Name}; + warn "Processing member $name\n" ; + + my $buff; + while (($status = $u->read($buff)) > 0) { + # Do something here + } + + last if $status < 0; + } + + die "Error processing $zipfile: $!\n" + if $status < 0 ; + +Each individual compressed data stream is read until the logical +end-of-file is reached. Then C<nextStream> is called. This will skip to the +start of the next compressed data stream and clear the end-of-file flag. + +It is also worth noting that C<nextStream> can be called at any time -- you +don't have to wait until you have exhausted a compressed data stream before +skipping to the next one. + +=head2 Unzipping a complete zip file to disk + +Daniel S. Sterling has written a script that uses C<IO::Uncompress::UnZip> +to read a zip file and unzip its contents to disk. + +The script is available from L<https://gist.github.com/eqhmcow/5389877> + +=head1 SEE ALSO + +L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<IO::Compress::FAQ|IO::Compress::FAQ> + +L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, +L<Archive::Tar|Archive::Tar>, +L<IO::Zlib|IO::Zlib> + +For RFC 1950, 1951 and 1952 see +L<http://www.faqs.org/rfcs/rfc1950.html>, +L<http://www.faqs.org/rfcs/rfc1951.html> and +L<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +L<http://www.zlib.org>. + +The primary site for gzip is L<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, C<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2017 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Zlib.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Zlib.pm new file mode 100644 index 0000000000..55534b4f37 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IO/Zlib.pm @@ -0,0 +1,652 @@ +# IO::Zlib.pm +# +# Copyright (c) 1998-2004 Tom Hughes <tom@compton.nu>. +# All rights reserved. This program is free software; you can redistribute +# it and/or modify it under the same terms as Perl itself. + +package IO::Zlib; + +$VERSION = "1.10"; + +=head1 NAME + +IO::Zlib - IO:: style interface to L<Compress::Zlib> + +=head1 SYNOPSIS + +With any version of Perl 5 you can use the basic OO interface: + + use IO::Zlib; + + $fh = new IO::Zlib; + if ($fh->open("file.gz", "rb")) { + print <$fh>; + $fh->close; + } + + $fh = IO::Zlib->new("file.gz", "wb9"); + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = IO::Zlib->new("file.gz", "rb"); + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + +With Perl 5.004 you can also use the TIEHANDLE interface to access +compressed files just like ordinary files: + + use IO::Zlib; + + tie *FILE, 'IO::Zlib', "file.gz", "wb"; + print FILE "line 1\nline2\n"; + + tie *FILE, 'IO::Zlib', "file.gz", "rb"; + while (<FILE>) { print "LINE: ", $_ }; + +=head1 DESCRIPTION + +C<IO::Zlib> provides an IO:: style interface to L<Compress::Zlib> and +hence to gzip/zlib compressed files. It provides many of the same methods +as the L<IO::Handle> interface. + +Starting from IO::Zlib version 1.02, IO::Zlib can also use an +external F<gzip> command. The default behaviour is to try to use +an external F<gzip> if no C<Compress::Zlib> can be loaded, unless +explicitly disabled by + + use IO::Zlib qw(:gzip_external 0); + +If explicitly enabled by + + use IO::Zlib qw(:gzip_external 1); + +then the external F<gzip> is used B<instead> of C<Compress::Zlib>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Zlib> object. If it receives any parameters, they are +passed to the method C<open>; if the open fails, the object is destroyed. +Otherwise, it is returned to the caller. + +=back + +=head1 OBJECT METHODS + +=over 4 + +=item open ( FILENAME, MODE ) + +C<open> takes two arguments. The first is the name of the file to open +and the second is the open mode. The mode can be anything acceptable to +L<Compress::Zlib> and by extension anything acceptable to I<zlib> (that +basically means POSIX fopen() style mode strings plus an optional number +to indicate the compression level). + +=item opened + +Returns true if the object currently refers to a opened file. + +=item close + +Close the file associated with the object and disassociate +the file from the handle. +Done automatically on destroy. + +=item getc + +Return the next character from the file, or undef if none remain. + +=item getline + +Return the next line from the file, or undef on end of string. +Can safely be called in an array context. +Currently ignores $/ ($INPUT_RECORD_SEPARATOR or $RS when L<English> +is in use) and treats lines as delimited by "\n". + +=item getlines + +Get all remaining lines from the file. +It will croak() if accidentally called in a scalar context. + +=item print ( ARGS... ) + +Print ARGS to the file. + +=item read ( BUF, NBYTES, [OFFSET] ) + +Read some bytes from the file. +Returns the number of bytes actually read, 0 on end-of-file, undef on error. + +=item eof + +Returns true if the handle is currently positioned at end of file? + +=item seek ( OFFSET, WHENCE ) + +Seek to a given position in the stream. +Not yet supported. + +=item tell + +Return the current position in the stream, as a numeric offset. +Not yet supported. + +=item setpos ( POS ) + +Set the current position, using the opaque value returned by C<getpos()>. +Not yet supported. + +=item getpos ( POS ) + +Return the current position in the string, as an opaque object. +Not yet supported. + +=back + +=head1 USING THE EXTERNAL GZIP + +If the external F<gzip> is used, the following C<open>s are used: + + open(FH, "gzip -dc $filename |") # for read opens + open(FH, " | gzip > $filename") # for write opens + +You can modify the 'commands' for example to hardwire +an absolute path by e.g. + + use IO::Zlib ':gzip_read_open' => '/some/where/gunzip -c %s |'; + use IO::Zlib ':gzip_write_open' => '| /some/where/gzip.exe > %s'; + +The C<%s> is expanded to be the filename (C<sprintf> is used, so be +careful to escape any other C<%> signs). The 'commands' are checked +for sanity - they must contain the C<%s>, and the read open must end +with the pipe sign, and the write open must begin with the pipe sign. + +=head1 CLASS METHODS + +=over 4 + +=item has_Compress_Zlib + +Returns true if C<Compress::Zlib> is available. Note that this does +not mean that C<Compress::Zlib> is being used: see L</gzip_external> +and L<gzip_used>. + +=item gzip_external + +Undef if an external F<gzip> B<can> be used if C<Compress::Zlib> is +not available (see L</has_Compress_Zlib>), true if an external F<gzip> +is explicitly used, false if an external F<gzip> must not be used. +See L</gzip_used>. + +=item gzip_used + +True if an external F<gzip> is being used, false if not. + +=item gzip_read_open + +Return the 'command' being used for opening a file for reading using an +external F<gzip>. + +=item gzip_write_open + +Return the 'command' being used for opening a file for writing using an +external F<gzip>. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item IO::Zlib::getlines: must be called in list context + +If you want read lines, you must read in list context. + +=item IO::Zlib::gzopen_external: mode '...' is illegal + +Use only modes 'rb' or 'wb' or /wb[1-9]/. + +=item IO::Zlib::import: '...' is illegal + +The known import symbols are the C<:gzip_external>, C<:gzip_read_open>, +and C<:gzip_write_open>. Anything else is not recognized. + +=item IO::Zlib::import: ':gzip_external' requires an argument + +The C<:gzip_external> requires one boolean argument. + +=item IO::Zlib::import: 'gzip_read_open' requires an argument + +The C<:gzip_external> requires one string argument. + +=item IO::Zlib::import: 'gzip_read' '...' is illegal + +The C<:gzip_read_open> argument must end with the pipe sign (|) +and have the C<%s> for the filename. See L</"USING THE EXTERNAL GZIP">. + +=item IO::Zlib::import: 'gzip_write_open' requires an argument + +The C<:gzip_external> requires one string argument. + +=item IO::Zlib::import: 'gzip_write_open' '...' is illegal + +The C<:gzip_write_open> argument must begin with the pipe sign (|) +and have the C<%s> for the filename. An output redirect (>) is also +often a good idea, depending on your operating system shell syntax. +See L</"USING THE EXTERNAL GZIP">. + +=item IO::Zlib::import: no Compress::Zlib and no external gzip + +Given that we failed to load C<Compress::Zlib> and that the use of + an external F<gzip> was disabled, IO::Zlib has not much chance of working. + +=item IO::Zlib::open: needs a filename + +No filename, no open. + +=item IO::Zlib::READ: NBYTES must be specified + +We must know how much to read. + +=item IO::Zlib::WRITE: too long LENGTH + +The LENGTH must be less than or equal to the buffer size. + +=back + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle>, +L<Compress::Zlib> + +=head1 HISTORY + +Created by Tom Hughes E<lt>F<tom@compton.nu>E<gt>. + +Support for external gzip added by Jarkko Hietaniemi E<lt>F<jhi@iki.fi>E<gt>. + +=head1 COPYRIGHT + +Copyright (c) 1998-2004 Tom Hughes E<lt>F<tom@compton.nu>E<gt>. +All rights reserved. This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +=cut + +require 5.006; + +use strict; +use vars qw($VERSION $AUTOLOAD @ISA); + +use Carp; +use Fcntl qw(SEEK_SET); + +my $has_Compress_Zlib; +my $aliased; + +sub has_Compress_Zlib { + $has_Compress_Zlib; +} + +BEGIN { + eval { require Compress::Zlib }; + $has_Compress_Zlib = $@ || $Compress::Zlib::VERSION < 2.000 ? 0 : 1; +} + +use Symbol; +use Tie::Handle; + +# These might use some $^O logic. +my $gzip_read_open = "gzip -dc %s |"; +my $gzip_write_open = "| gzip > %s"; + +my $gzip_external; +my $gzip_used; + +sub gzip_read_open { + $gzip_read_open; +} + +sub gzip_write_open { + $gzip_write_open; +} + +sub gzip_external { + $gzip_external; +} + +sub gzip_used { + $gzip_used; +} + +sub can_gunzip { + $has_Compress_Zlib || $gzip_external; +} + +sub _import { + my $import = shift; + while (@_) { + if ($_[0] eq ':gzip_external') { + shift; + if (@_) { + $gzip_external = shift; + } else { + croak "$import: ':gzip_external' requires an argument"; + } + } + elsif ($_[0] eq ':gzip_read_open') { + shift; + if (@_) { + $gzip_read_open = shift; + croak "$import: ':gzip_read_open' '$gzip_read_open' is illegal" + unless $gzip_read_open =~ /^.+%s.+\|\s*$/; + } else { + croak "$import: ':gzip_read_open' requires an argument"; + } + } + elsif ($_[0] eq ':gzip_write_open') { + shift; + if (@_) { + $gzip_write_open = shift; + croak "$import: ':gzip_write_open' '$gzip_read_open' is illegal" + unless $gzip_write_open =~ /^\s*\|.+%s.*$/; + } else { + croak "$import: ':gzip_write_open' requires an argument"; + } + } + else { + last; + } + } + return @_; +} + +sub _alias { + my $import = shift; + if ((!$has_Compress_Zlib && !defined $gzip_external) || $gzip_external) { + # The undef *gzopen is really needed only during + # testing where we eval several 'use IO::Zlib's. + undef *gzopen; + *gzopen = \&gzopen_external; + *IO::Handle::gzread = \&gzread_external; + *IO::Handle::gzwrite = \&gzwrite_external; + *IO::Handle::gzreadline = \&gzreadline_external; + *IO::Handle::gzeof = \&gzeof_external; + *IO::Handle::gzclose = \&gzclose_external; + $gzip_used = 1; + } else { + croak "$import: no Compress::Zlib and no external gzip" + unless $has_Compress_Zlib; + *gzopen = \&Compress::Zlib::gzopen; + *gzread = \&Compress::Zlib::gzread; + *gzwrite = \&Compress::Zlib::gzwrite; + *gzreadline = \&Compress::Zlib::gzreadline; + *gzeof = \&Compress::Zlib::gzeof; + } + $aliased = 1; +} + +sub import { + shift; + my $import = "IO::Zlib::import"; + if (@_) { + if (_import($import, @_)) { + croak "$import: '@_' is illegal"; + } + } + _alias($import); +} + +@ISA = qw(Tie::Handle); + +sub TIEHANDLE +{ + my $class = shift; + my @args = @_; + + my $self = bless {}, $class; + + return @args ? $self->OPEN(@args) : $self; +} + +sub DESTROY +{ +} + +sub OPEN +{ + my $self = shift; + my $filename = shift; + my $mode = shift; + + croak "IO::Zlib::open: needs a filename" unless defined($filename); + + $self->{'file'} = gzopen($filename,$mode); + + return defined($self->{'file'}) ? $self : undef; +} + +sub CLOSE +{ + my $self = shift; + + return undef unless defined($self->{'file'}); + + my $status = $self->{'file'}->gzclose(); + + delete $self->{'file'}; + + return ($status == 0) ? 1 : undef; +} + +sub READ +{ + my $self = shift; + my $bufref = \$_[0]; + my $nbytes = $_[1]; + my $offset = $_[2] || 0; + + croak "IO::Zlib::READ: NBYTES must be specified" unless defined($nbytes); + + $$bufref = "" unless defined($$bufref); + + my $bytesread = $self->{'file'}->gzread(substr($$bufref,$offset),$nbytes); + + return undef if $bytesread < 0; + + return $bytesread; +} + +sub READLINE +{ + my $self = shift; + + my $line; + + return () if $self->{'file'}->gzreadline($line) <= 0; + + return $line unless wantarray; + + my @lines = $line; + + while ($self->{'file'}->gzreadline($line) > 0) + { + push @lines, $line; + } + + return @lines; +} + +sub WRITE +{ + my $self = shift; + my $buf = shift; + my $length = shift; + my $offset = shift; + + croak "IO::Zlib::WRITE: too long LENGTH" unless $offset + $length <= length($buf); + + return $self->{'file'}->gzwrite(substr($buf,$offset,$length)); +} + +sub EOF +{ + my $self = shift; + + return $self->{'file'}->gzeof(); +} + +sub FILENO +{ + return undef; +} + +sub new +{ + my $class = shift; + my @args = @_; + + _alias("new", @_) unless $aliased; # Some call new IO::Zlib directly... + + my $self = gensym(); + + tie *{$self}, $class, @args; + + return tied(${$self}) ? bless $self, $class : undef; +} + +sub getline +{ + my $self = shift; + + return scalar tied(*{$self})->READLINE(); +} + +sub getlines +{ + my $self = shift; + + croak "IO::Zlib::getlines: must be called in list context" + unless wantarray; + + return tied(*{$self})->READLINE(); +} + +sub opened +{ + my $self = shift; + + return defined tied(*{$self})->{'file'}; +} + +sub AUTOLOAD +{ + my $self = shift; + + $AUTOLOAD =~ s/.*:://; + $AUTOLOAD =~ tr/a-z/A-Z/; + + return tied(*{$self})->$AUTOLOAD(@_); +} + +sub gzopen_external { + my ($filename, $mode) = @_; + require IO::Handle; + my $fh = IO::Handle->new(); + if ($mode =~ /r/) { + # Because someone will try to read ungzipped files + # with this we peek and verify the signature. Yes, + # this means that we open the file twice (if it is + # gzipped). + # Plenty of race conditions exist in this code, but + # the alternative would be to capture the stderr of + # gzip and parse it, which would be a portability nightmare. + if (-e $filename && open($fh, $filename)) { + binmode $fh; + my $sig; + my $rdb = read($fh, $sig, 2); + if ($rdb == 2 && $sig eq "\x1F\x8B") { + my $ropen = sprintf $gzip_read_open, $filename; + if (open($fh, $ropen)) { + binmode $fh; + return $fh; + } else { + return undef; + } + } + seek($fh, 0, SEEK_SET) or + die "IO::Zlib: open('$filename', 'r'): seek: $!"; + return $fh; + } else { + return undef; + } + } elsif ($mode =~ /w/) { + my $level = ''; + $level = "-$1" if $mode =~ /([1-9])/; + # To maximize portability we would need to open + # two filehandles here, one for "| gzip $level" + # and another for "> $filename", and then when + # writing copy bytes from the first to the second. + # We are using IO::Handle objects for now, however, + # and they can only contain one stream at a time. + my $wopen = sprintf $gzip_write_open, $filename; + if (open($fh, $wopen)) { + $fh->autoflush(1); + binmode $fh; + return $fh; + } else { + return undef; + } + } else { + croak "IO::Zlib::gzopen_external: mode '$mode' is illegal"; + } + return undef; +} + +sub gzread_external { + # Use read() instead of syswrite() because people may + # mix reads and readlines, and we don't want to mess + # the stdio buffering. See also gzreadline_external() + # and gzwrite_external(). + my $nread = read($_[0], $_[1], @_ == 3 ? $_[2] : 4096); + defined $nread ? $nread : -1; +} + +sub gzwrite_external { + # Using syswrite() is okay (cf. gzread_external()) + # since the bytes leave this process and buffering + # is therefore not an issue. + my $nwrote = syswrite($_[0], $_[1]); + defined $nwrote ? $nwrote : -1; +} + +sub gzreadline_external { + # See the comment in gzread_external(). + $_[1] = readline($_[0]); + return defined $_[1] ? length($_[1]) : -1; +} + +sub gzeof_external { + return eof($_[0]); +} + +sub gzclose_external { + close($_[0]); + # I am not entirely certain why this is needed but it seems + # the above close() always fails (as if the stream would have + # been already closed - something to do with using external + # processes via pipes?) + return 0; +} + +1; |