diff options
author | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
commit | 661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch) | |
tree | 2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/lib/IO | |
parent | b645030efc22e13c2498a1522083634ab91b2de1 (diff) |
move tlperl.straw to tlperl
git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/IO')
46 files changed, 28010 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/IO/AtomicFile.pm b/Master/tlpkg/tlperl/lib/IO/AtomicFile.pm new file mode 100755 index 00000000000..89ad6f0e8f5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/AtomicFile.pm @@ -0,0 +1,196 @@ +package IO::AtomicFile; + +### DOCUMENTATION AT BOTTOM OF FILE + +# Be strict: +use strict; + +# External modules: +use IO::File; + + +#------------------------------ +# +# GLOBALS... +# +#------------------------------ +use vars qw($VERSION @ISA); + +# The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.110"; + +# Inheritance: +@ISA = qw(IO::File); + + +#------------------------------ +# new ARGS... +#------------------------------ +# Class method, constructor. +# Any arguments are sent to open(). +# +sub new { + my $class = shift; + my $self = $class->SUPER::new(); + ${*$self}{'io_atomicfile_suffix'} = ''; + $self->open(@_) if @_; + $self; +} + +#------------------------------ +# DESTROY +#------------------------------ +# Destructor. +# +sub DESTROY { + shift->close(1); ### like close, but raises fatal exception on failure +} + +#------------------------------ +# open PATH, MODE +#------------------------------ +# Class/instance method. +# +sub open { + my ($self, $path, $mode) = @_; + ref($self) or $self = $self->new; ### now we have an instance! + + ### Create tmp path, and remember this info: + my $temp = "${path}..TMP" . ${*$self}{'io_atomicfile_suffix'}; + ${*$self}{'io_atomicfile_temp'} = $temp; + ${*$self}{'io_atomicfile_path'} = $path; + + ### Open the file! Returns filehandle on success, for use as a constructor: + $self->SUPER::open($temp, $mode) ? $self : undef; +} + +#------------------------------ +# _closed [YESNO] +#------------------------------ +# Instance method, private. +# Are we already closed? Argument sets new value, returns previous one. +# +sub _closed { + my $self = shift; + my $oldval = ${*$self}{'io_atomicfile_closed'}; + ${*$self}{'io_atomicfile_closed'} = shift if @_; + $oldval; +} + +#------------------------------ +# close +#------------------------------ +# Instance method. +# Close the handle, and rename the temp file to its final name. +# +sub close { + my ($self, $die) = @_; + unless ($self->_closed(1)) { ### sentinel... + $self->SUPER::close(); + rename(${*$self}{'io_atomicfile_temp'}, + ${*$self}{'io_atomicfile_path'}) + or ($die ? die "close atomic file: $!\n" : return undef); + } + 1; +} + +#------------------------------ +# delete +#------------------------------ +# Instance method. +# Close the handle, and delete the temp file. +# +sub delete { + my $self = shift; + unless ($self->_closed(1)) { ### sentinel... + $self->SUPER::close(); + return unlink(${*$self}{'io_atomicfile_temp'}); + } + 1; +} + +#------------------------------ +# detach +#------------------------------ +# Instance method. +# Close the handle, but DO NOT delete the temp file. +# +sub detach { + my $self = shift; + $self->SUPER::close() unless ($self->_closed(1)); + 1; +} + +#------------------------------ +1; +__END__ + + +=head1 NAME + +IO::AtomicFile - write a file which is updated atomically + + +=head1 SYNOPSIS + + use IO::AtomicFile; + + ### Write a temp file, and have it install itself when closed: + my $FH = IO::AtomicFile->open("bar.dat", "w"); + print $FH "Hello!\n"; + $FH->close || die "couldn't install atomic file: $!"; + + ### Write a temp file, but delete it before it gets installed: + my $FH = IO::AtomicFile->open("bar.dat", "w"); + print $FH "Hello!\n"; + $FH->delete; + + ### Write a temp file, but neither install it nor delete it: + my $FH = IO::AtomicFile->open("bar.dat", "w"); + print $FH "Hello!\n"; + $FH->detach; + + +=head1 DESCRIPTION + +This module is intended for people who need to update files +reliably in the face of unexpected program termination. + +For example, you generally don't want to be halfway in the middle of +writing I</etc/passwd> and have your program terminate! Even +the act of writing a single scalar to a filehandle is I<not> atomic. + +But this module gives you true atomic updates, via rename(). +When you open a file I</foo/bar.dat> via this module, you are I<actually> +opening a temporary file I</foo/bar.dat..TMP>, and writing your +output there. The act of closing this file (either explicitly +via close(), or implicitly via the destruction of the object) +will cause rename() to be called... therefore, from the point +of view of the outside world, the file's contents are updated +in a single time quantum. + +To ensure that problems do not go undetected, the "close" method +done by the destructor will raise a fatal exception if the rename() +fails. The explicit close() just returns undef. + +You can also decide at any point to trash the file you've been +building. + + +=head1 AUTHOR + +=head2 Primary Maintainer + +David F. Skoll (F<dfs@roaringpenguin.com>). + +=head2 Original Author + +Eryq (F<eryq@zeegee.com>). +President, ZeeGee Software Inc (F<http://www.zeegee.com>). + + +=head1 REVISION + +$Revision: 1.2 $ + +=cut diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm new file mode 100755 index 00000000000..3e2e89f8e12 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm @@ -0,0 +1,162 @@ +package IO::Compress::Adapter::Bzip2 ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.024 qw(:Status); + +#use Compress::Bzip2 ; +use Compress::Raw::Bzip2 2.024 ; + +our ($VERSION); +$VERSION = '2.024'; + +sub mkCompObject +{ + my $BlockSize100K = shift ; + my $WorkFactor = shift ; + my $Verbosity = shift ; + + my ($def, $status) = new Compress::Raw::Bzip2(1, $BlockSize100K, + $WorkFactor, $Verbosity); + #my ($def, $status) = bzdeflateInit(); + #-BlockSize100K => $params->value('BlockSize100K'), + #-WorkFactor => $params->value('WorkFactor'); + + 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 ($out, $status) = $def->bzdeflate(defined ${$_[0]} ? ${$_[0]} : "") ; + my $status = $def->bzdeflate($_[0], $_[1]) ; + $self->{ErrorNo} = $status; + + if ($status != BZ_RUN_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + #${ $_[1] } .= $out if defined $out; + + return STATUS_OK; +} + +sub flush +{ + my $self = shift ; + + my $def = $self->{Def}; + + #my ($out, $status) = $def->bzflush($opt); + #my $status = $def->bzflush($_[0], $opt); + my $status = $def->bzflush($_[0]); + $self->{ErrorNo} = $status; + + if ($status != BZ_RUN_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + #${ $_[0] } .= $out if defined $out ; + return STATUS_OK; + +} + +sub close +{ + my $self = shift ; + + my $def = $self->{Def}; + + #my ($out, $status) = $def->bzclose(); + my $status = $def->bzclose($_[0]); + $self->{ErrorNo} = $status; + + if ($status != BZ_STREAM_END) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + #${ $_[0] } .= $out if defined $out ; + 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/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm new file mode 100755 index 00000000000..f23a9819c67 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm @@ -0,0 +1,165 @@ +package IO::Compress::Adapter::Deflate ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.024 qw(:Status); + +use Compress::Raw::Zlib 2.024 qw(Z_OK Z_FINISH MAX_WBITS) ; +our ($VERSION); + +$VERSION = '2.024'; + +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/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Identity.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Identity.pm new file mode 100755 index 00000000000..16f14d8e7f3 --- /dev/null +++ b/Master/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.024 qw(:Status); +our ($VERSION); + +$VERSION = '2.024'; + +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/Master/tlpkg/tlperl/lib/IO/Compress/Base.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Base.pm new file mode 100755 index 00000000000..5a20f60007b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/Base.pm @@ -0,0 +1,981 @@ + +package IO::Compress::Base ; + +require 5.004 ; + +use strict ; +use warnings; + +use IO::Compress::Base::Common 2.024 ; + +use IO::File ; +use Scalar::Util qw(blessed readonly); + +#use File::Glob; +#require Exporter ; +use Carp ; +use Symbol; +use bytes; + +our (@ISA, $VERSION); +@ISA = qw(Exporter IO::File); + +$VERSION = '2.024'; + +#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]); + 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, 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, 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 output +{ + my $self = shift ; + my $data = shift ; + my $last = shift ; + + return 1 + if length $data == 0 && ! $last ; + + if ( *$self->{FilterEnvelope} ) { + *_ = \$data; + &{ *$self->{FilterEnvelope} }(); + } + + 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' => [1, 1, Parse_boolean, 1], + ); +} + +sub checkParams +{ + my $self = shift ; + my $class = shift ; + + my $got = shift || IO::Compress::Base::Parameters::new(); + + $got->parse( + { + # Generic Parameters + 'AutoClose' => [1, 1, Parse_boolean, 0], + #'Encode' => [1, 1, Parse_any, undef], + 'Strict' => [0, 1, Parse_boolean, 1], + 'Append' => [1, 1, Parse_boolean, 0], + 'BinModeIn' => [1, 1, Parse_boolean, 0], + + 'FilterEnvelope' => [1, 1, Parse_any, undef], + + $self->getExtraParams(), + *$self->{OneShot} ? $self->getOneShotParams() + : (), + }, + @_) or $self->croakError("${class}: $got->{Error}") ; + + 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->value('Strict') ; + + my $outType = 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->value('Merge') ; + my $appendOutput = $got->value('Append') || $merge ; + *$obj->{Append} = $appendOutput; + *$obj->{FilterEnvelope} = $got->value('FilterEnvelope') ; + + 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" ) } + + + + if ($got->parsed('Encode')) { + my $want_encoding = $got->value('Encode'); + *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding); + } + + $obj->ckParams($got) + or $obj->croakError("${class}: " . $obj->error()); + + + $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, 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; + } + else + { + *$obj->{Compress} = $obj->createMerge($outValue, $outType) + or return undef; + } + + *$obj->{Closed} = 0 ; + *$obj->{AutoClose} = $got->value('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 = 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' && 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, @_); + + 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 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 $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 ; + } + + croak "Should not be here"; + return undef; +} + +sub addInterStream +{ + my $self = shift ; + my $input = shift ; + my $inputIsFilename = shift ; + + if (*$self->{Got}->value('MultiStream')) + { + $self->getFileInfo(*$self->{Got}, $input) + #if isaFilename($input) and $inputIsFilename ; + if isaFilename($input) ; + + # TODO -- newStream needs to allow gzip/zip header to be modified + return $self->newStream(); + } + elsif (*$self->{Got}->value('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] ; + } + + $] >= 5.008 and ( utf8::downgrade($$buffer, 1) + or croak "Wide character in " . *$self->{ClassName} . "::write:"); + + + 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 ; + + if (*$self->{Encoding}) { + $$buffer = *$self->{Encoding}->encode($$buffer); + } + + $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->output($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 flush +{ + 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->output($outBuffer) + or return 0; + + if ( defined *$self->{FH} ) { + defined *$self->{FH}->flush() + or return $self->saveErrorString(0, $!, $!); + } + + return 1; +} + +sub newStream +{ + my $self = shift ; + + $self->_writeTrailer() + or return 0 ; + + my $got = $self->checkParams('newStream', *$self->{Got}, @_) + or return 0 ; + + $self->ckParams($got) + or $self->croakError("newStream: $self->{Error}"); + + *$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(); + + 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->_writeTrailer() + or return 0 ; + + $self->_writeFinalTrailer() + or return 0 ; + + $self->output( "", 1 ) + or return 0; + + if (defined *$self->{FH}) { + + #if (! *$self->{Handle} || *$self->{AutoClose}) { + 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 { 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 if to 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<Compress::Zlib::FAQ|Compress::Zlib::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, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm new file mode 100755 index 00000000000..4f8b4dadc36 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm @@ -0,0 +1,956 @@ +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.024'; + +@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput + isaFileGlobString cleanFileGlobString oneTarget + setBinModeInput setBinModeOutput + ckInOutParams + createSelfTiedObject + getEncoding + + 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; + +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 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_custom Parse_string + Parse_multiple 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_custom => 0x12; + +#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 ; + + + +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->{Error}" ; + + return $p; +} + +#package IO::Compress::Base::Parameters; + +use strict; +use warnings; +use Carp; + +sub IO::Compress::Base::Parameters::new +{ + my $class = shift ; + + my $obj = { Error => '', + Got => {}, + } ; + + #return bless $obj, ref($class) || $class || __PACKAGE__ ; + return bless $obj, 'IO::Compress::Base::Parameters' ; +} + +sub IO::Compress::Base::Parameters::setError +{ + my $self = shift ; + my $error = shift ; + my $retval = @_ ? shift : undef ; + + $self->{Error} = $error ; + return $retval; +} + +#sub getError +#{ +# my $self = shift ; +# return $self->{Error} ; +#} + +sub IO::Compress::Base::Parameters::parse +{ + my $self = shift ; + + my $default = shift ; + + my $got = $self->{Got} ; + my $firstTime = keys %{ $got } == 0 ; + my $other; + + 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) { + if ($_[2 * $i] eq '__xxx__') { + $other = $_[2 * $i + 1] ; + } + else { + push @entered, $_[2 * $i] ; + push @entered, \$_[2 * $i + 1] ; + } + } + } + + + while (my ($key, $v) = each %$default) + { + croak "need 4 params [@$v]" + if @$v != 4 ; + + my ($first_only, $sticky, $type, $value) = @$v ; + my $x ; + $self->_checkType($key, \$value, $type, 0, \$x) + or return undef ; + + $key = lc $key; + + if ($firstTime || ! $sticky) { + $x = [] + if $type & Parse_multiple; + + $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ; + } + + $got->{$key}[OFF_PARSED] = 0 ; + } + + my %parsed = (); + + if ($other) + { + for my $key (keys %$default) + { + my $canonkey = lc $key; + if ($other->parsed($canonkey)) + { + my $value = $other->value($canonkey); +#print "SET '$canonkey' to $value [$$value]\n"; + ++ $parsed{$canonkey}; + $got->{$canonkey}[OFF_PARSED] = 1; + $got->{$canonkey}[OFF_DEFAULT] = $value; + $got->{$canonkey}[OFF_FIXED] = $value; + } + } + } + + 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} && ($firstTime || + ! $got->{$canonkey}[OFF_FIRST_ONLY] )) + { + my $type = $got->{$canonkey}[OFF_TYPE] ; + my $parsed = $parsed{$canonkey}; + ++ $parsed{$canonkey}; + + return $self->setError("Muliple instances of '$key' found") + if $parsed && $type & Parse_multiple == 0 ; + + my $s ; + $self->_checkType($key, $value, $type, 1, \$s) + or return undef ; + + $value = $$value ; + if ($type & Parse_multiple) { + $got->{$canonkey}[OFF_PARSED] = 1; + push @{ $got->{$canonkey}[OFF_FIXED] }, $s ; + } + else { + $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 $validate && readonly $$value ; + + if (ref $$value) + { + return $self->setError("Parameter '$key' not a scalar reference") + if $validate && ref $$value ne 'SCALAR' ; + + $$output = $$value ; + } + else + { + return $self->setError("Parameter '$key' not a scalar") + if $validate && ref $value ne 'SCALAR' ; + + $$output = $value ; + } + + return 1; + } + +# if ($type & Parse_store_ref) +# { +# #$value = $$value +# # if ref ${ $value } ; +# +# $$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 $validate && ! defined $value ; + return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") + if $validate && $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 $validate && ! defined $value ; + return $self->setError("Parameter '$key' must be a signed int, got '$value'") + if $validate && $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 $validate && defined $value && $value !~ /^\d*$/; + $$output = defined $value ? $value != 0 : 0 ; + return 1; + } + elsif ($type & Parse_string) + { + $$output = defined $value ? $value : "" ; + return 1; + } + + $$output = $value ; + return 1; +} + + + +sub IO::Compress::Base::Parameters::parsed +{ + my $self = shift ; + my $name = shift ; + + return $self->{Got}{lc $name}[OFF_PARSED] ; +} + +sub IO::Compress::Base::Parameters::value +{ + my $self = shift ; + my $name = shift ; + + if (@_) + { + $self->{Got}{lc $name}[OFF_PARSED] = 1; + $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ; + $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ; + } + + return $self->{Got}{lc $name}[OFF_FIXED] ; +} + +sub IO::Compress::Base::Parameters::valueOrDefault +{ + my $self = shift ; + my $name = shift ; + my $default = shift ; + + my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ; + + return $value if defined $value ; + return $default ; +} + +sub IO::Compress::Base::Parameters::wantValue +{ + my $self = shift ; + my $name = shift ; + + return defined $self->{Got}{lc $name}[OFF_DEFAULT] ; + +} + +sub IO::Compress::Base::Parameters::clone +{ + my $self = shift ; + my $obj = { }; + my %got ; + + while (my ($k, $v) = each %{ $self->{Got} }) { + $got{$k} = [ @$v ]; + } + + $obj->{Error} = $self->{Error}; + $obj->{Got} = \%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 +{ + my $class = shift ; + + my $high = 0 ; + my $low = 0 ; + + if (@_ == 2) { + $high = shift ; + $low = shift ; + } + elsif (@_ == 1) { + $low = shift ; + } + + bless [$low, $high], $class; +} + +sub newUnpack_V64 +{ + my $string = shift; + + my ($low, $hi) = unpack "V V", $string ; + bless [ $low, $hi ], "U64"; +} + +sub newUnpack_V32 +{ + my $string = shift; + + my $low = unpack "V", $string ; + bless [ $low, 0 ], "U64"; +} + +sub reset +{ + my $self = shift; + $self->[HIGH] = $self->[LOW] = 0; +} + +sub clone +{ + my $self = shift; + bless [ @$self ], ref $self ; +} + +sub getHigh +{ + my $self = shift; + return $self->[HIGH]; +} + +sub getLow +{ + my $self = shift; + return $self->[LOW]; +} + +sub get32bit +{ + my $self = shift; + return $self->[LOW]; +} + +sub get64bit +{ + my $self = shift; + # Not using << here because the result will still be + # a 32-bit value on systems where int size is 32-bits + return $self->[HIGH] * HI_1 + $self->[LOW]; +} + +sub add +{ + my $self = shift; + my $value = shift; + + if (ref $value eq 'U64') { + $self->[HIGH] += $value->[HIGH] ; + $value = $value->[LOW]; + } + + my $available = MAX32 - $self->[LOW] ; + + if ($value > $available) { + ++ $self->[HIGH] ; + $self->[LOW] = $value - $available - 1; + } + else { + $self->[LOW] += $value ; + } + +} + +sub equal +{ + my $self = shift; + my $other = shift; + + return $self->[LOW] == $other->[LOW] && + $self->[HIGH] == $other->[HIGH] ; +} + +sub is64bit +{ + my $self = shift; + return $self->[HIGH] > 0 ; +} + +sub getPacked_V64 +{ + my $self = shift; + + return pack "V V", @$self ; +} + +sub getPacked_V32 +{ + my $self = shift; + + return pack "V", $self->[LOW] ; +} + +sub pack_V64 +{ + my $low = shift; + + return pack "V V", $low, 0; +} + + +package IO::Compress::Base::Common; + +1; diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm new file mode 100755 index 00000000000..2a85ef55b19 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm @@ -0,0 +1,758 @@ +package IO::Compress::Bzip2 ; + +use strict ; +use warnings; +use bytes; +require Exporter ; + +use IO::Compress::Base 2.024 ; + +use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject); +use IO::Compress::Adapter::Bzip2 2.024 ; + + + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error); + +$VERSION = '2.024'; +$Bzip2Error = ''; + +@ISA = qw(Exporter IO::Compress::Base); +@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 = createSelfTiedObject($class, \$Bzip2Error); + return $obj->_create(undef, @_); +} + +sub bzip2 +{ + my $obj = createSelfTiedObject(undef, \$Bzip2Error); + $obj->_def(@_); +} + + +sub mkHeader +{ + my $self = shift ; + return ''; + +} + +sub getExtraParams +{ + my $self = shift ; + + use IO::Compress::Base::Common 2.024 qw(:Parse); + + return ( + 'BlockSize100K' => [0, 1, Parse_unsigned, 1], + 'WorkFactor' => [0, 1, Parse_unsigned, 0], + 'Verbosity' => [0, 1, 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->value('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->value('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->value('BlockSize100K'); + my $WorkFactor = $got->value('WorkFactor'); + my $Verbosity = $got->value('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 => $output [,OPTS] + or die "bzip2 failed: $Bzip2Error\n"; + +The functional interface needs Perl5.005 or better. + +=head2 bzip2 $input => $output [, OPTS] + +C<bzip2> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +=head3 The C<$output> parameter + +The 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>. + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the input files/buffers will be stored +in C<$output> 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 >> + +TODO + +=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 if 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 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 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::Bzip2::FAQ|IO::Compress::Bzip2::FAQ/"Apache::GZip Revisited"> + + + +=head2 Working with Net::FTP + +See L<IO::Compress::Bzip2::FAQ|IO::Compress::Bzip2::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::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::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 F<http://www.bzip.org>. + +See the module L<Compress::Bzip2|Compress::Bzip2> + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2008 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/Master/tlpkg/tlperl/lib/IO/Compress/Deflate.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Deflate.pm new file mode 100755 index 00000000000..0f46e59d3a4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/Deflate.pm @@ -0,0 +1,930 @@ +package IO::Compress::Deflate ; + +use strict ; +use warnings; +use bytes; + +require Exporter ; + +use IO::Compress::RawDeflate 2.024 ; + +use Compress::Raw::Zlib 2.024 ; +use IO::Compress::Zlib::Constants 2.024 ; +use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject); + + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $DeflateError); + +$VERSION = '2.024'; +$DeflateError = ''; + +@ISA = qw(Exporter IO::Compress::RawDeflate); +@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 = createSelfTiedObject($class, \$DeflateError); + return $obj->_create(undef, @_); +} + +sub deflate +{ + my $obj = 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->value('Level'); + my $strategy = $param->value('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->value('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 => $output [,OPTS] + or die "deflate failed: $DeflateError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 deflate $input => $output [, OPTS] + +C<deflate> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +=head3 The C<$output> parameter + +The 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>. + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the input files/buffers will be stored +in C<$output> 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 appened 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 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 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<Compress::Zlib::FAQ|Compress::Zlib::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 +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Compress/Gzip.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Gzip.pm new file mode 100755 index 00000000000..1978b91b283 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/Gzip.pm @@ -0,0 +1,1242 @@ + +package IO::Compress::Gzip ; + +require 5.004 ; + +use strict ; +use warnings; +use bytes; + + +use IO::Compress::RawDeflate 2.024 ; + +use Compress::Raw::Zlib 2.024 ; +use IO::Compress::Base::Common 2.024 qw(:Status :Parse createSelfTiedObject); +use IO::Compress::Gzip::Constants 2.024 ; +use IO::Compress::Zlib::Extra 2.024 ; + +BEGIN +{ + if (defined &utf8::downgrade ) + { *noUTF8 = \&utf8::downgrade } + else + { *noUTF8 = sub {} } +} + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError); + +$VERSION = '2.024'; +$GzipError = '' ; + +@ISA = qw(Exporter IO::Compress::RawDeflate); +@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 = createSelfTiedObject($class, \$GzipError); + + $obj->_create(undef, @_); +} + + +sub gzip +{ + my $obj = 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' => [0, 1, Parse_boolean, 0], + 'Comment' => [0, 1, Parse_any, undef], + 'Name' => [0, 1, Parse_any, undef], + 'Time' => [0, 1, Parse_any, undef], + 'TextFlag' => [0, 1, Parse_boolean, 0], + 'HeaderCRC' => [0, 1, Parse_boolean, 0], + 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code], + 'ExtraField'=> [0, 1, Parse_any, undef], + 'ExtraFlags'=> [0, 1, Parse_any, undef], + + ); +} + + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # gzip always needs crc32 + $got->value('CRC32' => 1); + + return 1 + if $got->value('Merge') ; + + my $strict = $got->value('Strict') ; + + + { + if (! $got->parsed('Time') ) { + # Modification time defaults to now. + $got->value('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->value('Name')) { + my $name = $got->value('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->value('Comment')) { + my $comment = $got->value('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->value('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->value('Method' => Z_DEFLATED) ; + + if ( ! $got->parsed('ExtraFlags')) { + $got->value('ExtraFlags' => 2) + if $got->value('Level') == Z_BEST_SPEED ; + $got->value('ExtraFlags' => 4) + if $got->value('Level') == Z_BEST_COMPRESSION ; + } + + my $data = $got->value('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->value('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 ; + + my $defaultTime = (stat($filename))[9] ; + + $params->value('Name' => $filename) + if ! $params->parsed('Name') ; + + $params->value('Time' => $defaultTime) + if ! $params->parsed('Time') ; +} + + +sub mkHeader +{ + my $self = shift ; + my $param = shift ; + + # stort-circuit if a minimal header is requested. + return GZIP_MINIMUM_HEADER if $param->value('Minimal') ; + + # METHOD + my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ; + + # FLAGS + my $flags = GZIP_FLG_DEFAULT ; + $flags |= GZIP_FLG_FTEXT if $param->value('TextFlag') ; + $flags |= GZIP_FLG_FHCRC if $param->value('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->value('ExtraField') ; + $out .= pack("v", length $extra) . $extra ; + } + + # NAME + if ($flags & GZIP_FLG_FNAME) { + my $name .= $param->value('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->value('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", crc32($out) & 0x00FF ) if $param->value('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 => $output [,OPTS] + or die "gzip failed: $GzipError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 gzip $input => $output [, OPTS] + +C<gzip> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +In addition, if C<$input> 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> parameter + +The 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>. + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the input files/buffers will be stored +in C<$output> 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 appened 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 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 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 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<Compress::Zlib::FAQ|Compress::Zlib::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 +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Compress/Gzip/Constants.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Gzip/Constants.pm new file mode 100755 index 00000000000..8504330d188 --- /dev/null +++ b/Master/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.024'; + +@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/Master/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm b/Master/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm new file mode 100755 index 00000000000..b97b51c0509 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm @@ -0,0 +1,1017 @@ +package IO::Compress::RawDeflate ; + +# create RFC1951 +# +use strict ; +use warnings; +use bytes; + + +use IO::Compress::Base 2.024 ; +use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject); +use IO::Compress::Adapter::Deflate 2.024 ; + +require Exporter ; + + +our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError); + +$VERSION = '2.024'; +$RawDeflateError = ''; + +@ISA = qw(Exporter IO::Compress::Base); +@EXPORT_OK = qw( $RawDeflateError rawdeflate ) ; + +%EXPORT_TAGS = ( flush => [qw{ + Z_NO_FLUSH + Z_PARTIAL_FLUSH + Z_SYNC_FLUSH + Z_FULL_FLUSH + Z_FINISH + Z_BLOCK + }], + level => [qw{ + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + }], + strategy => [qw{ + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + }], + + ); + +{ + 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 = createSelfTiedObject($class, \$RawDeflateError); + + return $obj->_create(undef, @_); +} + +sub rawdeflate +{ + my $obj = 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->value('CRC32'), + $got->value('Adler32'), + $got->value('Level'), + $got->value('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 $self->getZlibParams(); +} + +sub getZlibParams +{ + my $self = shift ; + + use IO::Compress::Base::Common 2.024 qw(:Parse); + use Compress::Raw::Zlib 2.024 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); + + + return ( + + # zlib behaviour + #'Method' => [0, 1, Parse_unsigned, Z_DEFLATED], + 'Level' => [0, 1, Parse_signed, Z_DEFAULT_COMPRESSION], + 'Strategy' => [0, 1, Parse_signed, Z_DEFAULT_STRATEGY], + + 'CRC32' => [0, 1, Parse_boolean, 0], + 'ADLER32' => [0, 1, Parse_boolean, 0], + 'Merge' => [1, 1, Parse_boolean, 0], + ); + + +} + +sub getInverseClass +{ + return ('IO::Uncompress::RawInflate', + \$IO::Uncompress::RawInflate::RawInflateError); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $file = shift ; + +} + +use IO::Seekable 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 => $output [,OPTS] + or die "rawdeflate failed: $RawDeflateError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 rawdeflate $input => $output [, OPTS] + +C<rawdeflate> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +=head3 The C<$output> parameter + +The 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>. + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the input files/buffers will be stored +in C<$output> 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 appened 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 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 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<Compress::Zlib::FAQ|Compress::Zlib::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 +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Compress/Zip.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Zip.pm new file mode 100755 index 00000000000..5e37d78f97d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/Zip.pm @@ -0,0 +1,1612 @@ +package IO::Compress::Zip ; + +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject); +use IO::Compress::RawDeflate 2.024 ; +use IO::Compress::Adapter::Deflate 2.024 ; +use IO::Compress::Adapter::Identity 2.024 ; +use IO::Compress::Zlib::Extra 2.024 ; +use IO::Compress::Zip::Constants 2.024 ; + + +use Compress::Raw::Zlib 2.024 qw(crc32) ; +BEGIN +{ + eval { require IO::Compress::Adapter::Bzip2 ; + import IO::Compress::Adapter::Bzip2 2.024 ; + require IO::Compress::Bzip2 ; + import IO::Compress::Bzip2 2.024 ; + } ; +# eval { require IO::Compress::Adapter::Lzma ; +# import IO::Compress::Adapter::Lzma 2.020 ; +# require IO::Compress::Lzma ; +# import IO::Compress::Lzma 2.024 ; +# } ; +} + + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $ZipError); + +$VERSION = '2.024'; +$ZipError = ''; + +@ISA = qw(Exporter IO::Compress::RawDeflate); +@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 = createSelfTiedObject($class, \$ZipError); + $obj->_create(undef, @_); +} + +sub zip +{ + my $obj = createSelfTiedObject(undef, \$ZipError); + return $obj->_def(@_); +} + +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->value('Level'), + $got->value('Strategy') + ); + *$self->{ZipData}{CRC32} = crc32(undef); + } + elsif (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) { + ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject( + $got->value('CRC32'), + $got->value('Adler32'), + $got->value('Level'), + $got->value('Strategy') + ); + } + elsif (*$self->{ZipData}{Method} == ZIP_CM_BZIP2) { + ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject( + $got->value('BlockSize100K'), + $got->value('WorkFactor'), + $got->value('Verbosity') + ); + *$self->{ZipData}{CRC32} = crc32(undef); + } +# elsif (*$self->{ZipData}{Method} == ZIP_CM_LZMA) { +# ($obj, $errstr, $errno) = IO::Compress::Adapter::Lzma::mkCompObject(); +# *$self->{ZipData}{CRC32} = 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} = crc32(${$_[0]}, *$self->{ZipData}{CRC32}); + + } +} + +sub mkHeader +{ + my $self = shift; + my $param = shift ; + + + *$self->{ZipData}{LocalHdrOffset} = U64::clone(*$self->{ZipData}{Offset}); + + my $filename = ''; + $filename = $param->value('Name') || ''; + + my $comment = ''; + $comment = $param->value('Comment') || ''; + + my $hdr = ''; + + my $time = _unixToDosTime($param->value('Time')); + + my $extra = ''; + my $ctlExtra = ''; + my $empty = 0; + my $osCode = $param->value('OS_Code') ; + my $extFileAttr = 0 ; + + # This code assumes Unix. + $extFileAttr = 0666 << 16 + if $osCode == ZIP_OS_CODE_UNIX ; + + if (*$self->{ZipData}{Zip64}) { + $empty = 0xFFFFFFFF; + + my $x = ''; + $x .= pack "V V", 0, 0 ; # uncompressedLength + $x .= pack "V V", 0, 0 ; # compressedLength + $extra .= IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x); + } + + if (! $param->value('Minimal')) { + if (defined $param->value('exTime')) + { + $extra .= mkExtendedTime($param->value('MTime'), + $param->value('ATime'), + $param->value('CTime')); + + $ctlExtra .= mkExtendedTime($param->value('MTime')); + } + + if ( $param->value('UID') && $osCode == ZIP_OS_CODE_UNIX) + { + $extra .= mkUnix2Extra( $param->value('UID'), $param->value('GID')); + $ctlExtra .= mkUnix2Extra(); + } + + $extFileAttr = $param->value('ExtAttr') + if defined $param->value('ExtAttr') ; + + $extra .= $param->value('ExtraFieldLocal') + if defined $param->value('ExtraFieldLocal'); + + $ctlExtra .= $param->value('ExtraFieldCentral') + if defined $param->value('ExtraFieldCentral'); + } + + my $gpFlag = 0 ; + $gpFlag |= ZIP_GP_FLAG_STREAMING_MASK + if *$self->{ZipData}{Stream} ; + + my $method = *$self->{ZipData}{Method} ; + + my $version = $ZIP_CM_MIN_VERSIONS{$method}; + $version = ZIP64_MIN_VERSION + if ZIP64_MIN_VERSION > $version && *$self->{ZipData}{Zip64}; + my $madeBy = ($param->value('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->value('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', 0xFFFFFFFF ; + } + else { + $ctl .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V32() ; + } + + $ctl .= $filename ; + $ctl .= $ctlExtra ; + $ctl .= $comment ; + + *$self->{ZipData}{Offset}->add(length $hdr) ; + + *$self->{ZipData}{CentralHeader} = $ctl; + + 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 = *$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 $x = ''; + + # uncompressed length + if (*$self->{UnCompSize}->is64bit() ) { + $x .= *$self->{UnCompSize}->getPacked_V64() ; + } else { + substr($ctl, 24, 4) = *$self->{UnCompSize}->getPacked_V32() ; + } + + # compressed length + if (*$self->{CompSize}->is64bit() ) { + $x .= *$self->{CompSize}->getPacked_V64() ; + } else { + substr($ctl, 20, 4) = *$self->{CompSize}->getPacked_V32() ; + } + + # Local Header offset + $x .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V64() + if *$self->{ZipData}{LocalHdrOffset}->is64bit() ; + + # disk no - always zero, so don't need it + #$x .= pack "V", 0 ; + + if (length $x) { + my $xtra = IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x); + $ctl .= $xtra ; + substr($ctl, *$self->{ZipData}{ExtraOffset}, 2) = + pack 'v', *$self->{ZipData}{ExtraSize} + length $xtra; + + *$self->{ZipData}{AnyZip64} = 1; + } + + *$self->{ZipData}{Offset}->add(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} }; + 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}->add(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 = 0xFFFFFFFF ; + $cd_len = 0xFFFFFFFF if $cd_len >= 0xFFFFFFFF ; + $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->value('CRC32' => 1); + + if (! $got->parsed('Time') ) { + # Modification time defaults to now. + $got->value('Time' => time) ; + } + + if ($got->parsed('exTime') ) { + my $timeRef = $got->value('exTime'); + if ( defined $timeRef) { + return $self->saveErrorString(undef, "exTime not a 3-element array ref") + if ref $timeRef ne 'ARRAY' || @$timeRef != 3; + } + + $got->value("MTime", $timeRef->[1]); + $got->value("ATime", $timeRef->[0]); + $got->value("CTime", $timeRef->[2]); + } + + # Unix2 Extended Attribute + if ($got->parsed('exUnix2') ) { + my $timeRef = $got->value('exUnix2'); + if ( defined $timeRef) { + return $self->saveErrorString(undef, "exUnix2 not a 2-element array ref") + if ref $timeRef ne 'ARRAY' || @$timeRef != 2; + } + + $got->value("UID", $timeRef->[0]); + $got->value("GID", $timeRef->[1]); + } + + *$self->{ZipData}{AnyZip64} = 1 + if $got->value('Zip64'); + *$self->{ZipData}{Zip64} = $got->value('Zip64'); + *$self->{ZipData}{Stream} = $got->value('Stream'); + + my $method = $got->value('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->value('ZipComment') ; + + for my $name (qw( ExtraFieldLocal ExtraFieldCentral )) + { + my $data = $got->value($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->value($name, $data) ; + } + } + + return undef + if defined $IO::Compress::Bzip2::VERSION + and ! IO::Compress::Bzip2::ckParams($self, $got); + + return 1 ; +} + +#sub newHeader +#{ +# my $self = shift ; +# +# return $self->mkHeader(*$self->{Got}); +#} + +sub getExtraParams +{ + my $self = shift ; + + use IO::Compress::Base::Common 2.024 qw(:Parse); + use Compress::Raw::Zlib 2.024 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); + + my @Bzip2 = (); + + @Bzip2 = IO::Compress::Bzip2::getExtraParams($self) + if defined $IO::Compress::Bzip2::VERSION; + + return ( + # zlib behaviour + $self->getZlibParams(), + + 'Stream' => [1, 1, Parse_boolean, 1], + #'Store' => [0, 1, Parse_boolean, 0], + 'Method' => [0, 1, Parse_unsigned, ZIP_CM_DEFLATE], + +# # Zip header fields + 'Minimal' => [0, 1, Parse_boolean, 0], + 'Zip64' => [0, 1, Parse_boolean, 0], + 'Comment' => [0, 1, Parse_any, ''], + 'ZipComment'=> [0, 1, Parse_any, ''], + 'Name' => [0, 1, Parse_any, ''], + 'Time' => [0, 1, Parse_any, undef], + 'exTime' => [0, 1, Parse_any, undef], + 'exUnix2' => [0, 1, Parse_any, undef], + 'ExtAttr' => [0, 1, Parse_any, 0], + 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code], + + 'TextFlag' => [0, 1, Parse_boolean, 0], + 'ExtraFieldLocal' => [0, 1, Parse_any, undef], + 'ExtraFieldCentral'=> [0, 1, Parse_any, undef], + + @Bzip2, + ); +} + +sub getInverseClass +{ + return ('IO::Uncompress::Unzip', + \$IO::Uncompress::Unzip::UnzipError); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $filename = shift ; + + my ($mode, $uid, $gid, $atime, $mtime, $ctime) + = (stat($filename))[2, 4,5, 8,9,10] ; + + $params->value('Name' => $filename) + if ! $params->parsed('Name') ; + + $params->value('Time' => $mtime) + if ! $params->parsed('Time') ; + + if ( ! $params->parsed('exTime')) + { + $params->value('MTime' => $mtime) ; + $params->value('ATime' => $atime) ; + $params->value('CTime' => undef) ; # No Creation time + $params->value("exTime", [$mtime, $atime, undef]); + } + + # NOTE - Unix specific code alert + $params->value('ExtAttr' => $mode << 16) + if ! $params->parsed('ExtAttr'); + + $params->value('UID' => $uid) ; + $params->value('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); +} + + +# 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 and Bzip2. + +Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> 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 => $output [,OPTS] + or die "zip failed: $ZipError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 zip $input => $output [, OPTS] + +C<zip> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +In addition, if C<$input> is a simple filename, the default values for +the C<Name>, C<Time>, C<ExtAttr> 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<ExtAttr> and C<exTime> options or by setting the +C<Minimal> parameter. + +=head3 The C<$output> parameter + +The 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>. + +=item An Array Reference + +If C<$output> is an array reference, the compressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple files/buffers and C<$output> is a single +file/buffer the input files/buffers will each be stored +in C<$output> 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 appened 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 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::Zip qw(zip $ZipError) ; + + zip '</my/home/*.txt>' => '<*.zip>' + or die "zip failed: $ZipError\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::Zip qw(zip $ZipError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.zip" ; + zip $input => $output + or die "Error compressing '$input': $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, no zip filename field will be created. + +=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. + +=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 + + 0666 << 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 and group ID +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. This will be populated +with C<$uid> and C<$gid>. In addition an empty Unix2 extra field will also +be created in the central zip header + +If the C<Minimal> option is set to true, this option will be ignored. + +By default no Unix2 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 three compression +methods are supported, namely Store (no compression at all), Deflate and +Bzip2. + +The symbols, ZIP_CM_STORE, ZIP_CM_DEFLATE and ZIP_CM_BZIP2 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. + +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 should only be used if you want +to store files larger than 4 Gig. + +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. + +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 + +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<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 -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 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 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<Compress::Zlib::FAQ|Compress::Zlib::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 +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm new file mode 100755 index 00000000000..c8cb95342a2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm @@ -0,0 +1,105 @@ +package IO::Compress::Zip::Constants; + +use strict ; +use warnings; + +require Exporter; + +our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS); + +$VERSION = '2.024'; + +@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_JAVA_EXE + + ZIP_OS_CODE_UNIX + ZIP_OS_CODE_DEFAULT + + ZIP_IFA_TEXT_MASK + + %ZIP_CM_MIN_VERSIONS + ZIP64_MIN_VERSION + + ); + +# 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 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_JAVA_EXE => pack "v", 0xCAFE; + +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, + ); + + +1; + +__END__ + diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Constants.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Constants.pm new file mode 100755 index 00000000000..10fcf345f63 --- /dev/null +++ b/Master/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.024'; + +@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/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm new file mode 100755 index 00000000000..6812bb409dc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm @@ -0,0 +1,198 @@ +package IO::Compress::Zlib::Extra; + +require 5.004 ; + +use strict ; +use warnings; +use bytes; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); + +$VERSION = '2.024'; + +use IO::Compress::Gzip::Constants 2.024 ; + +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 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 $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 <= length(@$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/Master/tlpkg/tlperl/lib/IO/Dir.pm b/Master/tlpkg/tlperl/lib/IO/Dir.pm new file mode 100755 index 00000000000..cce392c2ce3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Dir.pm @@ -0,0 +1,248 @@ +# 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.006; + +use strict; +use Carp; +use Symbol; +use Exporter; +use IO::File; +our(@ISA, $VERSION, @EXPORT_OK); +use Tie::Hash; +use File::stat; +use File::Spec; + +@ISA = qw(Tie::Hash Exporter); +$VERSION = "1.07"; +$VERSION = eval $VERSION; +@EXPORT_OK = qw(DIR_UNLINK); + +sub DIR_UNLINK () { 1 } + +sub new { + @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [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 <perl5-porters@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/Master/tlpkg/tlperl/lib/IO/File.pm b/Master/tlpkg/tlperl/lib/IO/File.pm new file mode 100755 index 00000000000..d33d090d0b2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/File.pm @@ -0,0 +1,204 @@ +# + +package IO::File; + +=head1 NAME + +IO::File - supply object methods for filehandles + +=head1 SYNOPSIS + + use IO::File; + + $fh = new IO::File; + if ($fh->open("< file")) { + print <$fh>; + $fh->close; + } + + $fh = new IO::File "> file"; + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = new IO::File "file", "r"; + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + + $fh = new IO::File "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.006_001; +use strict; +our($VERSION, @EXPORT, @EXPORT_OK, @ISA); +use Carp; +use Symbol; +use SelectSaver; +use IO::Seekable; +use File::Spec; + +require Exporter; + +@ISA = qw(IO::Handle IO::Seekable Exporter); + +$VERSION = "1.14"; + +@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: new $class [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/Master/tlpkg/tlperl/lib/IO/Handle.pm b/Master/tlpkg/tlperl/lib/IO/Handle.pm new file mode 100755 index 00000000000..2f1f1b423bc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Handle.pm @@ -0,0 +1,635 @@ +package IO::Handle; + +=head1 NAME + +IO::Handle - supply object methods for I/O handles + +=head1 SYNOPSIS + + use IO::Handle; + + $io = new IO::Handle; + if ($io->fdopen(fileno(STDIN),"r")) { + print $io->getline; + $io->close; + } + + $io = new IO::Handle; + 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 like C<write> found in C, that is it is the +opposite of read. The wrapper for the perl C<write> function is +called C<format_write>. + +=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.006_001; +use strict; +our($VERSION, @EXPORT_OK, @ISA); +use Carp; +use Symbol; +use SelectSaver; +use IO (); # Load the XS module + +require Exporter; +@ISA = qw(Exporter); + +$VERSION = "1.28"; +$VERSION = eval $VERSION; + +@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"; + @_ == 1 or croak "usage: new $class"; + my $io = gensym; + bless $io, $class; +} + +sub new_from_fd { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 3 or croak "usage: new_from_fd $class 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 @_; +} + +sub getline { + @_ == 1 or croak 'usage: $io->getline()'; + my $this = shift; + return scalar <$this>; +} + +*gets = \&getline; # deprecated + +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>; +} + +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 = new SelectSaver 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 = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $%; + $% = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_per_page { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $=; + $= = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_left { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $-; + $- = $_[1] if @_ > 1; + $prev; +} + +sub format_name { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $~; + $~ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_top_name { + my $old; + $old = new SelectSaver 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 compatability with older releases of IO that used +# a sub called constant to detemine if a constant existed -- GMB +# +# The SEEK_* and _IO?BF constants were the only constants at that time +# any new code should just chech 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 = new SelectSaver qualify($io, caller) if ref($io); + local $| = 1; + if(ref($io)) { + print $io @_; + } + else { + print @_; + } +} + +1; diff --git a/Master/tlpkg/tlperl/lib/IO/InnerFile.pm b/Master/tlpkg/tlperl/lib/IO/InnerFile.pm new file mode 100755 index 00000000000..2023e42b8aa --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/InnerFile.pm @@ -0,0 +1,282 @@ +package IO::InnerFile; + +=head1 NAME + +IO::InnerFile - define a file inside another file + + +=head1 SYNOPSIS + + + ### Read a subset of a file: + $inner = IO::InnerFile->new($fh, $start, $length); + while (<$inner>) { + ... + } + + +=head1 DESCRIPTION + +If you have a filehandle that can seek() and tell(), then you +can open an IO::InnerFile on a range of the underlying file. + + +=head1 PUBLIC INTERFACE + +=over + +=cut + +use Symbol; + +# The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.110"; + +#------------------------------ + +=item new FILEHANDLE, [START, [LENGTH]] + +I<Class method, constructor.> +Create a new inner-file opened on the given FILEHANDLE, +from bytes START to START+LENGTH. Both START and LENGTH +default to 0; negative values are silently coerced to zero. + +Note that FILEHANDLE must be able to seek() and tell(), in addition +to whatever other methods you may desire for reading it. + +=cut + +sub new { + my ($class, $fh, $start, $lg) = @_; + $start = 0 if (!$start or ($start < 0)); + $lg = 0 if (!$lg or ($lg < 0)); + + ### Create the underlying "object": + my $a = { + FH => $fh, + CRPOS => 0, + START => $start, + LG => $lg, + }; + + ### Create a new filehandle tied to this object: + $fh = gensym; + tie(*$fh, $class, $a); + return bless($fh, $class); +} + +sub TIEHANDLE { + my ($class, $data) = @_; + return bless($data, $class); +} + +sub DESTROY { + my ($self) = @_; + $self->close() if (ref($self) eq 'SCALAR'); +} + +#------------------------------ + +=item set_length LENGTH + +=item get_length + +=item add_length NBYTES + +I<Instance methods.> +Get/set the virtual length of the inner file. + +=cut + +sub set_length { tied(${$_[0]})->{LG} = $_[1]; } +sub get_length { tied(${$_[0]})->{LG}; } +sub add_length { tied(${$_[0]})->{LG} += $_[1]; } + +#------------------------------ + +=item set_start START + +=item get_start + +=item add_start NBYTES + +I<Instance methods.> +Get/set the virtual start position of the inner file. + +=cut + +sub set_start { tied(${$_[0]})->{START} = $_[1]; } +sub get_start { tied(${$_[0]})->{START}; } +sub set_end { tied(${$_[0]})->{LG} = $_[1] - tied(${$_[0]})->{START}; } +sub get_end { tied(${$_[0]})->{LG} + tied(${$_[0]})->{START}; } + + +#------------------------------ + +=item binmode + +=item close + +=item flush + +=item getc + +=item getline + +=item print LIST + +=item printf LIST + +=item read BUF, NBYTES + +=item readline + +=item seek OFFFSET, WHENCE + +=item tell + +=item write ARGS... + +I<Instance methods.> +Standard filehandle methods. + +=cut + +sub write { shift->WRITE(@_) } +sub print { shift->PRINT(@_) } +sub printf { shift->PRINTF(@_) } +sub flush { "0 but true"; } +sub binmode { 1; } +sub getc { return GETC(tied(${$_[0]}) ); } +sub read { return READ( tied(${$_[0]}), @_[1,2,3] ); } +sub readline { return READLINE( tied(${$_[0]}) ); } +sub getline { return READLINE( tied(${$_[0]}) ); } +sub close { return CLOSE(tied(${$_[0]}) ); } + +sub seek { + my ($self, $ofs, $whence) = @_; + $self = tied( $$self ); + + $self->{CRPOS} = $ofs if ($whence == 0); + $self->{CRPOS}+= $ofs if ($whence == 1); + $self->{CRPOS} = $self->{LG} + $ofs if ($whence == 2); + + $self->{CRPOS} = 0 if ($self->{CRPOS} < 0); + $self->{CRPOS} = $self->{LG} if ($self->{CRPOS} > $self->{LG}); + return 1; +} + +sub tell { + return tied(${$_[0]})->{CRPOS}; +} + +sub WRITE { + die "inner files can only open for reading\n"; +} + +sub PRINT { + die "inner files can only open for reading\n"; +} + +sub PRINTF { + die "inner files can only open for reading\n"; +} + +sub GETC { + my ($self) = @_; + return 0 if ($self->{CRPOS} >= $self->{LG}); + + my $data; + + ### Save and seek... + my $old_pos = $self->{FH}->tell; + $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); + + ### ...read... + my $lg = $self->{FH}->read($data, 1); + $self->{CRPOS} += $lg; + + ### ...and restore: + $self->{FH}->seek($old_pos, 0); + + $self->{LG} = $self->{CRPOS} unless ($lg); + return ($lg ? $data : undef); +} + +sub READ { + my ($self, $undefined, $lg, $ofs) = @_; + $undefined = undef; + + return 0 if ($self->{CRPOS} >= $self->{LG}); + $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG}); + return 0 unless ($lg); + + ### Save and seek... + my $old_pos = $self->{FH}->tell; + $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); + + ### ...read... + $lg = $self->{FH}->read($_[1], $lg, $_[3] ); + $self->{CRPOS} += $lg; + + ### ...and restore: + $self->{FH}->seek($old_pos, 0); + + $self->{LG} = $self->{CRPOS} unless ($lg); + return $lg; +} + +sub READLINE { + my ($self) = @_; + return undef if ($self->{CRPOS} >= $self->{LG}); + + ### Save and seek... + my $old_pos = $self->{FH}->tell; + $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); + + ### ...read... + my $text = $self->{FH}->getline; + + ### ...and restore: + $self->{FH}->seek($old_pos, 0); + + #### If we detected a new EOF ... + unless (defined $text) { + $self->{LG} = $self->{CRPOS}; + return undef; + } + + my $lg=length($text); + + $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG}); + $self->{CRPOS} += $lg; + + return substr($text, 0,$lg); +} + +sub CLOSE { %{$_[0]}=(); } + + + +1; +__END__ + +=back + + +=head1 VERSION + +$Id: InnerFile.pm,v 1.4 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHOR + +Original version by Doru Petrescu (pdoru@kappa.ro). + +Documentation and by Eryq (eryq@zeegee.com). + +Currently maintained by David F. Skoll (dfs@roaringpenguin.com). + +=cut + + diff --git a/Master/tlpkg/tlperl/lib/IO/Lines.pm b/Master/tlpkg/tlperl/lib/IO/Lines.pm new file mode 100755 index 00000000000..46c40a5492b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Lines.pm @@ -0,0 +1,184 @@ +package IO::Lines; + + +=head1 NAME + +IO::Lines - IO:: interface for reading/writing an array of lines + + +=head1 SYNOPSIS + + use IO::Lines; + + ### See IO::ScalarArray for details + + +=head1 DESCRIPTION + +This class implements objects which behave just like FileHandle +(or IO::Handle) objects, except that you may use them to write to +(or read from) an array of lines. They can be tiehandle'd as well. + +This is a subclass of L<IO::ScalarArray|IO::ScalarArray> +in which the underlying +array has its data stored in a line-oriented-format: that is, +every element ends in a C<"\n">, with the possible exception of the +final element. This makes C<getline()> I<much> more efficient; +if you plan to do line-oriented reading/printing, you want this class. + +The C<print()> method will enforce this rule, so you can print +arbitrary data to the line-array: it will break the data at +newlines appropriately. + +See L<IO::ScalarArray> for full usage and warnings. + +=cut + +use Carp; +use strict; +use IO::ScalarArray; +use vars qw($VERSION @ISA); + +# The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.110"; + +# Inheritance: +@ISA = qw(IO::ScalarArray); ### also gets us new_tie :-) + + +#------------------------------ +# +# getline +# +# Instance method, override. +# Return the next line, or undef on end of data. +# Can safely be called in an array context. +# Currently, lines are delimited by "\n". +# +sub getline { + my $self = shift; + + if (!defined $/) { + return join( '', $self->_getlines_for_newlines ); + } + elsif ($/ eq "\n") { + if (!*$self->{Pos}) { ### full line... + return *$self->{AR}[*$self->{Str}++]; + } + else { ### partial line... + my $partial = substr(*$self->{AR}[*$self->{Str}++], *$self->{Pos}); + *$self->{Pos} = 0; + return $partial; + } + } + else { + croak 'unsupported $/: must be "\n" or undef'; + } +} + +#------------------------------ +# +# getlines +# +# Instance method, override. +# Return an array comprised of the remaining lines, or () on end of data. +# Must be called in an array context. +# Currently, lines are delimited by "\n". +# +sub getlines { + my $self = shift; + wantarray or croak("can't call getlines in scalar context!"); + + if ((defined $/) and ($/ eq "\n")) { + return $self->_getlines_for_newlines(@_); + } + else { ### slow but steady + return $self->SUPER::getlines(@_); + } +} + +#------------------------------ +# +# _getlines_for_newlines +# +# Instance method, private. +# If $/ is newline, do fast getlines. +# This CAN NOT invoke getline! +# +sub _getlines_for_newlines { + my $self = shift; + my ($rArray, $Str, $Pos) = @{*$self}{ qw( AR Str Pos ) }; + my @partial = (); + + if ($Pos) { ### partial line... + @partial = (substr( $rArray->[ $Str++ ], $Pos )); + *$self->{Pos} = 0; + } + *$self->{Str} = scalar @$rArray; ### about to exhaust @$rArray + return (@partial, + @$rArray[ $Str .. $#$rArray ]); ### remaining full lines... +} + +#------------------------------ +# +# print ARGS... +# +# Instance method, override. +# Print ARGS to the underlying line array. +# +sub print { + if (defined $\ && $\ ne "\n") { + croak 'unsupported $\: must be "\n" or undef'; + } + + my $self = shift; + ### print STDERR "\n[[ARRAY WAS...\n", @{*$self->{AR}}, "<<EOF>>\n"; + my @lines = split /^/, join('', @_); @lines or return 1; + + ### Did the previous print not end with a newline? + ### If so, append first line: + if (@{*$self->{AR}} and (*$self->{AR}[-1] !~ /\n\Z/)) { + *$self->{AR}[-1] .= shift @lines; + } + push @{*$self->{AR}}, @lines; ### add the remainder + ### print STDERR "\n[[ARRAY IS NOW...\n", @{*$self->{AR}}, "<<EOF>>\n"; + 1; +} + +#------------------------------ +1; + +__END__ + + +=head1 VERSION + +$Id: Lines.pm,v 1.3 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHORS + + +=head2 Primary Maintainer + +David F. Skoll (F<dfs@roaringpenguin.com>). + +=head2 Principal author + +Eryq (F<eryq@zeegee.com>). +President, ZeeGee Software Inc (F<http://www.zeegee.com>). + + +=head2 Other contributors + +Thanks to the following individuals for their invaluable contributions +(if I've forgotten or misspelled your name, please email me!): + +I<Morris M. Siegel,> +for his $/ patch and the new C<getlines()>. + +I<Doug Wilson,> +for the IO::Handle inheritance and automatic tie-ing. + +=cut + diff --git a/Master/tlpkg/tlperl/lib/IO/Pipe.pm b/Master/tlpkg/tlperl/lib/IO/Pipe.pm new file mode 100755 index 00000000000..827cc48bfcd --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Pipe.pm @@ -0,0 +1,257 @@ +# 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.006_001; + +use IO::Handle; +use strict; +our($VERSION); +use Carp; +use Symbol; + +$VERSION = "1.13"; + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::Pipe"; + @_ == 0 || @_ == 2 or croak "usage: new $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 = new IO::Pipe; + + if($pid = fork()) { # Parent + $pipe->reader(); + + while(<$pipe>) { + ... + } + + } + elsif(defined $pid) { # Child + $pipe->writer(); + + print $pipe ... + } + + or + + $pipe = new IO::Pipe; + + $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 <perl5-porters@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/Master/tlpkg/tlperl/lib/IO/Poll.pm b/Master/tlpkg/tlperl/lib/IO/Poll.pm new file mode 100755 index 00000000000..e7fb0135069 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Poll.pm @@ -0,0 +1,209 @@ + +# 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, @EXPORT_OK, @EXPORT, $VERSION); + +@ISA = qw(Exporter); +$VERSION = "0.07"; + +@EXPORT = qw( POLLIN + POLLOUT + POLLERR + POLLHUP + POLLNVAL + ); + +@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 ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; + + 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 = new IO::Poll; + + $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 <perl5-porters@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/Master/tlpkg/tlperl/lib/IO/Scalar.pm b/Master/tlpkg/tlperl/lib/IO/Scalar.pm new file mode 100755 index 00000000000..7a522821343 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Scalar.pm @@ -0,0 +1,778 @@ +package IO::Scalar; + + +=head1 NAME + +IO::Scalar - IO:: interface for reading/writing a scalar + + +=head1 SYNOPSIS + +Perform I/O on strings, using the basic OO interface... + + use 5.005; + use IO::Scalar; + $data = "My message:\n"; + + ### Open a handle on a string, and append to it: + $SH = new IO::Scalar \$data; + $SH->print("Hello"); + $SH->print(", world!\nBye now!\n"); + print "The string is now: ", $data, "\n"; + + ### Open a handle on a string, read it line-by-line, then close it: + $SH = new IO::Scalar \$data; + while (defined($_ = $SH->getline)) { + print "Got line: $_"; + } + $SH->close; + + ### Open a handle on a string, and slurp in all the lines: + $SH = new IO::Scalar \$data; + print "All lines:\n", $SH->getlines; + + ### Get the current position (either of two ways): + $pos = $SH->getpos; + $offset = $SH->tell; + + ### Set the current position (either of two ways): + $SH->setpos($pos); + $SH->seek($offset, 0); + + ### Open an anonymous temporary scalar: + $SH = new IO::Scalar; + $SH->print("Hi there!"); + print "I printed: ", ${$SH->sref}, "\n"; ### get at value + + +Don't like OO for your I/O? No problem. +Thanks to the magic of an invisible tie(), the following now +works out of the box, just as it does with IO::Handle: + + use 5.005; + use IO::Scalar; + $data = "My message:\n"; + + ### Open a handle on a string, and append to it: + $SH = new IO::Scalar \$data; + print $SH "Hello"; + print $SH ", world!\nBye now!\n"; + print "The string is now: ", $data, "\n"; + + ### Open a handle on a string, read it line-by-line, then close it: + $SH = new IO::Scalar \$data; + while (<$SH>) { + print "Got line: $_"; + } + close $SH; + + ### Open a handle on a string, and slurp in all the lines: + $SH = new IO::Scalar \$data; + print "All lines:\n", <$SH>; + + ### Get the current position (WARNING: requires 5.6): + $offset = tell $SH; + + ### Set the current position (WARNING: requires 5.6): + seek $SH, $offset, 0; + + ### Open an anonymous temporary scalar: + $SH = new IO::Scalar; + print $SH "Hi there!"; + print "I printed: ", ${$SH->sref}, "\n"; ### get at value + + +And for you folks with 1.x code out there: the old tie() style still works, +though this is I<unnecessary and deprecated>: + + use IO::Scalar; + + ### Writing to a scalar... + my $s; + tie *OUT, 'IO::Scalar', \$s; + print OUT "line 1\nline 2\n", "line 3\n"; + print "String is now: $s\n" + + ### Reading and writing an anonymous scalar... + tie *OUT, 'IO::Scalar'; + print OUT "line 1\nline 2\n", "line 3\n"; + tied(OUT)->seek(0,0); + while (<OUT>) { + print "Got line: ", $_; + } + + +Stringification works, too! + + my $SH = new IO::Scalar \$data; + print $SH "Hello, "; + print $SH "world!"; + print "I printed: $SH\n"; + + + +=head1 DESCRIPTION + +This class is part of the IO::Stringy distribution; +see L<IO::Stringy> for change log and general information. + +The IO::Scalar class implements objects which behave just like +IO::Handle (or FileHandle) objects, except that you may use them +to write to (or read from) scalars. These handles are +automatically tiehandle'd (though please see L<"WARNINGS"> +for information relevant to your Perl version). + + +Basically, this: + + my $s; + $SH = new IO::Scalar \$s; + $SH->print("Hel", "lo, "); ### OO style + $SH->print("world!\n"); ### ditto + +Or this: + + my $s; + $SH = tie *OUT, 'IO::Scalar', \$s; + print OUT "Hel", "lo, "; ### non-OO style + print OUT "world!\n"; ### ditto + +Causes $s to be set to: + + "Hello, world!\n" + + +=head1 PUBLIC INTERFACE + +=cut + +use Carp; +use strict; +use vars qw($VERSION @ISA); +use IO::Handle; + +use 5.005; + +### Stringification, courtesy of B. K. Oxley (binkley): :-) +use overload '""' => sub { ${*{$_[0]}->{SR}} }; +use overload 'bool' => sub { 1 }; ### have to do this, so object is true! + +### The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.110"; + +### Inheritance: +@ISA = qw(IO::Handle); + +### This stuff should be got rid of ASAP. +require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004); + +#============================== + +=head2 Construction + +=over 4 + +=cut + +#------------------------------ + +=item new [ARGS...] + +I<Class method.> +Return a new, unattached scalar handle. +If any arguments are given, they're sent to open(). + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless \do { local *FH }, $class; + tie *$self, $class, $self; + $self->open(@_); ### open on anonymous by default + $self; +} +sub DESTROY { + shift->close; +} + +#------------------------------ + +=item open [SCALARREF] + +I<Instance method.> +Open the scalar handle on a new scalar, pointed to by SCALARREF. +If no SCALARREF is given, a "private" scalar is created to hold +the file data. + +Returns the self object on success, undefined on error. + +=cut + +sub open { + my ($self, $sref) = @_; + + ### Sanity: + defined($sref) or do {my $s = ''; $sref = \$s}; + (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; + + ### Setup: + *$self->{Pos} = 0; ### seek position + *$self->{SR} = $sref; ### scalar reference + $self; +} + +#------------------------------ + +=item opened + +I<Instance method.> +Is the scalar handle opened on something? + +=cut + +sub opened { + *{shift()}->{SR}; +} + +#------------------------------ + +=item close + +I<Instance method.> +Disassociate the scalar handle from its underlying scalar. +Done automatically on destroy. + +=cut + +sub close { + my $self = shift; + %{*$self} = (); + 1; +} + +=back + +=cut + + + +#============================== + +=head2 Input and output + +=over 4 + +=cut + + +#------------------------------ + +=item flush + +I<Instance method.> +No-op, provided for OO compatibility. + +=cut + +sub flush { "0 but true" } + +#------------------------------ + +=item getc + +I<Instance method.> +Return the next character, or undef if none remain. + +=cut + +sub getc { + my $self = shift; + + ### Return undef right away if at EOF; else, move pos forward: + return undef if $self->eof; + substr(${*$self->{SR}}, *$self->{Pos}++, 1); +} + +#------------------------------ + +=item getline + +I<Instance method.> +Return the next line, or undef on end of string. +Can safely be called in an array context. +Currently, lines are delimited by "\n". + +=cut + +sub getline { + my $self = shift; + + ### Return undef right away if at EOF: + return undef if $self->eof; + + ### Get next line: + my $sr = *$self->{SR}; + my $i = *$self->{Pos}; ### Start matching at this point. + + ### Minimal impact implementation! + ### We do the fast fast thing (no regexps) if using the + ### classic input record separator. + + ### Case 1: $/ is undef: slurp all... + if (!defined($/)) { + *$self->{Pos} = length $$sr; + return substr($$sr, $i); + } + + ### Case 2: $/ is "\n": zoom zoom zoom... + elsif ($/ eq "\012") { + + ### Seek ahead for "\n"... yes, this really is faster than regexps. + my $len = length($$sr); + for (; $i < $len; ++$i) { + last if ord (substr ($$sr, $i, 1)) == 10; + } + + ### Extract the line: + my $line; + if ($i < $len) { ### We found a "\n": + $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); + *$self->{Pos} = $i+1; ### Remember where we finished up. + } + else { ### No "\n"; slurp the remainder: + $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); + *$self->{Pos} = $len; + } + return $line; + } + + ### Case 3: $/ is ref to int. Do fixed-size records. + ### (Thanks to Dominique Quatravaux.) + elsif (ref($/)) { + my $len = length($$sr); + my $i = ${$/} + 0; + my $line = substr ($$sr, *$self->{Pos}, $i); + *$self->{Pos} += $i; + *$self->{Pos} = $len if (*$self->{Pos} > $len); + return $line; + } + + ### Case 4: $/ is either "" (paragraphs) or something weird... + ### This is Graham's general-purpose stuff, which might be + ### a tad slower than Case 2 for typical data, because + ### of the regexps. + else { + pos($$sr) = $i; + + ### If in paragraph mode, skip leading lines (and update i!): + length($/) or + (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); + + ### If we see the separator in the buffer ahead... + if (length($/) + ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! + : $$sr =~ m,\n\n,g ### (a paragraph) + ) { + *$self->{Pos} = pos $$sr; + return substr($$sr, $i, *$self->{Pos}-$i); + } + ### Else if no separator remains, just slurp the rest: + else { + *$self->{Pos} = length $$sr; + return substr($$sr, $i); + } + } +} + +#------------------------------ + +=item getlines + +I<Instance method.> +Get all remaining lines. +It will croak() if accidentally called in a scalar context. + +=cut + +sub getlines { + my $self = shift; + wantarray or croak("can't call getlines in scalar context!"); + my ($line, @lines); + push @lines, $line while (defined($line = $self->getline)); + @lines; +} + +#------------------------------ + +=item print ARGS... + +I<Instance method.> +Print ARGS to the underlying scalar. + +B<Warning:> this continues to always cause a seek to the end +of the string, but if you perform seek()s and tell()s, it is +still safer to explicitly seek-to-end before subsequent print()s. + +=cut + +sub print { + my $self = shift; + *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); + 1; +} +sub _unsafe_print { + my $self = shift; + my $append = join('', @_) . $\; + ${*$self->{SR}} .= $append; + *$self->{Pos} += length($append); + 1; +} +sub _old_print { + my $self = shift; + ${*$self->{SR}} .= join('', @_) . $\; + *$self->{Pos} = length(${*$self->{SR}}); + 1; +} + + +#------------------------------ + +=item read BUF, NBYTES, [OFFSET] + +I<Instance method.> +Read some bytes from the scalar. +Returns the number of bytes actually read, 0 on end-of-file, undef on error. + +=cut + +sub read { + my $self = $_[0]; + my $n = $_[2]; + my $off = $_[3] || 0; + + my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); + $n = length($read); + *$self->{Pos} += $n; + ($off ? substr($_[1], $off) : $_[1]) = $read; + return $n; +} + +#------------------------------ + +=item write BUF, NBYTES, [OFFSET] + +I<Instance method.> +Write some bytes to the scalar. + +=cut + +sub write { + my $self = $_[0]; + my $n = $_[2]; + my $off = $_[3] || 0; + + my $data = substr($_[1], $off, $n); + $n = length($data); + $self->print($data); + return $n; +} + +#------------------------------ + +=item sysread BUF, LEN, [OFFSET] + +I<Instance method.> +Read some bytes from the scalar. +Returns the number of bytes actually read, 0 on end-of-file, undef on error. + +=cut + +sub sysread { + my $self = shift; + $self->read(@_); +} + +#------------------------------ + +=item syswrite BUF, NBYTES, [OFFSET] + +I<Instance method.> +Write some bytes to the scalar. + +=cut + +sub syswrite { + my $self = shift; + $self->write(@_); +} + +=back + +=cut + + +#============================== + +=head2 Seeking/telling and other attributes + +=over 4 + +=cut + + +#------------------------------ + +=item autoflush + +I<Instance method.> +No-op, provided for OO compatibility. + +=cut + +sub autoflush {} + +#------------------------------ + +=item binmode + +I<Instance method.> +No-op, provided for OO compatibility. + +=cut + +sub binmode {} + +#------------------------------ + +=item clearerr + +I<Instance method.> Clear the error and EOF flags. A no-op. + +=cut + +sub clearerr { 1 } + +#------------------------------ + +=item eof + +I<Instance method.> Are we at end of file? + +=cut + +sub eof { + my $self = shift; + (*$self->{Pos} >= length(${*$self->{SR}})); +} + +#------------------------------ + +=item seek OFFSET, WHENCE + +I<Instance method.> Seek to a given position in the stream. + +=cut + +sub seek { + my ($self, $pos, $whence) = @_; + my $eofpos = length(${*$self->{SR}}); + + ### Seek: + if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET + elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR + elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END + else { croak "bad seek whence ($whence)" } + + ### Fixup: + if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } + if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } + return 1; +} + +#------------------------------ + +=item sysseek OFFSET, WHENCE + +I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.> + +=cut + +sub sysseek { + my $self = shift; + $self->seek (@_); +} + +#------------------------------ + +=item tell + +I<Instance method.> +Return the current position in the stream, as a numeric offset. + +=cut + +sub tell { *{shift()}->{Pos} } + +#------------------------------ +# +# use_RS [YESNO] +# +# I<Instance method.> +# Obey the curent setting of $/, like IO::Handle does? +# Default is false in 1.x, but cold-welded true in 2.x and later. +# +sub use_RS { + my ($self, $yesno) = @_; + carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; + } + +#------------------------------ + +=item setpos POS + +I<Instance method.> +Set the current position, using the opaque value returned by C<getpos()>. + +=cut + +sub setpos { shift->seek($_[0],0) } + +#------------------------------ + +=item getpos + +I<Instance method.> +Return the current position in the string, as an opaque object. + +=cut + +*getpos = \&tell; + + +#------------------------------ + +=item sref + +I<Instance method.> +Return a reference to the underlying scalar. + +=cut + +sub sref { *{shift()}->{SR} } + + +#------------------------------ +# Tied handle methods... +#------------------------------ + +# Conventional tiehandle interface: +sub TIEHANDLE { + ((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar")) + ? $_[1] + : shift->new(@_)); +} +sub GETC { shift->getc(@_) } +sub PRINT { shift->print(@_) } +sub PRINTF { shift->print(sprintf(shift, @_)) } +sub READ { shift->read(@_) } +sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } +sub WRITE { shift->write(@_); } +sub CLOSE { shift->close(@_); } +sub SEEK { shift->seek(@_); } +sub TELL { shift->tell(@_); } +sub EOF { shift->eof(@_); } + +#------------------------------------------------------------ + +1; + +__END__ + + + +=back + +=cut + + +=head1 WARNINGS + +Perl's TIEHANDLE spec was incomplete prior to 5.005_57; +it was missing support for C<seek()>, C<tell()>, and C<eof()>. +Attempting to use these functions with an IO::Scalar will not work +prior to 5.005_57. IO::Scalar will not have the relevant methods +invoked; and even worse, this kind of bug can lie dormant for a while. +If you turn warnings on (via C<$^W> or C<perl -w>), +and you see something like this... + + attempt to seek on unopened filehandle + +...then you are probably trying to use one of these functions +on an IO::Scalar with an old Perl. The remedy is to simply +use the OO version; e.g.: + + $SH->seek(0,0); ### GOOD: will work on any 5.005 + seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond + + +=head1 VERSION + +$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHORS + +=head2 Primary Maintainer + +David F. Skoll (F<dfs@roaringpenguin.com>). + +=head2 Principal author + +Eryq (F<eryq@zeegee.com>). +President, ZeeGee Software Inc (F<http://www.zeegee.com>). + + +=head2 Other contributors + +The full set of contributors always includes the folks mentioned +in L<IO::Stringy/"CHANGE LOG">. But just the same, special +thanks to the following individuals for their invaluable contributions +(if I've forgotten or misspelled your name, please email me!): + +I<Andy Glew,> +for contributing C<getc()>. + +I<Brandon Browning,> +for suggesting C<opened()>. + +I<David Richter,> +for finding and fixing the bug in C<PRINTF()>. + +I<Eric L. Brine,> +for his offset-using read() and write() implementations. + +I<Richard Jones,> +for his patches to massively improve the performance of C<getline()> +and add C<sysread> and C<syswrite>. + +I<B. K. Oxley (binkley),> +for stringification and inheritance improvements, +and sundry good ideas. + +I<Doug Wilson,> +for the IO::Handle inheritance and automatic tie-ing. + + +=head1 SEE ALSO + +L<IO::String>, which is quite similar but which was designed +more-recently and with an IO::Handle-like interface in mind, +so you could mix OO- and native-filehandle usage without using tied(). + +I<Note:> as of version 2.x, these classes all work like +their IO::Handle counterparts, so we have comparable +functionality to IO::String. + +=cut + diff --git a/Master/tlpkg/tlperl/lib/IO/ScalarArray.pm b/Master/tlpkg/tlperl/lib/IO/ScalarArray.pm new file mode 100755 index 00000000000..8877ce60472 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/ScalarArray.pm @@ -0,0 +1,791 @@ +package IO::ScalarArray; + + +=head1 NAME + +IO::ScalarArray - IO:: interface for reading/writing an array of scalars + + +=head1 SYNOPSIS + +Perform I/O on strings, using the basic OO interface... + + use IO::ScalarArray; + @data = ("My mes", "sage:\n"); + + ### Open a handle on an array, and append to it: + $AH = new IO::ScalarArray \@data; + $AH->print("Hello"); + $AH->print(", world!\nBye now!\n"); + print "The array is now: ", @data, "\n"; + + ### Open a handle on an array, read it line-by-line, then close it: + $AH = new IO::ScalarArray \@data; + while (defined($_ = $AH->getline)) { + print "Got line: $_"; + } + $AH->close; + + ### Open a handle on an array, and slurp in all the lines: + $AH = new IO::ScalarArray \@data; + print "All lines:\n", $AH->getlines; + + ### Get the current position (either of two ways): + $pos = $AH->getpos; + $offset = $AH->tell; + + ### Set the current position (either of two ways): + $AH->setpos($pos); + $AH->seek($offset, 0); + + ### Open an anonymous temporary array: + $AH = new IO::ScalarArray; + $AH->print("Hi there!"); + print "I printed: ", @{$AH->aref}, "\n"; ### get at value + + +Don't like OO for your I/O? No problem. +Thanks to the magic of an invisible tie(), the following now +works out of the box, just as it does with IO::Handle: + + use IO::ScalarArray; + @data = ("My mes", "sage:\n"); + + ### Open a handle on an array, and append to it: + $AH = new IO::ScalarArray \@data; + print $AH "Hello"; + print $AH ", world!\nBye now!\n"; + print "The array is now: ", @data, "\n"; + + ### Open a handle on a string, read it line-by-line, then close it: + $AH = new IO::ScalarArray \@data; + while (<$AH>) { + print "Got line: $_"; + } + close $AH; + + ### Open a handle on a string, and slurp in all the lines: + $AH = new IO::ScalarArray \@data; + print "All lines:\n", <$AH>; + + ### Get the current position (WARNING: requires 5.6): + $offset = tell $AH; + + ### Set the current position (WARNING: requires 5.6): + seek $AH, $offset, 0; + + ### Open an anonymous temporary scalar: + $AH = new IO::ScalarArray; + print $AH "Hi there!"; + print "I printed: ", @{$AH->aref}, "\n"; ### get at value + + +And for you folks with 1.x code out there: the old tie() style still works, +though this is I<unnecessary and deprecated>: + + use IO::ScalarArray; + + ### Writing to a scalar... + my @a; + tie *OUT, 'IO::ScalarArray', \@a; + print OUT "line 1\nline 2\n", "line 3\n"; + print "Array is now: ", @a, "\n" + + ### Reading and writing an anonymous scalar... + tie *OUT, 'IO::ScalarArray'; + print OUT "line 1\nline 2\n", "line 3\n"; + tied(OUT)->seek(0,0); + while (<OUT>) { + print "Got line: ", $_; + } + + + +=head1 DESCRIPTION + +This class is part of the IO::Stringy distribution; +see L<IO::Stringy> for change log and general information. + +The IO::ScalarArray class implements objects which behave just like +IO::Handle (or FileHandle) objects, except that you may use them +to write to (or read from) arrays of scalars. Logically, an +array of scalars defines an in-core "file" whose contents are +the concatenation of the scalars in the array. The handles created by +this class are automatically tiehandle'd (though please see L<"WARNINGS"> +for information relevant to your Perl version). + +For writing large amounts of data with individual print() statements, +this class is likely to be more efficient than IO::Scalar. + +Basically, this: + + my @a; + $AH = new IO::ScalarArray \@a; + $AH->print("Hel", "lo, "); ### OO style + $AH->print("world!\n"); ### ditto + +Or this: + + my @a; + $AH = new IO::ScalarArray \@a; + print $AH "Hel", "lo, "; ### non-OO style + print $AH "world!\n"; ### ditto + +Causes @a to be set to the following array of 3 strings: + + ( "Hel" , + "lo, " , + "world!\n" ) + +See L<IO::Scalar> and compare with this class. + + +=head1 PUBLIC INTERFACE + +=cut + +use Carp; +use strict; +use vars qw($VERSION @ISA); +use IO::Handle; + +# The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.110"; + +# Inheritance: +@ISA = qw(IO::Handle); +require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004); + + +#============================== + +=head2 Construction + +=over 4 + +=cut + +#------------------------------ + +=item new [ARGS...] + +I<Class method.> +Return a new, unattached array handle. +If any arguments are given, they're sent to open(). + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless \do { local *FH }, $class; + tie *$self, $class, $self; + $self->open(@_); ### open on anonymous by default + $self; +} +sub DESTROY { + shift->close; +} + + +#------------------------------ + +=item open [ARRAYREF] + +I<Instance method.> +Open the array handle on a new array, pointed to by ARRAYREF. +If no ARRAYREF is given, a "private" array is created to hold +the file data. + +Returns the self object on success, undefined on error. + +=cut + +sub open { + my ($self, $aref) = @_; + + ### Sanity: + defined($aref) or do {my @a; $aref = \@a}; + (ref($aref) eq "ARRAY") or croak "open needs a ref to a array"; + + ### Setup: + $self->setpos([0,0]); + *$self->{AR} = $aref; + $self; +} + +#------------------------------ + +=item opened + +I<Instance method.> +Is the array handle opened on something? + +=cut + +sub opened { + *{shift()}->{AR}; +} + +#------------------------------ + +=item close + +I<Instance method.> +Disassociate the array handle from its underlying array. +Done automatically on destroy. + +=cut + +sub close { + my $self = shift; + %{*$self} = (); + 1; +} + +=back + +=cut + + + +#============================== + +=head2 Input and output + +=over 4 + +=cut + +#------------------------------ + +=item flush + +I<Instance method.> +No-op, provided for OO compatibility. + +=cut + +sub flush { "0 but true" } + +#------------------------------ + +=item getc + +I<Instance method.> +Return the next character, or undef if none remain. +This does a read(1), which is somewhat costly. + +=cut + +sub getc { + my $buf = ''; + ($_[0]->read($buf, 1) ? $buf : undef); +} + +#------------------------------ + +=item getline + +I<Instance method.> +Return the next line, or undef on end of data. +Can safely be called in an array context. +Currently, lines are delimited by "\n". + +=cut + +sub getline { + my $self = shift; + my ($str, $line) = (undef, ''); + + + ### Minimal impact implementation! + ### We do the fast fast thing (no regexps) if using the + ### classic input record separator. + + ### Case 1: $/ is undef: slurp all... + if (!defined($/)) { + + return undef if ($self->eof); + + ### Get the rest of the current string, followed by remaining strings: + my $ar = *$self->{AR}; + my @slurp = ( + substr($ar->[*$self->{Str}], *$self->{Pos}), + @$ar[(1 + *$self->{Str}) .. $#$ar ] + ); + + ### Seek to end: + $self->_setpos_to_eof; + return join('', @slurp); + } + + ### Case 2: $/ is "\n": + elsif ($/ eq "\012") { + + ### Until we hit EOF (or exitted because of a found line): + until ($self->eof) { + ### If at end of current string, go fwd to next one (won't be EOF): + if ($self->_eos) {++*$self->{Str}, *$self->{Pos}=0}; + + ### Get ref to current string in array, and set internal pos mark: + $str = \(*$self->{AR}[*$self->{Str}]); ### get current string + pos($$str) = *$self->{Pos}; ### start matching from here + + ### Get from here to either \n or end of string, and add to line: + $$str =~ m/\G(.*?)((\n)|\Z)/g; ### match to 1st \n or EOS + $line .= $1.$2; ### add it + *$self->{Pos} += length($1.$2); ### move fwd by len matched + return $line if $3; ### done, got line with "\n" + } + return ($line eq '') ? undef : $line; ### return undef if EOF + } + + ### Case 3: $/ is ref to int. Bail out. + elsif (ref($/)) { + croak '$/ given as a ref to int; currently unsupported'; + } + + ### Case 4: $/ is either "" (paragraphs) or something weird... + ### Bail for now. + else { + croak '$/ as given is currently unsupported'; + } +} + +#------------------------------ + +=item getlines + +I<Instance method.> +Get all remaining lines. +It will croak() if accidentally called in a scalar context. + +=cut + +sub getlines { + my $self = shift; + wantarray or croak("can't call getlines in scalar context!"); + my ($line, @lines); + push @lines, $line while (defined($line = $self->getline)); + @lines; +} + +#------------------------------ + +=item print ARGS... + +I<Instance method.> +Print ARGS to the underlying array. + +Currently, this always causes a "seek to the end of the array" +and generates a new array entry. This may change in the future. + +=cut + +sub print { + my $self = shift; + push @{*$self->{AR}}, join('', @_) . (defined($\) ? $\ : ""); ### add the data + $self->_setpos_to_eof; + 1; +} + +#------------------------------ + +=item read BUF, NBYTES, [OFFSET]; + +I<Instance method.> +Read some bytes from the array. +Returns the number of bytes actually read, 0 on end-of-file, undef on error. + +=cut + +sub read { + my $self = $_[0]; + ### we must use $_[1] as a ref + my $n = $_[2]; + my $off = $_[3] || 0; + + ### print "getline\n"; + my $justread; + my $len; + ($off ? substr($_[1], $off) : $_[1]) = ''; + + ### Stop when we have zero bytes to go, or when we hit EOF: + my @got; + until (!$n or $self->eof) { + ### If at end of current string, go forward to next one (won't be EOF): + if ($self->_eos) { + ++*$self->{Str}; + *$self->{Pos} = 0; + } + + ### Get longest possible desired substring of current string: + $justread = substr(*$self->{AR}[*$self->{Str}], *$self->{Pos}, $n); + $len = length($justread); + push @got, $justread; + $n -= $len; + *$self->{Pos} += $len; + } + $_[1] .= join('', @got); + return length($_[1])-$off; +} + +#------------------------------ + +=item write BUF, NBYTES, [OFFSET]; + +I<Instance method.> +Write some bytes into the array. + +=cut + +sub write { + my $self = $_[0]; + my $n = $_[2]; + my $off = $_[3] || 0; + + my $data = substr($_[1], $n, $off); + $n = length($data); + $self->print($data); + return $n; +} + + +=back + +=cut + + + +#============================== + +=head2 Seeking/telling and other attributes + +=over 4 + +=cut + +#------------------------------ + +=item autoflush + +I<Instance method.> +No-op, provided for OO compatibility. + +=cut + +sub autoflush {} + +#------------------------------ + +=item binmode + +I<Instance method.> +No-op, provided for OO compatibility. + +=cut + +sub binmode {} + +#------------------------------ + +=item clearerr + +I<Instance method.> Clear the error and EOF flags. A no-op. + +=cut + +sub clearerr { 1 } + +#------------------------------ + +=item eof + +I<Instance method.> Are we at end of file? + +=cut + +sub eof { + ### print "checking EOF [*$self->{Str}, *$self->{Pos}]\n"; + ### print "SR = ", $#{*$self->{AR}}, "\n"; + + return 0 if (*{$_[0]}->{Str} < $#{*{$_[0]}->{AR}}); ### before EOA + return 1 if (*{$_[0]}->{Str} > $#{*{$_[0]}->{AR}}); ### after EOA + ### ### at EOA, past EOS: + ((*{$_[0]}->{Str} == $#{*{$_[0]}->{AR}}) && ($_[0]->_eos)); +} + +#------------------------------ +# +# _eos +# +# I<Instance method, private.> Are we at end of the CURRENT string? +# +sub _eos { + (*{$_[0]}->{Pos} >= length(*{$_[0]}->{AR}[*{$_[0]}->{Str}])); ### past last char +} + +#------------------------------ + +=item seek POS,WHENCE + +I<Instance method.> +Seek to a given position in the stream. +Only a WHENCE of 0 (SEEK_SET) is supported. + +=cut + +sub seek { + my ($self, $pos, $whence) = @_; + + ### Seek: + if ($whence == 0) { $self->_seek_set($pos); } + elsif ($whence == 1) { $self->_seek_cur($pos); } + elsif ($whence == 2) { $self->_seek_end($pos); } + else { croak "bad seek whence ($whence)" } + return 1; +} + +#------------------------------ +# +# _seek_set POS +# +# Instance method, private. +# Seek to $pos relative to start: +# +sub _seek_set { + my ($self, $pos) = @_; + + ### Advance through array until done: + my $istr = 0; + while (($pos >= 0) && ($istr < scalar(@{*$self->{AR}}))) { + if (length(*$self->{AR}[$istr]) > $pos) { ### it's in this string! + return $self->setpos([$istr, $pos]); + } + else { ### it's in next string + $pos -= length(*$self->{AR}[$istr++]); ### move forward one string + } + } + ### If we reached this point, pos is at or past end; zoom to EOF: + return $self->_setpos_to_eof; +} + +#------------------------------ +# +# _seek_cur POS +# +# Instance method, private. +# Seek to $pos relative to current position. +# +sub _seek_cur { + my ($self, $pos) = @_; + $self->_seek_set($self->tell + $pos); +} + +#------------------------------ +# +# _seek_end POS +# +# Instance method, private. +# Seek to $pos relative to end. +# We actually seek relative to beginning, which is simple. +# +sub _seek_end { + my ($self, $pos) = @_; + $self->_seek_set($self->_tell_eof + $pos); +} + +#------------------------------ + +=item tell + +I<Instance method.> +Return the current position in the stream, as a numeric offset. + +=cut + +sub tell { + my $self = shift; + my $off = 0; + my ($s, $str_s); + for ($s = 0; $s < *$self->{Str}; $s++) { ### count all "whole" scalars + defined($str_s = *$self->{AR}[$s]) or $str_s = ''; + ###print STDERR "COUNTING STRING $s (". length($str_s) . ")\n"; + $off += length($str_s); + } + ###print STDERR "COUNTING POS ($self->{Pos})\n"; + return ($off += *$self->{Pos}); ### plus the final, partial one +} + +#------------------------------ +# +# _tell_eof +# +# Instance method, private. +# Get position of EOF, as a numeric offset. +# This is identical to the size of the stream - 1. +# +sub _tell_eof { + my $self = shift; + my $len = 0; + foreach (@{*$self->{AR}}) { $len += length($_) } + $len; +} + +#------------------------------ + +=item setpos POS + +I<Instance method.> +Seek to a given position in the array, using the opaque getpos() value. +Don't expect this to be a number. + +=cut + +sub setpos { + my ($self, $pos) = @_; + (ref($pos) eq 'ARRAY') or + die "setpos: only use a value returned by getpos!\n"; + (*$self->{Str}, *$self->{Pos}) = @$pos; +} + +#------------------------------ +# +# _setpos_to_eof +# +# Fast-forward to EOF. +# +sub _setpos_to_eof { + my $self = shift; + $self->setpos([scalar(@{*$self->{AR}}), 0]); +} + +#------------------------------ + +=item getpos + +I<Instance method.> +Return the current position in the array, as an opaque value. +Don't expect this to be a number. + +=cut + +sub getpos { + [*{$_[0]}->{Str}, *{$_[0]}->{Pos}]; +} + +#------------------------------ + +=item aref + +I<Instance method.> +Return a reference to the underlying array. + +=cut + +sub aref { + *{shift()}->{AR}; +} + +=back + +=cut + +#------------------------------ +# Tied handle methods... +#------------------------------ + +### Conventional tiehandle interface: +sub TIEHANDLE { (defined($_[1]) && UNIVERSAL::isa($_[1],"IO::ScalarArray")) + ? $_[1] + : shift->new(@_) } +sub GETC { shift->getc(@_) } +sub PRINT { shift->print(@_) } +sub PRINTF { shift->print(sprintf(shift, @_)) } +sub READ { shift->read(@_) } +sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } +sub WRITE { shift->write(@_); } +sub CLOSE { shift->close(@_); } +sub SEEK { shift->seek(@_); } +sub TELL { shift->tell(@_); } +sub EOF { shift->eof(@_); } + +#------------------------------------------------------------ + +1; +__END__ + +# SOME PRIVATE NOTES: +# +# * The "current position" is the position before the next +# character to be read/written. +# +# * Str gives the string index of the current position, 0-based +# +# * Pos gives the offset within AR[Str], 0-based. +# +# * Inital pos is [0,0]. After print("Hello"), it is [1,0]. + + + +=head1 WARNINGS + +Perl's TIEHANDLE spec was incomplete prior to 5.005_57; +it was missing support for C<seek()>, C<tell()>, and C<eof()>. +Attempting to use these functions with an IO::ScalarArray will not work +prior to 5.005_57. IO::ScalarArray will not have the relevant methods +invoked; and even worse, this kind of bug can lie dormant for a while. +If you turn warnings on (via C<$^W> or C<perl -w>), +and you see something like this... + + attempt to seek on unopened filehandle + +...then you are probably trying to use one of these functions +on an IO::ScalarArray with an old Perl. The remedy is to simply +use the OO version; e.g.: + + $AH->seek(0,0); ### GOOD: will work on any 5.005 + seek($AH,0,0); ### WARNING: will only work on 5.005_57 and beyond + + + +=head1 VERSION + +$Id: ScalarArray.pm,v 1.7 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHOR + +=head2 Primary Maintainer + +David F. Skoll (F<dfs@roaringpenguin.com>). + +=head2 Principal author + +Eryq (F<eryq@zeegee.com>). +President, ZeeGee Software Inc (F<http://www.zeegee.com>). + + +=head2 Other contributors + +Thanks to the following individuals for their invaluable contributions +(if I've forgotten or misspelled your name, please email me!): + +I<Andy Glew,> +for suggesting C<getc()>. + +I<Brandon Browning,> +for suggesting C<opened()>. + +I<Eric L. Brine,> +for his offset-using read() and write() implementations. + +I<Doug Wilson,> +for the IO::Handle inheritance and automatic tie-ing. + +=cut + +#------------------------------ +1; + diff --git a/Master/tlpkg/tlperl/lib/IO/Seekable.pm b/Master/tlpkg/tlperl/lib/IO/Seekable.pm new file mode 100755 index 00000000000..db1effda287 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Seekable.pm @@ -0,0 +1,128 @@ +# + +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.006_001; +use Carp; +use strict; +our($VERSION, @EXPORT, @ISA); +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; + +@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); +@ISA = qw(Exporter); + +$VERSION = "1.10"; +$VERSION = eval $VERSION; + +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/Master/tlpkg/tlperl/lib/IO/Select.pm b/Master/tlpkg/tlperl/lib/IO/Select.pm new file mode 100755 index 00000000000..fc05fe70e9c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Select.pm @@ -0,0 +1,381 @@ +# 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; +use vars qw($VERSION @ISA); +require Exporter; + +$VERSION = "1.17"; + +@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); + next unless defined $fn; + my $i = $fn + FIRST_FD; + if ($add) { + 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 + 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, in +seconds, possibly fractional. If C<TIMEOUT> is not given and any +handles are registered then the call will block. + +=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. + +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 error 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 = new IO::Socket::INET(Listen => 1, LocalPort => 8080); + $sel = new IO::Select( $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 <perl5-porters@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/Master/tlpkg/tlperl/lib/IO/Socket.pm b/Master/tlpkg/tlperl/lib/IO/Socket.pm new file mode 100755 index 00000000000..2ef05a72fa7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Socket.pm @@ -0,0 +1,529 @@ +# 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; + +require 5.006; + +use IO::Handle; +use Socket 1.3; +use Carp; +use strict; +our(@ISA, $VERSION, @EXPORT_OK); +use Exporter; +use Errno; + +# legacy + +require IO::Socket::INET; +require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian'); + +@ISA = qw(IO::Handle); + +$VERSION = "1.31"; + +@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 $!; + if (!$sel->can_write($timeout)) { + $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + $@ = "connect: timeout"; + } + elsif (!connect($sock,$addr) && + not ($!{EISCONN} || ($! == 10022 && $^O eq 'MSWin32')) + ) { + # Some systems refuse to re-connect() to + # an already open socket and set errno to EISCONN. + # Windows sets errno to WSAEINVAL (10022) + $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'; + + # 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; + + 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; + ${*$sock}{'io_socket_domain'}; +} + +sub socktype { + @_ == 1 or croak 'usage: $sock->socktype()'; + my $sock = shift; + ${*$sock}{'io_socket_type'} +} + +sub protocol { + @_ == 1 or croak 'usage: $sock->protocol()'; + my($sock) = @_; + ${*$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 then undef will be returned. + +=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 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 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 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 <perl5-porters@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/Master/tlpkg/tlperl/lib/IO/Socket/INET.pm b/Master/tlpkg/tlperl/lib/IO/Socket/INET.pm new file mode 100755 index 00000000000..2f0e5d1d7a6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Socket/INET.pm @@ -0,0 +1,464 @@ +# 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; +our(@ISA, $VERSION); +use IO::Socket; +use Socket; +use Carp; +use Exporter; +use Errno; + +@ISA = qw(IO::Socket); +$VERSION = "1.31"; + +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 = 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 = 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. + +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 <perl5-porters@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/Master/tlpkg/tlperl/lib/IO/Socket/SSL.pm b/Master/tlpkg/tlperl/lib/IO/Socket/SSL.pm new file mode 100755 index 00000000000..bcf098f58f3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Socket/SSL.pm @@ -0,0 +1,2303 @@ +#!/usr/bin/perl -w +# +# IO::Socket::SSL: +# a drop-in replacement for IO::Socket::INET that encapsulates +# data passed over a network with SSL. +# +# Current Code Shepherd: Steffen Ullrich <steffen at genua.de> +# Code Shepherd before: Peter Behroozi, <behrooz at fas.harvard.edu> +# +# The original version of this module was written by +# Marko Asplund, <marko.asplund at kronodoc.fi>, who drew from +# Crypt::SSLeay (Net::SSL) by Gisle Aas. +# + +package IO::Socket::SSL; + +use IO::Socket; +use Net::SSLeay 1.21; +use Exporter (); +use Errno qw( EAGAIN ETIMEDOUT ); +use Carp; +use strict; + +use constant { + SSL_VERIFY_NONE => Net::SSLeay::VERIFY_NONE(), + SSL_VERIFY_PEER => Net::SSLeay::VERIFY_PEER(), + SSL_VERIFY_FAIL_IF_NO_PEER_CERT => Net::SSLeay::VERIFY_FAIL_IF_NO_PEER_CERT(), + SSL_VERIFY_CLIENT_ONCE => Net::SSLeay::VERIFY_CLIENT_ONCE(), + # from openssl/ssl.h, should be better in Net::SSLeay + SSL_SENT_SHUTDOWN => 1, + SSL_RECEIVED_SHUTDOWN => 2, +}; + + + +# non-XS Versions of Scalar::Util will fail +BEGIN{ + eval { use Scalar::Util 'dualvar'; dualvar(0,'') }; + die "You need the XS Version of Scalar::Util for dualvar() support" + if $@; +} + +use vars qw(@ISA $VERSION $DEBUG $SSL_ERROR $GLOBAL_CONTEXT_ARGS @EXPORT ); + +{ + # These constants will be used in $! at return from SSL_connect, + # SSL_accept, generic_read and write, thus notifying the caller + # the usual way of problems. Like with EAGAIN, EINPROGRESS.. + # these are especially important for non-blocking sockets + + my $x = Net::SSLeay::ERROR_WANT_READ(); + use constant SSL_WANT_READ => dualvar( \$x, 'SSL wants a read first' ); + my $y = Net::SSLeay::ERROR_WANT_WRITE(); + use constant SSL_WANT_WRITE => dualvar( \$y, 'SSL wants a write first' ); + + @EXPORT = qw( + SSL_WANT_READ SSL_WANT_WRITE SSL_VERIFY_NONE SSL_VERIFY_PEER + SSL_VERIFY_FAIL_IF_NO_PEER_CERT SSL_VERIFY_CLIENT_ONCE + $SSL_ERROR GEN_DNS GEN_IPADD + ); +} + +my @caller_force_inet4; # in case inet4 gets forced we store here who forced it +my $can_ipv6; # true if we successfully enabled ipv6 while loading + +BEGIN { + # Declare @ISA, $VERSION, $GLOBAL_CONTEXT_ARGS + + # if we have IO::Socket::INET6 we will use this not IO::Socket::INET, because + # it can handle both IPv4 and IPv6. If we don't have INET6 available fall back + # to INET + if ( ! eval { + require Socket6; + Socket6->import( 'inet_pton' ); + require IO::Socket::INET6; + @ISA = qw(IO::Socket::INET6); + $can_ipv6 = 1; + }) { + @ISA = qw(IO::Socket::INET); + } + $VERSION = '1.31'; + $GLOBAL_CONTEXT_ARGS = {}; + + #Make $DEBUG another name for $Net::SSLeay::trace + *DEBUG = \$Net::SSLeay::trace; + + #Compability + *ERROR = \$SSL_ERROR; + + # Do Net::SSLeay initialization + Net::SSLeay::load_error_strings(); + Net::SSLeay::SSLeay_add_ssl_algorithms(); + Net::SSLeay::randomize(); +} + +sub DEBUG { + $DEBUG>=shift or return; # check against debug level + my (undef,$file,$line) = caller; + my $msg = shift; + $file = '...'.substr( $file,-17 ) if length($file)>20; + $msg = sprintf $msg,@_ if @_; + print STDERR "DEBUG: $file:$line: $msg\n"; +} + +BEGIN { + # import some constants from Net::SSLeay or use hard-coded defaults + # if Net::SSLeay isn't recent enough to provide the constants + my %const = ( + NID_CommonName => 13, + GEN_DNS => 2, + GEN_IPADD => 7, + ); + while ( my ($name,$value) = each %const ) { + no strict 'refs'; + *{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value }; + } + + # check if we have something to handle IDN + local $SIG{__DIE__}; local $SIG{__WARN__}; # be silent + if ( eval { require Net::IDN::Encode }) { + *{idn_to_ascii} = \&Net::IDN::Encode::domain_to_ascii; + } elsif ( eval { require Net::LibIDN }) { + *{idn_to_ascii} = \&Net::LibIDN::idn_to_ascii; + } else { + # default: croak if we really got an unencoded international domain + *{idn_to_ascii} = sub { + my $domain = shift; + return $domain if $domain =~m{^[a-zA-Z0-9-_\.]+$}; + croak "cannot handle international domains, please install Net::LibIDN or Net::IDN::Encode" + } + } +} + +# Export some stuff +# inet4|inet6|debug will be handeled by myself, everything +# else will be handeld the Exporter way +sub import { + my $class = shift; + + my @export; + foreach (@_) { + if ( /^inet4$/i ) { + # explicitly fall back to inet4 + @ISA = 'IO::Socket::INET'; + @caller_force_inet4 = caller(); # save for warnings for 'inet6' case + } elsif ( /^inet6$/i ) { + # check if we have already ipv6 as base + if ( ! UNIVERSAL::isa( $class, 'IO::Socket::INET6' )) { + # either we don't support it or we disabled it by explicitly + # loading it with 'inet4'. In this case re-enable but warn + # because this is probably an error + if ( $can_ipv6 ) { + @ISA = 'IO::Socket::INET6'; + warn "IPv6 support re-enabled in __PACKAGE__, got disabled in file $caller_force_inet4[1] line $caller_force_inet4[2]"; + } else { + die "INET6 is not supported, missing Socket6 or IO::Socket::INET6"; + } + } + } elsif ( /^:?debug(\d+)/ ) { + $DEBUG=$1; + } else { + push @export,$_ + } + } + + @_ = ( $class,@export ); + goto &Exporter::import; +} + +# You might be expecting to find a new() subroutine here, but that is +# not how IO::Socket::INET works. All configuration gets performed in +# the calls to configure() and either connect() or accept(). + +#Call to configure occurs when a new socket is made using +#IO::Socket::INET. Returns false (empty list) on failure. +sub configure { + my ($self, $arg_hash) = @_; + return _invalid_object() unless($self); + + # work around Bug in IO::Socket::INET6 where it doesn't use the + # right family for the socket on BSD systems: + # http://rt.cpan.org/Ticket/Display.html?id=39550 + if ( $can_ipv6 && ! $arg_hash->{Domain} && + ! ( $arg_hash->{LocalAddr} || $arg_hash->{LocalHost} ) && + (my $peer = $arg_hash->{PeerAddr} || $arg_hash->{PeerHost})) { + # set Domain to AF_INET/AF_INET6 if there is only one choice + ($peer, my $port) = IO::Socket::INET6::_sock_info( $peer,$arg_hash->{PeerPort},6 ); + my @res = Socket6::getaddrinfo( $peer,$port,AF_UNSPEC,SOCK_STREAM ); + if (@res == 5) { + $arg_hash->{Domain} = $res[0]; + DEBUG(2,'set domain to '.$res[0] ); + } + } + + # force initial blocking + # otherwise IO::Socket::SSL->new might return undef if the + # socket is nonblocking and it fails to connect immediatly + # for real nonblocking behavior one should create a nonblocking + # socket and later call connect explicitly + my $blocking = delete $arg_hash->{Blocking}; + + # because Net::HTTPS simple redefines blocking() to {} (e.g + # return undef) and IO::Socket::INET does not like this we + + # set Blocking only explicitly if it was set + $arg_hash->{Blocking} = 1 if defined ($blocking); + + $self->configure_SSL($arg_hash) || return; + + $self->SUPER::configure($arg_hash) + || return $self->error("@ISA configuration failed"); + + $self->blocking(0) if defined $blocking && !$blocking; + return $self; +} + +sub configure_SSL { + my ($self, $arg_hash) = @_; + + my $is_server = $arg_hash->{'SSL_server'} || $arg_hash->{'Listen'} || 0; + + my %default_args = ( + Proto => 'tcp', + SSL_server => $is_server, + SSL_use_cert => $is_server, + SSL_check_crl => 0, + SSL_version => 'sslv23', + SSL_verify_mode => SSL_VERIFY_NONE, + SSL_verify_callback => undef, + SSL_verifycn_scheme => undef, # don't verify cn + SSL_verifycn_name => undef, # use from PeerAddr/PeerHost + ); + + # common problem forgetting SSL_use_cert + # if client cert is given but SSL_use_cert undef assume that it + # should be set + if ( ! $is_server && ! defined $arg_hash->{SSL_use_cert} + && ( grep { $arg_hash->{$_} } qw(SSL_cert SSL_cert_file)) + && ( grep { $arg_hash->{$_} } qw(SSL_key SSL_key_file)) ) { + $arg_hash->{SSL_use_cert} = 1 + } + + # SSL_key_file and SSL_cert_file will only be set in defaults if + # SSL_key|SSL_key_file resp SSL_cert|SSL_cert_file are not set in + # $args_hash + foreach my $k (qw( key cert )) { + next if exists $arg_hash->{ "SSL_${k}" }; + next if exists $arg_hash->{ "SSL_${k}_file" }; + $default_args{ "SSL_${k}_file" } = $is_server + ? "certs/server-${k}.pem" + : "certs/client-${k}.pem"; + } + + # add only SSL_ca_* if not in args + if ( ! exists $arg_hash->{SSL_ca_file} && ! exists $arg_hash->{SSL_ca_path} ) { + if ( -f 'certs/my-ca.pem' ) { + $default_args{SSL_ca_file} = 'certs/my-ca.pem' + } elsif ( -d 'ca/' ) { + $default_args{SSL_ca_path} = 'ca/' + } + } + + #Replace nonexistent entries with defaults + %$arg_hash = ( %default_args, %$GLOBAL_CONTEXT_ARGS, %$arg_hash ); + + #Avoid passing undef arguments to Net::SSLeay + defined($arg_hash->{$_}) or delete($arg_hash->{$_}) foreach (keys %$arg_hash); + + my $vcn_scheme = delete $arg_hash->{SSL_verifycn_scheme}; + if ( $vcn_scheme && $vcn_scheme ne 'none' ) { + # don't access ${*self} inside callback - this seems to create + # circular references from the ssl object to the context and back + + # use SSL_verifycn_name or determine from PeerAddr + my $host = $arg_hash->{SSL_verifycn_name}; + if (not defined($host)) { + if ( $host = $arg_hash->{PeerAddr} || $arg_hash->{PeerHost} ) { + $host =~s{:[a-zA-Z0-9_\-]+$}{}; + } + } + $host ||= ref($vcn_scheme) && $vcn_scheme->{callback} && 'unknown'; + $host or return $self->error( "Cannot determine peer hostname for verification" ); + + my $vcb = $arg_hash->{SSL_verify_callback}; + $arg_hash->{SSL_verify_callback} = sub { + my ($ok,$ctx_store,$certname,$error,$cert) = @_; + $ok = $vcb->($ok,$ctx_store,$certname,$error,$cert) if $vcb; + $ok or return; + my $depth = Net::SSLeay::X509_STORE_CTX_get_error_depth($ctx_store); + return $ok if $depth != 0; + + # verify name + my $rv = verify_hostname_of_cert( $host,$cert,$vcn_scheme ); + # just do some code here against optimization because x509 has no + # increased reference and CRYPTO_add is not available from Net::SSLeay + return $rv; + }; + } + + ${*$self}{'_SSL_arguments'} = $arg_hash; + ${*$self}{'_SSL_ctx'} = IO::Socket::SSL::SSL_Context->new($arg_hash) || return; + ${*$self}{'_SSL_opened'} = 1 if $is_server; + + return $self; +} + + +sub _set_rw_error { + my ($self,$ssl,$rv) = @_; + my $err = Net::SSLeay::get_error($ssl,$rv); + $SSL_ERROR = + $err == Net::SSLeay::ERROR_WANT_READ() ? SSL_WANT_READ : + $err == Net::SSLeay::ERROR_WANT_WRITE() ? SSL_WANT_WRITE : + return; + $! ||= EAGAIN; + ${*$self}{'_SSL_last_err'} = $SSL_ERROR if ref($self); + return 1; +} + + +#Call to connect occurs when a new client socket is made using +#IO::Socket::INET +sub connect { + my $self = shift || return _invalid_object(); + return $self if ${*$self}{'_SSL_opened'}; # already connected + + if ( ! ${*$self}{'_SSL_opening'} ) { + # call SUPER::connect if the underlying socket is not connected + # if this fails this might not be an error (e.g. if $! = EINPROGRESS + # and socket is nonblocking this is normal), so keep any error + # handling to the client + DEBUG(2, 'socket not yet connected' ); + $self->SUPER::connect(@_) || return; + DEBUG(2,'socket connected' ); + } + return $self->connect_SSL; +} + + +sub connect_SSL { + my $self = shift; + my $args = @_>1 ? {@_}: $_[0]||{}; + + my ($ssl,$ctx); + if ( ! ${*$self}{'_SSL_opening'} ) { + # start ssl connection + DEBUG(2,'ssl handshake not started' ); + ${*$self}{'_SSL_opening'} = 1; + my $arg_hash = ${*$self}{'_SSL_arguments'}; + + my $fileno = ${*$self}{'_SSL_fileno'} = fileno($self); + return $self->error("Socket has no fileno") unless (defined $fileno); + + $ctx = ${*$self}{'_SSL_ctx'}; # Reference to real context + $ssl = ${*$self}{'_SSL_object'} = Net::SSLeay::new($ctx->{context}) + || return $self->error("SSL structure creation failed"); + + Net::SSLeay::set_fd($ssl, $fileno) + || return $self->error("SSL filehandle association failed"); + + if ( my $cl = $arg_hash->{SSL_cipher_list} ) { + Net::SSLeay::set_cipher_list($ssl, $cl ) + || return $self->error("Failed to set SSL cipher list"); + } + + $arg_hash->{PeerAddr} || $self->_update_peer; + my $session = $ctx->session_cache( $arg_hash->{PeerAddr}, $arg_hash->{PeerPort} ); + Net::SSLeay::set_session($ssl, $session) if ($session); + } + + $ssl ||= ${*$self}{'_SSL_object'}; + + $SSL_ERROR = undef; + my $timeout = exists $args->{Timeout} + ? $args->{Timeout} + : ${*$self}{io_socket_timeout}; # from IO::Socket + if ( defined($timeout) && $timeout>0 && $self->blocking(0) ) { + DEBUG(2, "set socket to non-blocking to enforce timeout=$timeout" ); + # timeout was given and socket was blocking + # enforce timeout with now non-blocking socket + } else { + # timeout does not apply because invalid or socket non-blocking + $timeout = undef; + } + + my $start = defined($timeout) && time(); + for my $dummy (1) { + #DEBUG( 'calling ssleay::connect' ); + my $rv = Net::SSLeay::connect($ssl); + DEBUG( 3,"Net::SSLeay::connect -> $rv" ); + if ( $rv < 0 ) { + unless ( $self->_set_rw_error( $ssl,$rv )) { + $self->error("SSL connect attempt failed with unknown error"); + delete ${*$self}{'_SSL_opening'}; + ${*$self}{'_SSL_opened'} = -1; + DEBUG(1, "fatal SSL error: $SSL_ERROR" ); + return $self->fatal_ssl_error(); + } + + DEBUG(2,'ssl handshake in progress' ); + # connect failed because handshake needs to be completed + # if socket was non-blocking or no timeout was given return with this error + return if ! defined($timeout); + + # wait until socket is readable or writable + my $rv; + if ( $timeout>0 ) { + my $vec = ''; + vec($vec,$self->fileno,1) = 1; + DEBUG(2, "waiting for fd to become ready: $SSL_ERROR" ); + $rv = + $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) : + $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) : + undef; + } else { + DEBUG(2,"handshake failed because no more time" ); + $! = ETIMEDOUT + } + if ( ! $rv ) { + DEBUG(2,"handshake failed because socket did not became ready" ); + # failed because of timeout, return + $! ||= ETIMEDOUT; + delete ${*$self}{'_SSL_opening'}; + ${*$self}{'_SSL_opened'} = -1; + $self->blocking(1); # was blocking before + return + } + + # socket is ready, try non-blocking connect again after recomputing timeout + DEBUG(2,"socket ready, retrying connect" ); + my $now = time(); + $timeout -= $now - $start; + $start = $now; + redo; + + } elsif ( $rv == 0 ) { + delete ${*$self}{'_SSL_opening'}; + DEBUG(2,"connection failed - connect returned 0" ); + $self->error("SSL connect attempt failed because of handshake problems" ); + ${*$self}{'_SSL_opened'} = -1; + return $self->fatal_ssl_error(); + } + } + + DEBUG(2,'ssl handshake done' ); + # ssl connect successful + delete ${*$self}{'_SSL_opening'}; + ${*$self}{'_SSL_opened'}=1; + $self->blocking(1) if defined($timeout); # was blocking before + + $ctx ||= ${*$self}{'_SSL_ctx'}; + if ( $ctx->has_session_cache ) { + my $arg_hash = ${*$self}{'_SSL_arguments'}; + $arg_hash->{PeerAddr} || $self->_update_peer; + my ($addr,$port) = ( $arg_hash->{PeerAddr}, $arg_hash->{PeerPort} ); + my $session = $ctx->session_cache( $addr,$port ); + $ctx->session_cache( $addr,$port, Net::SSLeay::get1_session($ssl) ) if !$session; + } + + tie *{$self}, "IO::Socket::SSL::SSL_HANDLE", $self; + + return $self; +} + +# called if PeerAddr is not set in ${*$self}{'_SSL_arguments'} +# this can be the case if start_SSL is called with a normal IO::Socket::INET +# so that PeerAddr|PeerPort are not set from args +sub _update_peer { + my $self = shift; + my $arg_hash = ${*$self}{'_SSL_arguments'}; + eval { + my ($port,$addr) = sockaddr_in( getpeername( $self )); + $arg_hash->{PeerAddr} = inet_ntoa( $addr ); + $arg_hash->{PeerPort} = $port; + } +} + +#Call to accept occurs when a new client connects to a server using +#IO::Socket::SSL +sub accept { + my $self = shift || return _invalid_object(); + my $class = shift || 'IO::Socket::SSL'; + + my $socket = ${*$self}{'_SSL_opening'}; + if ( ! $socket ) { + # underlying socket not done + DEBUG(2,'no socket yet' ); + $socket = $self->SUPER::accept($class) || return; + DEBUG(2,'accept created normal socket '.$socket ); + } + + $self->accept_SSL($socket) || return; + DEBUG(2,'accept_SSL ok' ); + + return wantarray ? ($socket, getpeername($socket) ) : $socket; +} + +sub accept_SSL { + my $self = shift; + my $socket = ( @_ && UNIVERSAL::isa( $_[0], 'IO::Handle' )) ? shift : $self; + my $args = @_>1 ? {@_}: $_[0]||{}; + + my $ssl; + if ( ! ${*$self}{'_SSL_opening'} ) { + DEBUG(2,'starting sslifying' ); + ${*$self}{'_SSL_opening'} = $socket; + my $arg_hash = ${*$self}{'_SSL_arguments'}; + ${*$socket}{'_SSL_arguments'} = { %$arg_hash, SSL_server => 0 }; + my $ctx = ${*$socket}{'_SSL_ctx'} = ${*$self}{'_SSL_ctx'}; + + my $fileno = ${*$socket}{'_SSL_fileno'} = fileno($socket); + return $socket->error("Socket has no fileno") unless (defined $fileno); + + $ssl = ${*$socket}{'_SSL_object'} = Net::SSLeay::new($ctx->{context}) + || return $socket->error("SSL structure creation failed"); + + Net::SSLeay::set_fd($ssl, $fileno) + || return $socket->error("SSL filehandle association failed"); + + if ( my $cl = $arg_hash->{SSL_cipher_list} ) { + Net::SSLeay::set_cipher_list($ssl, $cl ) + || return $socket->error("Failed to set SSL cipher list"); + } + } + + $ssl ||= ${*$socket}{'_SSL_object'}; + + $SSL_ERROR = undef; + #DEBUG(2,'calling ssleay::accept' ); + + my $timeout = exists $args->{Timeout} + ? $args->{Timeout} + : ${*$self}{io_socket_timeout}; # from IO::Socket + if ( defined($timeout) && $timeout>0 && $socket->blocking(0) ) { + # timeout was given and socket was blocking + # enforce timeout with now non-blocking socket + } else { + # timeout does not apply because invalid or socket non-blocking + $timeout = undef; + } + + my $start = defined($timeout) && time(); + for my $dummy (1) { + my $rv = Net::SSLeay::accept($ssl); + DEBUG(3, "Net::SSLeay::accept -> $rv" ); + if ( $rv < 0 ) { + unless ( $socket->_set_rw_error( $ssl,$rv )) { + $socket->error("SSL accept attempt failed with unknown error"); + delete ${*$self}{'_SSL_opening'}; + ${*$socket}{'_SSL_opened'} = -1; + return $socket->fatal_ssl_error(); + } + + # accept failed because handshake needs to be completed + # if socket was non-blocking or no timeout was given return with this error + return if ! defined($timeout); + + # wait until socket is readable or writable + my $rv; + if ( $timeout>0 ) { + my $vec = ''; + vec($vec,$socket->fileno,1) = 1; + $rv = + $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) : + $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) : + undef; + } else { + $! = ETIMEDOUT + } + if ( ! $rv ) { + # failed because of timeout, return + $! ||= ETIMEDOUT; + delete ${*$self}{'_SSL_opening'}; + ${*$socket}{'_SSL_opened'} = -1; + $socket->blocking(1); # was blocking before + return + } + + # socket is ready, try non-blocking accept again after recomputing timeout + my $now = time(); + $timeout -= $now - $start; + $start = $now; + redo; + + } elsif ( $rv == 0 ) { + $socket->error("SSL connect accept failed because of handshake problems" ); + delete ${*$self}{'_SSL_opening'}; + ${*$socket}{'_SSL_opened'} = -1; + return $socket->fatal_ssl_error(); + } + } + + DEBUG(2,'handshake done, socket ready' ); + # socket opened + delete ${*$self}{'_SSL_opening'}; + ${*$socket}{'_SSL_opened'} = 1; + $socket->blocking(1) if defined($timeout); # was blocking before + + tie *{$socket}, "IO::Socket::SSL::SSL_HANDLE", $socket; + + return $socket; +} + + +####### I/O subroutines ######################## + +sub generic_read { + my ($self, $read_func, undef, $length, $offset) = @_; + my $ssl = $self->_get_ssl_object || return; + my $buffer=\$_[2]; + + $SSL_ERROR = undef; + my $data = $read_func->($ssl, $length); + if ( !defined($data)) { + $self->_set_rw_error( $ssl,-1 ) || $self->error("SSL read error"); + return; + } + + $length = length($data); + $$buffer = '' if !defined $$buffer; + $offset ||= 0; + if ($offset>length($$buffer)) { + $$buffer.="\0" x ($offset-length($$buffer)); #mimic behavior of read + } + + substr($$buffer, $offset, length($$buffer), $data); + return $length; +} + +sub read { + my $self = shift; + return $self->generic_read( + $self->blocking ? \&Net::SSLeay::ssl_read_all : \&Net::SSLeay::read, + @_ + ); +} + +# contrary to the behavior of read sysread can read partial data +sub sysread { + my $self = shift; + return $self->generic_read( \&Net::SSLeay::read, @_ ); +} + +sub peek { + my $self = shift; + if (Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x0090601f) { + return $self->generic_read(\&Net::SSLeay::peek, @_); + } else { + return $self->error("SSL_peek not supported for OpenSSL < v0.9.6a"); + } +} + + +sub generic_write { + my ($self, $write_all, undef, $length, $offset) = @_; + + my $ssl = $self->_get_ssl_object || return; + my $buffer = \$_[2]; + + my $buf_len = length($$buffer); + $length ||= $buf_len; + $offset ||= 0; + return $self->error("Invalid offset for SSL write") if ($offset>$buf_len); + return 0 if ($offset == $buf_len); + + $SSL_ERROR = undef; + my $written; + if ( $write_all ) { + my $data = $length < $buf_len-$offset ? substr($$buffer, $offset, $length) : $$buffer; + ($written, my $errs) = Net::SSLeay::ssl_write_all($ssl, $data); + # ssl_write_all returns number of bytes written + $written = undef if ! $written && $errs; + } else { + $written = Net::SSLeay::write_partial( $ssl,$offset,$length,$$buffer ); + # write_partial does SSL_write which returns -1 on error + $written = undef if $written < 0; + } + if ( !defined($written) ) { + $self->_set_rw_error( $ssl,-1 ) + || $self->error("SSL write error"); + return; + } + + return $written; +} + +# if socket is blocking write() should return only on error or +# if all data are written +sub write { + my $self = shift; + return $self->generic_write( scalar($self->blocking),@_ ); +} + +# contrary to write syswrite() returns already if only +# a part of the data is written +sub syswrite { + my $self = shift; + return $self->generic_write( 0,@_ ); +} + +sub print { + my $self = shift; + my $string = join(($, or ''), @_, ($\ or '')); + return $self->write( $string ); +} + +sub printf { + my ($self,$format) = (shift,shift); + return $self->write(sprintf($format, @_)); +} + +sub getc { + my ($self, $buffer) = (shift, undef); + return $buffer if $self->read($buffer, 1, 0); +} + +sub readline { + my $self = shift; + my $ssl = $self->_get_ssl_object || return; + + if (wantarray) { + my ($buf,$err) = Net::SSLeay::ssl_read_all($ssl); + return $self->error( "SSL read error" ) if $err; + if ( !defined($/) ) { + return $buf; + } elsif ( ref($/) ) { + my $size = ${$/}; + die "bad value in ref \$/: $size" unless $size>0; + return $buf=~m{\G(.{1,$size})}g; + } elsif ( $/ eq '' ) { + return $buf =~m{\G(.*\n\n+|.+)}g; + } else { + return $buf =~m{\G(.*$/|.+)}g; + } + } + + if ( !defined($/) ) { + my ($buf,$err) = Net::SSLeay::ssl_read_all($ssl); + return $self->error( "SSL read error" ) if $err; + return $buf; + } elsif ( ref($/) ) { + my $size = ${$/}; + die "bad value in ref \$/: $size" unless $size>0; + my ($buf,$err) = Net::SSLeay::ssl_read_all($ssl,$size); + return $self->error( "SSL read error" ) if $err; + return $buf; + } elsif ( $/ ne '' ) { + my $line = Net::SSLeay::ssl_read_until($ssl,$/); + return $self->error( "SSL read error" ) if $line eq ''; + return $line; + } else { + # $/ is '' + # ^.*?\n\n+, need peek to find all \n at the end + die "empty \$/ is not supported if I don't have peek" + if Net::SSLeay::OPENSSL_VERSION_NUMBER() < 0x0090601f; + + # find first occurence of \n\n + my $buf = ''; + my $eon = 0; + while (1) { + defined( Net::SSLeay::peek($ssl,1)) || last; # peek more, can block + my $pending = Net::SSLeay::pending($ssl); + $buf .= Net::SSLeay::peek( $ssl,$pending ); # will not block + if ( !$eon ) { + my $pos = index( $buf,"\n\n"); + next if $pos<0; # newlines not found + $eon = $pos+2; # pos after second newline + } + # $eon >= 2 == bytes incl last known \n + while ( index( $buf,"\n",$eon ) == $eon ) { + # the next char ist \n too + $eon++; + } + last if $eon < length($buf); # found last \n before end of buf + } + if ( $eon > 0 ) { + # found something + # readed peeked data until $eon from $ssl + return Net::SSLeay::ssl_read_all( $ssl,$eon ); + } else { + # found nothing + # return all what we have + if ( my $l = length($buf)) { + return Net::SSLeay::ssl_read_all( $ssl,$l ); + } else { + return $self->error( "SSL read error" ); + } + } + } +} + +sub close { + my $self = shift || return _invalid_object(); + my $close_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; + + return if ! $self->stop_SSL( + SSL_fast_shutdown => 1, + %$close_args, + _SSL_ioclass_downgrade => 0, + ); + + if ( ! $close_args->{_SSL_in_DESTROY} ) { + untie( *$self ); + return $self->SUPER::close; + } + return 1; +} + +sub stop_SSL { + my $self = shift || return _invalid_object(); + my $stop_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; + return $self->error("SSL object not open") + if ! ${*$self}{'_SSL_opened'}; + + if (my $ssl = ${*$self}{'_SSL_object'}) { + my $shutdown_done; + if ( $stop_args->{SSL_no_shutdown} ) { + $shutdown_done = 1; + } else { + my $fast = $stop_args->{SSL_fast_shutdown}; + my $status = Net::SSLeay::get_shutdown($ssl); + if ( $status == SSL_RECEIVED_SHUTDOWN + || ( $status != 0 && $fast )) { + # shutdown done + $shutdown_done = 1; + } else { + # need to initiate/continue shutdown + local $SIG{PIPE} = sub{}; + for my $try (1,2 ) { + my $rv = Net::SSLeay::shutdown($ssl); + if ( $rv < 0 ) { + # non-blocking socket? + $self->_set_rw_error( $ssl,$rv ); + # need to try again + return; + } elsif ( $rv + || ( $rv == 0 && $fast )) { + # shutdown finished + $shutdown_done = 1; + last; + } else { + # shutdown partly finished (e.g. one direction) + # call again + } + } + } + } + + return if ! $shutdown_done; + Net::SSLeay::free($ssl); + delete ${*$self}{_SSL_object}; + } + + if ($stop_args->{'SSL_ctx_free'}) { + my $ctx = delete ${*$self}{'_SSL_ctx'}; + $ctx && $ctx->DESTROY(); + } + + if (my $cert = delete ${*$self}{'_SSL_certificate'}) { + Net::SSLeay::X509_free($cert); + } + + ${*$self}{'_SSL_opened'} = 0; + + if ( ! $stop_args->{_SSL_in_DESTROY} ) { + + my $downgrade = $stop_args->{_SSL_ioclass_downgrade}; + if ( $downgrade || ! defined $downgrade ) { + # rebless to original class from start_SSL + if ( my $orig_class = delete ${*$self}{'_SSL_ioclass_upgraded'} ) { + bless $self,$orig_class; + untie(*$self); + # FIXME: if original class was tied too we need to restore the tie + } + # remove all _SSL related from *$self + my @sslkeys = grep { m{^_?SSL_} } keys %{*$self}; + delete @{*$self}{@sslkeys} if @sslkeys; + } + } + return 1; +} + + +sub kill_socket { + my $self = shift; + shutdown($self, 2); + $self->close(SSL_no_shutdown => 1) if ${*$self}{'_SSL_opened'}; + delete(${*$self}{'_SSL_ctx'}); + return; +} + +sub fileno { + my $self = shift; + my $fn = ${*$self}{'_SSL_fileno'}; + return defined($fn) ? $fn : $self->SUPER::fileno(); +} + + +####### IO::Socket::SSL specific functions ####### +# _get_ssl_object is for internal use ONLY! +sub _get_ssl_object { + my $self = shift; + my $ssl = ${*$self}{'_SSL_object'}; + return IO::Socket::SSL->error("Undefined SSL object") unless($ssl); + return $ssl; +} + +# default error for undefined arguments +sub _invalid_object { + return IO::Socket::SSL->error("Undefined IO::Socket::SSL object"); +} + + +sub pending { + my $ssl = shift()->_get_ssl_object || return; + return Net::SSLeay::pending($ssl); +} + +sub start_SSL { + my ($class,$socket) = (shift,shift); + return $class->error("Not a socket") unless(ref($socket)); + my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; + my %to = exists $arg_hash->{Timeout} ? ( Timeout => delete $arg_hash->{Timeout} ) :(); + my $original_class = ref($socket); + my $original_fileno = (UNIVERSAL::can($socket, "fileno")) + ? $socket->fileno : CORE::fileno($socket); + return $class->error("Socket has no fileno") unless defined $original_fileno; + + bless $socket, $class; + $socket->configure_SSL($arg_hash) or bless($socket, $original_class) && return; + + ${*$socket}{'_SSL_fileno'} = $original_fileno; + ${*$socket}{'_SSL_ioclass_upgraded'} = $original_class; + + my $start_handshake = $arg_hash->{SSL_startHandshake}; + if ( ! defined($start_handshake) || $start_handshake ) { + # if we have no callback force blocking mode + DEBUG(2, "start handshake" ); + my $blocking = $socket->blocking(1); + my $result = ${*$socket}{'_SSL_arguments'}{SSL_server} + ? $socket->accept_SSL(%to) + : $socket->connect_SSL(%to); + $socket->blocking(0) if !$blocking; + return $result ? $socket : (bless($socket, $original_class) && ()); + } else { + DEBUG(2, "dont start handshake: $socket" ); + return $socket; # just return upgraded socket + } + +} + +sub new_from_fd { + my ($class, $fd) = (shift,shift); + # Check for accidental inclusion of MODE in the argument list + if (length($_[0]) < 4) { + (my $mode = $_[0]) =~ tr/+<>//d; + shift unless length($mode); + } + my $handle = $ISA[0]->new_from_fd($fd, '+<') + || return($class->error("Could not create socket from file descriptor.")); + + # Annoying workaround for Perl 5.6.1 and below: + $handle = $ISA[0]->new_from_fd($handle, '+<'); + + return $class->start_SSL($handle, @_); +} + + +sub dump_peer_certificate { + my $ssl = shift()->_get_ssl_object || return; + return Net::SSLeay::dump_peer_certificate($ssl); +} + +{ + my %dispatcher = ( + issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) }, + subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) }, + ); + if ( $Net::SSLeay::VERSION >= 1.30 ) { + # I think X509_NAME_get_text_by_NID got added in 1.30 + $dispatcher{commonName} = sub { + my $cn = Net::SSLeay::X509_NAME_get_text_by_NID( + Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName); + $cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33 + $cn; + } + } else { + $dispatcher{commonName} = sub { + croak "you need at least Net::SSLeay version 1.30 for getting commonName" + } + } + + if ( $Net::SSLeay::VERSION >= 1.33 ) { + # X509_get_subjectAltNames did not really work before + $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) }; + } else { + $dispatcher{subjectAltNames} = sub { + croak "you need at least Net::SSLeay version 1.33 for getting subjectAltNames" + }; + } + + # alternative names + $dispatcher{authority} = $dispatcher{issuer}; + $dispatcher{owner} = $dispatcher{subject}; + $dispatcher{cn} = $dispatcher{commonName}; + + sub peer_certificate { + my ($self, $field) = @_; + my $ssl = $self->_get_ssl_object or return; + + my $cert = ${*$self}{_SSL_certificate} + ||= Net::SSLeay::get_peer_certificate($ssl) + or return $self->error("Could not retrieve peer certificate"); + + if ($field) { + my $sub = $dispatcher{$field} or croak + "invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ). + "\nMaybe you need to upgrade your Net::SSLeay"; + return $sub->($cert); + } else { + return $cert + } + } + + # known schemes, possible attributes are: + # - wildcards_in_alt (0, 'leftmost', 'anywhere') + # - wildcards_in_cn (0, 'leftmost', 'anywhere') + # - check_cn (0, 'always', 'when_only') + + my %scheme = ( + # rfc 4513 + ldap => { + wildcards_in_cn => 0, + wildcards_in_alt => 'leftmost', + check_cn => 'always', + }, + # rfc 2818 + http => { + wildcards_in_cn => 0, + wildcards_in_alt => 'anywhere', + check_cn => 'when_only', + }, + # rfc 3207 + # This is just a dumb guess + # RFC3207 itself just says, that the client should expect the + # domain name of the server in the certificate. It doesn't say + # anything about wildcards, so I forbid them. It doesn't say + # anything about alt names, but other documents show, that alt + # names should be possible. The check_cn value again is a guess. + # Fix the spec! + smtp => { + wildcards_in_cn => 0, + wildcards_in_alt => 0, + check_cn => 'always' + }, + none => {}, # do not check + ); + + $scheme{www} = $scheme{http}; # alias + $scheme{xmpp} = $scheme{http}; # rfc 3920 + $scheme{pop3} = $scheme{ldap}; # rfc 2595 + $scheme{imap} = $scheme{ldap}; # rfc 2595 + $scheme{acap} = $scheme{ldap}; # rfc 2595 + $scheme{nntp} = $scheme{ldap}; # rfc 4642 + $scheme{ftp} = $scheme{http}; # rfc 4217 + + # function to verify the hostname + # + # as every application protocol has its own rules to do this + # we provide some default rules as well as a user-defined + # callback + + sub verify_hostname_of_cert { + my $identity = shift; + my $cert = shift; + my $scheme = shift || 'none'; + if ( ! ref($scheme) ) { + DEBUG(3, "scheme=$scheme cert=$cert" ); + $scheme = $scheme{$scheme} or croak "scheme $scheme not defined"; + } + + # get data from certificate + my $commonName = $dispatcher{cn}->($cert); + my @altNames = $dispatcher{subjectAltNames}->($cert); + DEBUG(3,"identity=$identity cn=$commonName alt=@altNames" ); + + if ( my $sub = $scheme->{callback} ) { + # use custom callback + return $sub->($identity,$commonName,@altNames); + } + + # is the given hostname an IP address? Then we have to convert to network byte order [RFC791][RFC2460] + + my ($ip4,$ip6); + if ( $identity =~m{:} ) { + # no IPv4 or hostname have ':' in it, try IPv6. + # make sure that Socket6 was loaded properly + UNIVERSAL::can( __PACKAGE__, 'inet_pton' ) or croak + q[Looks like IPv6 address, make sure that Socket6 is loaded or make "use IO::Socket::SSL 'inet6']; + $ip6 = inet_pton( $identity ) or croak "'$identity' is not IPv6, but neither IPv4 nor hostname"; + } elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) { + # definitly no hostname, try IPv4 + $ip4 = inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname"; + } else { + # assume hostname, check for umlauts etc + if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) { + $identity =~m{\0} and croak("name '$identity' has \\0 byte"); + $identity = idn_to_ascii($identity) or + croak "Warning: Given name '$identity' could not be converted to IDNA!"; + } + } + + # do the actual verification + my $check_name = sub { + my ($name,$identity,$wtyp) = @_; + $wtyp ||= ''; + my $pattern; + ### IMPORTANT! + # we accept only a single wildcard and only for a single part of the FQDN + # e.g *.example.org does match www.example.org but not bla.www.example.org + # The RFCs are in this regard unspecific but we don't want to have to + # deal with certificates like *.com, *.co.uk or even * + # see also http://nils.toedtmann.net/pub/subjectAltName.txt + if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) { + $pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i; + } elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) { + $pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i; + } else { + $pattern = qr{^\Q$name\E$}i; + } + return $identity =~ $pattern; + }; + + my $alt_dnsNames = 0; + while (@altNames) { + my ($type, $name) = splice (@altNames, 0, 2); + if ( $type == GEN_IPADD ) { + # exakt match needed for IP + # $name is already packed format (inet_xton) + return 1 if + $ip6 ? $ip6 eq $name : + $ip4 ? $ip4 eq $name : + 0; + + } elsif ( $type == GEN_DNS ) { + $name =~s/\s+$//; $name =~s/^\s+//; + $alt_dnsNames++; + $check_name->($name,$identity,$scheme->{wildcards_in_alt}) + and return 1; + } + } + + if ( $scheme->{check_cn} eq 'always' or + $scheme->{check_cn} eq 'when_only' and !$alt_dnsNames) { + $check_name->($commonName,$identity,$scheme->{wildcards_in_cn}) + and return 1; + } + + return 0; # no match + } +} + +sub verify_hostname { + my $self = shift; + my $host = shift; + my $cert = $self->peer_certificate; + return verify_hostname_of_cert( $host,$cert,@_ ); +} + + +sub get_cipher { + my $ssl = shift()->_get_ssl_object || return; + return Net::SSLeay::get_cipher($ssl); +} + +sub errstr { + my $self = shift; + return ((ref($self) ? ${*$self}{'_SSL_last_err'} : $SSL_ERROR) or ''); +} + +sub fatal_ssl_error { + my $self = shift; + my $error_trap = ${*$self}{'_SSL_arguments'}->{'SSL_error_trap'}; + $@ = $self->errstr; + if (defined $error_trap and ref($error_trap) eq 'CODE') { + $error_trap->($self, $self->errstr()."\n".$self->get_ssleay_error()); + } else { + $self->kill_socket; + } + return; +} + +sub get_ssleay_error { + #Net::SSLeay will print out the errors itself unless we explicitly + #undefine $Net::SSLeay::trace while running print_errs() + local $Net::SSLeay::trace; + return Net::SSLeay::print_errs('SSL error: ') || ''; +} + +sub error { + my ($self, $error, $destroy_socket) = @_; + $error .= Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()); + DEBUG(2, $error."\n".$self->get_ssleay_error()); + $SSL_ERROR = dualvar( -1, $error ); + ${*$self}{'_SSL_last_err'} = $SSL_ERROR if (ref($self)); + return; +} + + +sub DESTROY { + my $self = shift || return; + $self->close(_SSL_in_DESTROY => 1, SSL_no_shutdown => 1) + if ${*$self}{'_SSL_opened'}; + delete(${*$self}{'_SSL_ctx'}); +} + + +#######Extra Backwards Compatibility Functionality####### +sub socket_to_SSL { IO::Socket::SSL->start_SSL(@_); } +sub socketToSSL { IO::Socket::SSL->start_SSL(@_); } + +sub issuer_name { return(shift()->peer_certificate("issuer")) } +sub subject_name { return(shift()->peer_certificate("subject")) } +sub get_peer_certificate { return shift() } + +sub context_init { + return($GLOBAL_CONTEXT_ARGS = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}); +} + +sub set_default_context { + $GLOBAL_CONTEXT_ARGS->{'SSL_reuse_ctx'} = shift; +} + +sub set_default_session_cache { + $GLOBAL_CONTEXT_ARGS->{SSL_session_cache} = shift; +} + +sub set_ctx_defaults { + my %args = @_; + while ( my ($k,$v) = each %args ) { + $k =~s{^(SSL_)?}{SSL_}; + $GLOBAL_CONTEXT_ARGS->{$k} = $v; + } +} + + +sub opened { + my $self = shift; + return IO::Handle::opened($self) && ${*$self}{'_SSL_opened'}; +} + +sub opening { + my $self = shift; + return ${*$self}{'_SSL_opening'}; +} + +sub want_read { shift->errstr == SSL_WANT_READ } +sub want_write { shift->errstr == SSL_WANT_WRITE } + + +#Redundant IO::Handle functionality +sub getline { return(scalar shift->readline()) } +sub getlines { + return(shift->readline()) if wantarray(); + croak("Use of getlines() not allowed in scalar context"); +} + +#Useless IO::Handle functionality +sub truncate { croak("Use of truncate() not allowed with SSL") } +sub stat { croak("Use of stat() not allowed with SSL" ) } +sub setbuf { croak("Use of setbuf() not allowed with SSL" ) } +sub setvbuf { croak("Use of setvbuf() not allowed with SSL" ) } +sub fdopen { croak("Use of fdopen() not allowed with SSL" ) } + +#Unsupported socket functionality +sub ungetc { croak("Use of ungetc() not implemented in IO::Socket::SSL") } +sub send { croak("Use of send() not implemented in IO::Socket::SSL; use print/printf/syswrite instead") } +sub recv { croak("Use of recv() not implemented in IO::Socket::SSL; use read/sysread instead") } + +package IO::Socket::SSL::SSL_HANDLE; +use strict; +use vars qw($HAVE_WEAKREF); +use Errno 'EBADF'; + +BEGIN { + local ($@, $SIG{__DIE__}); + + #Use Scalar::Util or WeakRef if possible: + eval "use Scalar::Util qw(weaken isweak); 1" or + eval "use WeakRef"; + $HAVE_WEAKREF = $@ ? 0 : 1; +} + + +sub TIEHANDLE { + my ($class, $handle) = @_; + weaken($handle) if $HAVE_WEAKREF; + bless \$handle, $class; +} + +sub READ { ${shift()}->sysread(@_) } +sub READLINE { ${shift()}->readline(@_) } +sub GETC { ${shift()}->getc(@_) } + +sub PRINT { ${shift()}->print(@_) } +sub PRINTF { ${shift()}->printf(@_) } +sub WRITE { ${shift()}->syswrite(@_) } + +sub FILENO { ${shift()}->fileno(@_) } + +sub TELL { $! = EBADF; return -1 } +sub BINMODE { return 0 } # not perfect, but better than not implementing the method + +sub CLOSE { #<---- Do not change this function! + my $ssl = ${$_[0]}; + local @_; + $ssl->close(); +} + + +package IO::Socket::SSL::SSL_Context; +use Carp; +use strict; + +my %CTX_CREATED_IN_THIS_THREAD; +*DEBUG = *IO::Socket::SSL::DEBUG; + +# should be better taken from Net::SSLeay, but they are not (yet) defined there +use constant SSL_MODE_ENABLE_PARTIAL_WRITE => 1; +use constant SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER => 2; + + +# Note that the final object will actually be a reference to the scalar +# (C-style pointer) returned by Net::SSLeay::CTX_*_new() so that +# it can be blessed. +sub new { + my $class = shift; + #DEBUG( "$class @_" ); + my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; + + my $ctx_object = $arg_hash->{'SSL_reuse_ctx'}; + if ($ctx_object) { + return $ctx_object if ($ctx_object->isa('IO::Socket::SSL::SSL_Context') and + $ctx_object->{context}); + + # The following "double entendre" applies only if someone passed + # in an IO::Socket::SSL object instead of an actual context. + return $ctx_object if ($ctx_object = ${*$ctx_object}{'_SSL_ctx'}); + } + + my $ctx; + foreach ($arg_hash->{'SSL_version'}) { + $ctx = /^sslv2$/i ? Net::SSLeay::CTX_v2_new() : + /^sslv3$/i ? Net::SSLeay::CTX_v3_new() : + /^tlsv1$/i ? Net::SSLeay::CTX_tlsv1_new() : + Net::SSLeay::CTX_new(); + } + + $ctx || return IO::Socket::SSL->error("SSL Context init failed"); + + Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL()); + + # SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER makes syswrite return if at least one + # buffer was written and not block for the rest + # SSL_MODE_ENABLE_PARTIAL_WRITE can be necessary for non-blocking because we + # cannot guarantee, that the location of the buffer stays constant + Net::SSLeay::CTX_set_mode( $ctx, + SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER|SSL_MODE_ENABLE_PARTIAL_WRITE); + + + my $verify_mode = $arg_hash->{SSL_verify_mode}; + if ( $verify_mode != Net::SSLeay::VERIFY_NONE() and + ! Net::SSLeay::CTX_load_verify_locations( + $ctx, $arg_hash->{SSL_ca_file} || '',$arg_hash->{SSL_ca_path} || '') ) { + if ( ! $arg_hash->{SSL_ca_file} && ! $arg_hash->{SSL_ca_path} ) { + carp("No certificate verification because neither SSL_ca_file nor SSL_ca_path known"); + $verify_mode = Net::SSLeay::VERIFY_NONE(); + } else { + return IO::Socket::SSL->error("Invalid certificate authority locations"); + } + } + + if ($arg_hash->{'SSL_check_crl'}) { + if (Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x0090702f) { + Net::SSLeay::X509_STORE_set_flags( + Net::SSLeay::CTX_get_cert_store($ctx), + Net::SSLeay::X509_V_FLAG_CRL_CHECK() + ); + if ($arg_hash->{'SSL_crl_file'}) { + my $bio = Net::SSLeay::BIO_new_file($arg_hash->{'SSL_crl_file'}, 'r'); + my $crl = Net::SSLeay::PEM_read_bio_X509_CRL($bio); + if ( $crl ) { + Net::SSLeay::X509_STORE_add_crl(Net::SSLeay::CTX_get_cert_store($ctx), $crl); + } else { + return IO::Socket::SSL->error("Invalid certificate revocation list"); + } + } + } else { + return IO::Socket::SSL->error("CRL not supported for OpenSSL < v0.9.7b"); + } + } + + if ($arg_hash->{'SSL_server'} || $arg_hash->{'SSL_use_cert'}) { + my $filetype = Net::SSLeay::FILETYPE_PEM(); + + if ($arg_hash->{'SSL_passwd_cb'}) { + Net::SSLeay::CTX_set_default_passwd_cb($ctx, $arg_hash->{'SSL_passwd_cb'}); + } + + if ( my $pkey= $arg_hash->{SSL_key} ) { + # binary, e.g. EVP_PKEY* + Net::SSLeay::CTX_use_PrivateKey($ctx, $pkey) + || return IO::Socket::SSL->error("Failed to use Private Key"); + } elsif ( my $f = $arg_hash->{SSL_key_file} ) { + Net::SSLeay::CTX_use_PrivateKey_file($ctx, $f, $filetype) + || return IO::Socket::SSL->error("Failed to open Private Key"); + } + + if ( my $x509 = $arg_hash->{SSL_cert} ) { + # binary, e.g. X509* + # we habe either a single certificate or a list with + # a chain of certificates + my @x509 = ref($x509) eq 'ARRAY' ? @$x509: ($x509); + my $cert = shift @x509; + Net::SSLeay::CTX_use_certificate( $ctx,$cert ) + || return IO::Socket::SSL->error("Failed to use Certificate"); + foreach my $ca (@x509) { + Net::SSLeay::CTX_add_extra_chain_cert( $ctx,$ca ) + || return IO::Socket::SSL->error("Failed to use Certificate"); + } + } elsif ( my $f = $arg_hash->{SSL_cert_file} ) { + Net::SSLeay::CTX_use_certificate_chain_file($ctx, $f) + || return IO::Socket::SSL->error("Failed to open Certificate"); + } + + if ( my $dh = $arg_hash->{SSL_dh} ) { + # binary, e.g. DH* + Net::SSLeay::CTX_set_tmp_dh( $ctx,$dh ) + || return IO::Socket::SSL->error( "Failed to set DH from SSL_dh" ); + } elsif ( my $f = $arg_hash->{SSL_dh_file} ) { + my $bio = Net::SSLeay::BIO_new_file( $f,'r' ) + || return IO::Socket::SSL->error( "Failed to open DH file $f" ); + my $dh = Net::SSLeay::PEM_read_bio_DHparams($bio); + Net::SSLeay::BIO_free($bio); + $dh || return IO::Socket::SSL->error( "Failed to read PEM for DH from $f - wrong format?" ); + my $rv = Net::SSLeay::CTX_set_tmp_dh( $ctx,$dh ); + Net::SSLeay::DH_free( $dh ); + $rv || return IO::Socket::SSL->error( "Failed to set DH from $f" ); + } + } + + my $verify_cb = $arg_hash->{SSL_verify_callback}; + my $verify_callback = $verify_cb && sub { + my ($ok, $ctx_store) = @_; + my ($certname,$cert,$error); + if ($ctx_store) { + $cert = Net::SSLeay::X509_STORE_CTX_get_current_cert($ctx_store); + $error = Net::SSLeay::X509_STORE_CTX_get_error($ctx_store); + $certname = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_issuer_name($cert)). + Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert)); + $error &&= Net::SSLeay::ERR_error_string($error); + } + DEBUG(3, "ok=$ok cert=$cert" ); + return $verify_cb->($ok,$ctx_store,$certname,$error,$cert); + }; + + Net::SSLeay::CTX_set_verify($ctx, $verify_mode, $verify_callback); + + $ctx_object = { context => $ctx }; + $ctx_object->{has_verifycb} = 1 if $verify_callback; + DEBUG(3, "new ctx $ctx" ); + $CTX_CREATED_IN_THIS_THREAD{$ctx} = 1; + + if ( my $cache = $arg_hash->{SSL_session_cache} ) { + # use predefined cache + $ctx_object->{session_cache} = $cache + } elsif ( my $size = $arg_hash->{SSL_session_cache_size}) { + return IO::Socket::SSL->error("Session caches not supported for Net::SSLeay < v1.26") + if $Net::SSLeay::VERSION < 1.26; + $ctx_object->{session_cache} = IO::Socket::SSL::Session_Cache->new( $size ); + } + + return bless $ctx_object, $class; +} + + +sub session_cache { + my $ctx = shift; + my $cache = $ctx->{'session_cache'} || return; + my ($addr,$port,$session) = @_; + $port ||= $addr =~s{:(\w+)$}{} && $1; # host:port + my $key = "$addr:$port"; + return defined($session) + ? $cache->add_session($key, $session) + : $cache->get_session($key); +} + +sub has_session_cache { + return defined shift->{session_cache}; +} + + +sub CLONE { %CTX_CREATED_IN_THIS_THREAD = (); } +sub DESTROY { + my $self = shift; + if ( my $ctx = $self->{context} ) { + DEBUG( 3,"free ctx $ctx open=".join( " ",keys %CTX_CREATED_IN_THIS_THREAD )); + if ( %CTX_CREATED_IN_THIS_THREAD and + delete $CTX_CREATED_IN_THIS_THREAD{$ctx} ) { + # remove any verify callback for this context + if ( $self->{has_verifycb}) { + DEBUG( 3,"free ctx $ctx callback" ); + Net::SSLeay::CTX_set_verify($ctx, 0,undef); + } + DEBUG( 3,"OK free ctx $ctx" ); + Net::SSLeay::CTX_free($ctx); + } + } + delete(@{$self}{'context','session_cache'}); +} + +package IO::Socket::SSL::Session_Cache; +use strict; + +sub new { + my ($class, $size) = @_; + $size>0 or return; + return bless { _maxsize => $size }, $class; +} + + +sub get_session { + my ($self, $key) = @_; + my $session = $self->{$key} || return; + return $session->{session} if ($self->{'_head'} eq $session); + $session->{prev}->{next} = $session->{next}; + $session->{next}->{prev} = $session->{prev}; + $session->{next} = $self->{'_head'}; + $session->{prev} = $self->{'_head'}->{prev}; + $self->{'_head'}->{prev} = $self->{'_head'}->{prev}->{next} = $session; + $self->{'_head'} = $session; + return $session->{session}; +} + +sub add_session { + my ($self, $key, $val) = @_; + return if ($key eq '_maxsize' or $key eq '_head'); + + if ((keys %$self) > $self->{'_maxsize'} + 1) { + my $last = $self->{'_head'}->{prev}; + Net::SSLeay::SESSION_free($last->{session}); + delete($self->{$last->{key}}); + $self->{'_head'}->{prev} = $self->{'_head'}->{prev}->{prev}; + delete($self->{'_head'}) if ($self->{'_maxsize'} == 1); + } + + my $session = $self->{$key} = { session => $val, key => $key }; + + if ($self->{'_head'}) { + $session->{next} = $self->{'_head'}; + $session->{prev} = $self->{'_head'}->{prev}; + $self->{'_head'}->{prev}->{next} = $session; + $self->{'_head'}->{prev} = $session; + } else { + $session->{next} = $session->{prev} = $session; + } + $self->{'_head'} = $session; + return $session; +} + +sub DESTROY { + my $self = shift; + delete(@{$self}{'_head','_maxsize'}); + foreach my $key (keys %$self) { + Net::SSLeay::SESSION_free($self->{$key}->{session}); + } +} + + +1; + + +=head1 NAME + +IO::Socket::SSL -- Nearly transparent SSL encapsulation for IO::Socket::INET. + +=head1 SYNOPSIS + + use strict; + use IO::Socket::SSL; + + my $client = IO::Socket::SSL->new("www.example.com:https") + || warn "I encountered a problem: ".IO::Socket::SSL::errstr(); + $client->verify_hostname( 'www.example.com','http' ) + || die "hostname verification failed"; + + print $client "GET / HTTP/1.0\r\n\r\n"; + print <$client>; + + +=head1 DESCRIPTION + +This module is a true drop-in replacement for IO::Socket::INET that uses +SSL to encrypt data before it is transferred to a remote server or +client. IO::Socket::SSL supports all the extra features that one needs +to write a full-featured SSL client or server application: multiple SSL contexts, +cipher selection, certificate verification, and SSL version selection. As an +extra bonus, it works perfectly with mod_perl. + +If you have never used SSL before, you should read the appendix labelled 'Using SSL' +before attempting to use this module. + +If you have used this module before, read on, as versions 0.93 and above +have several changes from the previous IO::Socket::SSL versions (especially +see the note about return values). + +If you are using non-blocking sockets read on, as version 0.98 added better +support for non-blocking. + +If you are trying to use it with threads see the BUGS section. + +=head1 METHODS + +IO::Socket::SSL inherits its methods from IO::Socket::INET, overriding them +as necessary. If there is an SSL error, the method or operation will return an +empty list (false in all contexts). The methods that have changed from the +perspective of the user are re-documented here: + +=over 4 + +=item B<new(...)> + +Creates a new IO::Socket::SSL object. You may use all the friendly options +that came bundled with IO::Socket::INET, plus (optionally) the ones that follow: + +=over 2 + +=item SSL_version + +Sets the version of the SSL protocol used to transmit data. The default is SSLv2/3, +which auto-negotiates between SSLv2 and SSLv3. You may specify 'SSLv2', 'SSLv3', or +'TLSv1' (case-insensitive) if you do not want this behavior. + +=item SSL_cipher_list + +If this option is set the cipher list for the connection will be set to the +given value, e.g. something like 'ALL:!LOW:!EXP:!ADH'. Look into the OpenSSL +documentation (L<http://www.openssl.org/docs/apps/ciphers.html#CIPHER_STRINGS>) +for more details. +If this option is not used the openssl builtin default is used which is suitable +for most cases. + +=item SSL_use_cert + +If this is set, it forces IO::Socket::SSL to use a certificate and key, even if +you are setting up an SSL client. If this is set to 0 (the default), then you will +only need a certificate and key if you are setting up a server. + +SSL_use_cert will implicitly be set if SSL_server is set. +For convinience it is also set if it was not given but a cert was given for use +(SSL_cert_file or similar). + +=item SSL_server + +Use this, if the socket should be used as a server. +If this is not explicitly set it is assumed, if Listen with given when creating +the socket. + +=item SSL_key_file + +If your RSA private key is not in default place (F<certs/server-key.pem> for servers, +F<certs/client-key.pem> for clients), then this is the option that you would use to +specify a different location. Keys should be PEM formatted, and if they are +encrypted, you will be prompted to enter a password before the socket is formed +(unless you specified the SSL_passwd_cb option). + +=item SSL_key + +This is an EVP_PKEY* and can be used instead of SSL_key_file. +Useful if you don't have your key in a file but create it dynamically or get it from +a string (see openssl PEM_read_bio_PrivateKey etc for getting a EVP_PKEY* from +a string). + +=item SSL_cert_file + +If your SSL certificate is not in the default place (F<certs/server-cert.pem> for servers, +F<certs/client-cert.pem> for clients), then you should use this option to specify the +location of your certificate. Note that a key and certificate are only required for an +SSL server, so you do not need to bother with these trifling options should you be +setting up an unauthenticated client. + +=item SSL_cert + +This is an X509* or an array of X509*. +The first X509* is the internal representation of the certificate while the following +ones are extra certificates. Useful if you create your certificate dynamically (like +in a SSL intercepting proxy) or get it from a string (see openssl PEM_read_bio_X509 etc +for getting a X509* from a string). + +=item SSL_dh_file + +If you want Diffie-Hellman key exchange you need to supply a suitable file here +or use the SSL_dh parameter. See dhparam command in openssl for more information. + +=item SSL_dh + +Like SSL_dh_file, but instead of giving a file you use a preloaded or generated DH*. + +=item SSL_passwd_cb + +If your private key is encrypted, you might not want the default password prompt from +Net::SSLeay. This option takes a reference to a subroutine that should return the +password required to decrypt your private key. + +=item SSL_ca_file + +If you want to verify that the peer certificate has been signed by a reputable +certificate authority, then you should use this option to locate the file +containing the certificateZ<>(s) of the reputable certificate authorities if it is +not already in the file F<certs/my-ca.pem>. + +=item SSL_ca_path + +If you are unusually friendly with the OpenSSL documentation, you might have set +yourself up a directory containing several trusted certificates as separate files +as well as an index of the certificates. If you want to use that directory for +validation purposes, and that directory is not F<ca/>, then use this option to +point IO::Socket::SSL to the right place to look. + +=item SSL_verify_mode + +This option sets the verification mode for the peer certificate. The default +(0x00) does no authentication. You may combine 0x01 (verify peer), 0x02 (fail +verification if no peer certificate exists; ignored for clients), and 0x04 +(verify client once) to change the default. +See OpenSSL man page for SSL_CTX_set_verify for more information. + +=item SSL_verify_callback + +If you want to verify certificates yourself, you can pass a sub reference along +with this parameter to do so. When the callback is called, it will be passed: +1) a true/false value that indicates what OpenSSL thinks of the certificate, +2) a C-style memory address of the certificate store, +3) a string containing the certificate's issuer attributes and owner attributes, and +4) a string containing any errors encountered (0 if no errors). +The function should return 1 or 0, depending on whether it thinks the certificate +is valid or invalid. The default is to let OpenSSL do all of the busy work. + +=item SSL_verifycn_scheme + +Set the scheme used to automatically verify the hostname of the peer. +See the information about the verification schemes in B<verify_hostname>. +The default is undef, e.g. to not automatically verify the hostname. + +=item SSL_verifycn_name + +Set the name which is used in verification of hostname. If SSL_verifycn_scheme +is set and no SSL_verifycn_name is given it will try to use the PeerHost and +PeerAddr settings and fail if no name caan be determined. + +Using PeerHost or PeerAddr works only if you create the connection directly +with C<< IO::Socket::SSL->new >>, if an IO::Socket::INET object is upgraded +with B<start_SSL> the name has to be given in B<SSL_verifycn_name>. + +=item SSL_check_crl + +If you want to verify that the peer certificate has not been revoked +by the signing authority, set this value to true. OpenSSL will search +for the CRL in your SSL_ca_path, or use the file specified by +SSL_crl_file. See the Net::SSLeay documentation for more details. +Note that this functionality appears to be broken with OpenSSL < +v0.9.7b, so its use with lower versions will result in an error. + +=item SSL_crl_file + +If you want to specify the CRL file to be used, set this value to the +pathname to be used. This must be used in addition to setting +SSL_check_crl. + +=item SSL_reuse_ctx + +If you have already set the above options (SSL_version through SSL_check_crl; +this does not include SSL_cipher_list yet) for a previous instance of +IO::Socket::SSL, then you can reuse the SSL context of that instance by passing +it as the value for the SSL_reuse_ctx parameter. You may also create a +new instance of the IO::Socket::SSL::SSL_Context class, using any context options +that you desire without specifying connection options, and pass that here instead. + +If you use this option, all other context-related options that you pass +in the same call to new() will be ignored unless the context supplied was invalid. +Note that, contrary to versions of IO::Socket::SSL below v0.90, a global SSL context +will not be implicitly used unless you use the set_default_context() function. + +=item SSL_session_cache_size + +If you make repeated connections to the same host/port and the SSL renegotiation time +is an issue, you can turn on client-side session caching with this option by specifying a +positive cache size. For successive connections, pass the SSL_reuse_ctx option to +the new() calls (or use set_default_context()) to make use of the cached sessions. +The session cache size refers to the number of unique host/port pairs that can be +stored at one time; the oldest sessions in the cache will be removed if new ones are +added. + +=item SSL_session_cache + +Specifies session cache object which should be used instead of creating a new. +Overrules SSL_session_cache_size. +This option is useful if you want to reuse the cache, but not the rest of +the context. + +A session cache object can be created using +C<< IO::Socket::SSL::Session_Cache->new( cachesize ) >>. + +Use set_default_session_cache() to set a global cache object. + +=item SSL_error_trap + +When using the accept() or connect() methods, it may be the case that the +actual socket connection works but the SSL negotiation fails, as in the case of +an HTTP client connecting to an HTTPS server. Passing a subroutine ref attached +to this parameter allows you to gain control of the orphaned socket instead of having it +be closed forcibly. The subroutine, if called, will be passed two parameters: +a reference to the socket on which the SSL negotiation failed and and the full +text of the error message. + +=back + +=item B<close(...)> + +There are a number of nasty traps that lie in wait if you are not careful about using +close(). The first of these will bite you if you have been using shutdown() on your +sockets. Since the SSL protocol mandates that a SSL "close notify" message be +sent before the socket is closed, a shutdown() that closes the socket's write channel +will cause the close() call to hang. For a similar reason, if you try to close a +copy of a socket (as in a forking server) you will affect the original socket as well. +To get around these problems, call close with an object-oriented syntax +(e.g. $socket->close(SSL_no_shutdown => 1)) +and one or more of the following parameters: + +=over 2 + +=item SSL_no_shutdown + +If set to a true value, this option will make close() not use the SSL_shutdown() call +on the socket in question so that the close operation can complete without problems +if you have used shutdown() or are working on a copy of a socket. + +=item SSL_fast_shutdown + +If set to true only a unidirectional shutdown will be done, e.g. only the +close_notify (see SSL_shutdown(3)) will be called. Otherwise a bidrectional +shutdown will be done. If used within close() it defaults to true, if used +within stop_SSL() it defaults to false. + +=item SSL_ctx_free + +If you want to make sure that the SSL context of the socket is destroyed when +you close it, set this option to a true value. + +=back + +=item B<peek(...)> + +This function has exactly the same syntax as sysread(), and performs nearly the same +task (reading data from the socket) but will not advance the read position so +that successive calls to peek() with the same arguments will return the same results. +This function requires OpenSSL 0.9.6a or later to work. + + +=item B<pending()> + +This function will let you know how many bytes of data are immediately ready for reading +from the socket. This is especially handy if you are doing reads on a blocking socket +or just want to know if new data has been sent over the socket. + + +=item B<get_cipher()> + +Returns the string form of the cipher that the IO::Socket::SSL object is using. + +=item B<dump_peer_certificate()> + +Returns a parsable string with select fields from the peer SSL certificate. This +method directly returns the result of the dump_peer_certificate() method of Net::SSLeay. + +=item B<peer_certificate($field)> + +If a peer certificate exists, this function can retrieve values from it. +If no field is given the internal representation of certificate from Net::SSLeay is +returned. +The following fields can be queried: + +=over 8 + +=item authority (alias issuer) + +The certificate authority which signed the certificate. + +=item owner (alias subject) + +The owner of the certificate. + +=item commonName (alias cn) - only for Net::SSLeay version >=1.30 + +The common name, usually the server name for SSL certificates. + +=item subjectAltNames - only for Net::SSLeay version >=1.33 + +Alternative names for the subject, usually different names for the same +server, like example.org, example.com, *.example.com. + +It returns a list of (typ,value) with typ GEN_DNS, GEN_IPADD etc (these +constants are exported from IO::Socket::SSL). +See Net::SSLeay::X509_get_subjectAltNames. + +=back + +=item B<verify_hostname($hostname,$scheme)> + +This verifies the given hostname against the peer certificate using the +given scheme. Hostname is usually what you specify within the PeerAddr. + +Verification of hostname against a certificate is different between various +applications and RFCs. Some scheme allow wildcards for hostnames, some only +in subjectAltNames, and even their different wildcard schemes are possible. + +To ease the verification the following schemes are predefined: + +=over 8 + +=item ldap (rfc4513), pop3,imap,acap (rfc2995), nntp (rfc4642) + +Simple wildcards in subjectAltNames are possible, e.g. *.example.org matches +www.example.org but not lala.www.example.org. If nothing from subjectAltNames +match it checks against the common name, but there are no wildcards allowed. + +=item http (rfc2818), alias is www + +Extended wildcards in subjectAltNames are possible, e.g. *.example.org or +even www*.example.org. Wildcards in the common name are not allowed. The common +name will be only checked if no names are given in subjectAltNames. + +=item smtp (rfc3207) + +This RFC doesn't say much useful about the verification so it just assumes +that subjectAltNames are possible, but no wildcards are possible anywhere. + +=back + +The scheme can be given either by specifying the name for one of the above predefined +schemes, by using a callback (see below) or by using a hash which can have the +following keys and values: + +=over 8 + +=item check_cn: 0|'always'|'when_only' + +Determines if the common name gets checked. If 'always' it will always be checked +(like in ldap), if 'when_only' it will only be checked if no names are given in +subjectAltNames (like in http), for any other values the common name will not be checked. + +=item wildcards_in_alt: 0|'leftmost'|'anywhere' + +Determines if and where wildcards in subjectAltNames are possible. If 'leftmost' +only cases like *.example.org will be possible (like in ldap), for 'anywhere' +www*.example.org is possible too (like http), dangerous things like but www.*.org +or even '*' will not be allowed. + +=item wildcards_in_cn: 0|'leftmost'|'anywhere' + +Similar to wildcards_in_alt, but checks the common name. There is no predefined +scheme which allows wildcards in common names. + +=back + +If you give a subroutine for verification it will be called with the arguments +($hostname,$commonName,@subjectAltNames), where hostname is the name given for +verification, commonName is the result from peer_certificate('cn') and +subjectAltNames is the result from peer_certificate('subjectAltNames'). + +=item B<errstr()> + +Returns the last error (in string form) that occurred. If you do not have a real +object to perform this method on, call IO::Socket::SSL::errstr() instead. + +For read and write errors on non-blocking sockets, this method may include the string +C<SSL wants a read first!> or C<SSL wants a write first!> meaning that the other side +is expecting to read from or write to the socket and wants to be satisfied before you +get to do anything. But with version 0.98 you are better comparing the global exported +variable $SSL_ERROR against the exported symbols SSL_WANT_READ and SSL_WANT_WRITE. + +=item B<opened()> + +This returns false if the socket could not be opened, 1 if the socket could be opened +and the SSL handshake was successful done and -1 if the underlying IO::Handle is open, +but the SSL handshake failed. + +=item B<< IO::Socket::SSL->start_SSL($socket, ... ) >> + +This will convert a glob reference or a socket that you provide to an IO::Socket::SSL +object. You may also pass parameters to specify context or connection options as with +a call to new(). If you are using this function on an accept()ed socket, you must +set the parameter "SSL_server" to 1, i.e. IO::Socket::SSL->start_SSL($socket, SSL_server => 1). +If you have a class that inherits from IO::Socket::SSL and you want the $socket to be blessed +into your own class instead, use MyClass->start_SSL($socket) to achieve the desired effect. + +Note that if start_SSL() fails in SSL negotiation, $socket will remain blessed in its +original class. For non-blocking sockets you better just upgrade the socket to +IO::Socket::SSL and call accept_SSL or connect_SSL and the upgraded object. To +just upgrade the socket set B<SSL_startHandshake> explicitly to 0. If you call start_SSL +w/o this parameter it will revert to blocking behavior for accept_SSL and connect_SSL. + +If given the parameter "Timeout" it will stop if after the timeout no SSL connection +was established. This parameter is only used for blocking sockets, if it is not given the +default Timeout from the underlying IO::Socket will be used. + +=item B<stop_SSL(...)> + +This is the opposite of start_SSL(), e.g. it will shutdown the SSL connection +and return to the class before start_SSL(). It gets the same arguments as close(), +in fact close() calls stop_SSL() (but without downgrading the class). + +Will return true if it suceeded and undef if failed. This might be the case for +non-blocking sockets. In this case $! is set to EAGAIN and the ssl error to +SSL_WANT_READ or SSL_WANT_WRITE. In this case the call should be retried again with +the same arguments once the socket is ready is until it succeeds. + +=item B<< IO::Socket::SSL->new_from_fd($fd, ...) >> + +This will convert a socket identified via a file descriptor into an SSL socket. +Note that the argument list does not include a "MODE" argument; if you supply one, +it will be thoughtfully ignored (for compatibility with IO::Socket::INET). Instead, +a mode of '+<' is assumed, and the file descriptor passed must be able to handle such +I/O because the initial SSL handshake requires bidirectional communication. + +=item B<IO::Socket::SSL::set_default_context(...)> + +You may use this to make IO::Socket::SSL automatically re-use a given context (unless +specifically overridden in a call to new()). It accepts one argument, which should +be either an IO::Socket::SSL object or an IO::Socket::SSL::SSL_Context object. See +the SSL_reuse_ctx option of new() for more details. Note that this sets the default +context globally, so use with caution (esp. in mod_perl scripts). + +=item B<IO::Socket::SSL::set_default_session_cache(...)> + +You may use this to make IO::Socket::SSL automatically re-use a given session cache +(unless specifically overridden in a call to new()). It accepts one argument, which should +be an IO::Socket::SSL::Session_Cache object or similar (e.g something which implements +get_session and add_session like IO::Socket::SSL::Session_Cache does). +See the SSL_session_cache option of new() for more details. Note that this sets the default +cache globally, so use with caution. + +=item B<IO::Socket::SSL::set_ctx_defaults(%args)> + +With this function one can set defaults for all SSL_* parameter used for creation of +the context, like the SSL_verify* parameter. + +=over 8 + +=item mode - set default SSL_verify_mode + +=item callback - set default SSL_verify_callback + +=item scheme - set default SSL_verifycn_scheme + +=item name - set default SSL_verifycn_name + +If not given and scheme is hash reference with key callback it will be set to 'unknown' + +=back + +=back + +The following methods are unsupported (not to mention futile!) and IO::Socket::SSL +will emit a large CROAK() if you are silly enough to use them: + +=over 4 + +=item truncate + +=item stat + +=item ungetc + +=item setbuf + +=item setvbuf + +=item fdopen + +=item send/recv + +Note that send() and recv() cannot be reliably trapped by a tied filehandle (such as +that used by IO::Socket::SSL) and so may send unencrypted data over the socket. Object-oriented +calls to these functions will fail, telling you to use the print/printf/syswrite +and read/sysread families instead. + +=back + +=head1 IPv6 + +Support for IPv6 with IO::Socket::SSL is expected to work and basic testing is done. +If IO::Socket::INET6 is available it will automatically use it instead of +IO::Socket::INET4. + +Please be aware of the associated problems: If you give a name as a host and the +host resolves to both IPv6 and IPv4 it will try IPv6 first and if there is no IPv6 +connectivity it will fail. + +To avoid these problems you can either force IPv4 by specifying and AF_INET as the +Domain (this is per socket) or load IO::Socket::SSL with the option 'inet4' +(This is a global setting, e.g. affects all IO::Socket::SSL objects in the program). + +=head1 RETURN VALUES + +A few changes have gone into IO::Socket::SSL v0.93 and later with respect to +return values. The behavior on success remains unchanged, but for I<all> functions, +the return value on error is now an empty list. Therefore, the return value will be +false in all contexts, but those who have been using the return values as arguments +to subroutines (like C<mysub(IO::Socket::SSL(...)->new, ...)>) may run into problems. +The moral of the story: I<always> check the return values of these functions before +using them in any way that you consider meaningful. + + +=head1 DEBUGGING + +If you are having problems using IO::Socket::SSL despite the fact that can recite backwards +the section of this documentation labelled 'Using SSL', you should try enabling debugging. To +specify the debug level, pass 'debug#' (where # is a number from 0 to 3) to IO::Socket::SSL +when calling it. +The debug level will also be propagated to Net::SSLeay::trace, see also L<Net::SSLeay>: + +=over 4 + +=item use IO::Socket::SSL qw(debug0); + +No debugging (default). + +=item use IO::Socket::SSL qw(debug1); + +Print out errors from IO::Socket::SSL and ciphers from Net::SSLeay. + +=item use IO::Socket::SSL qw(debug2); + +Print also information about call flow from IO::Socket::SSL and progress +information from Net::SSLeay. + +=item use IO::Socket::SSL qw(debug3); + +Print also some data dumps from IO::Socket::SSL and from Net::SSLeay. + +=back + +=head1 EXAMPLES + +See the 'example' directory. + +=head1 BUGS + +IO::Socket::SSL is not threadsafe. +This is because IO::Socket::SSL is based on Net::SSLeay which +uses a global object to access some of the API of openssl +and is therefore not threadsafe. +It might probably work if you don't use SSL_verify_callback and +SSL_password_cb. + +IO::Socket::SSL does not work together with Storable::fd_retrieve/fd_store. +See BUGS file for more information and how to work around the problem. + +Non-blocking and timeouts (which are based on non-blocking) are not +supported on Win32, because the underlying IO::Socket::INET does not support +non-blocking on this platform. + +=head1 LIMITATIONS + +IO::Socket::SSL uses Net::SSLeay as the shiny interface to OpenSSL, which is +the shiny interface to the ugliness of SSL. As a result, you will need both Net::SSLeay +and OpenSSL on your computer before using this module. + +If you have Scalar::Util (standard with Perl 5.8.0 and above) or WeakRef, IO::Socket::SSL +sockets will auto-close when they go out of scope, just like IO::Socket::INET sockets. If +you do not have one of these modules, then IO::Socket::SSL sockets will stay open until the +program ends or you explicitly close them. This is due to the fact that a circular reference +is required to make IO::Socket::SSL sockets act simultaneously like objects and glob references. + +=head1 DEPRECATIONS + +The following functions are deprecated and are only retained for compatibility: + +=over 2 + +=item context_init() + +use the SSL_reuse_ctx option if you want to re-use a context + + +=item socketToSSL() and socket_to_SSL() + +use IO::Socket::SSL->start_SSL() instead + + +=item get_peer_certificate() + +use the peer_certificate() function instead. +Used to return X509_Certificate with methods subject_name and issuer_name. +Now simply returns $self which has these methods (although depreceated). + +=item issuer_name() + +use peer_certificate( 'issuer' ) instead + +=item subject_name() + +use peer_certificate( 'subject' ) instead + +=back + +The following classes have been removed: + +=over 2 + +=item SSL_SSL + +(not that you should have been directly accessing this anyway): + +=item X509_Certificate + +(but get_peer_certificate() will still Do The Right Thing) + +=back + +=head1 SEE ALSO + +IO::Socket::INET, IO::Socket::INET6, Net::SSLeay. + +=head1 AUTHORS + +Steffen Ullrich, <steffen at genua.de> is the current maintainer. + +Peter Behroozi, <behrooz at fas.harvard.edu> (Note the lack of an "i" at the end of "behrooz") + +Marko Asplund, <marko.asplund at kronodoc.fi>, was the original author of IO::Socket::SSL. + +Patches incorporated from various people, see file Changes. + +=head1 COPYRIGHT + +Working support for non-blocking was added by Steffen Ullrich. + +The rewrite of this module is Copyright (C) 2002-2005 Peter Behroozi. + +The original versions of this module are Copyright (C) 1999-2002 Marko Asplund. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + +=head1 Appendix: Using SSL + +If you are unfamiliar with the way OpenSSL works, good references may be found in +both the book "Network Security with OpenSSL" (Oreilly & Assoc.) and the web site +L<http://www.tldp.org/HOWTO/SSL-Certificates-HOWTO/>. Read on for a quick overview. + +=head2 The Long of It (Detail) + +The usual reason for using SSL is to keep your data safe. This means that not only +do you have to encrypt the data while it is being transported over a network, but +you also have to make sure that the right person gets the data. To accomplish this +with SSL, you have to use certificates. A certificate closely resembles a +Government-issued ID (at least in places where you can trust them). The ID contains some sort of +identifying information such as a name and address, and is usually stamped with a seal +of Government Approval. Theoretically, this means that you may trust the information on +the card and do business with the owner of the card. The same ideas apply to SSL certificates, +which have some identifying information and are "stamped" [most people refer to this as +I<signing> instead] by someone (a Certificate Authority) who you trust will adequately +verify the identifying information. In this case, because of some clever number theory, +it is extremely difficult to falsify the stamping process. Another useful consequence +of number theory is that the certificate is linked to the encryption process, so you may +encrypt data (using information on the certificate) that only the certificate owner can +decrypt. + +What does this mean for you? It means that at least one person in the party has to +have an ID to get drinks :-). Seriously, it means that one of the people communicating +has to have a certificate to ensure that your data is safe. For client/server +interactions, the server must B<always> have a certificate. If the server wants to +verify that the client is safe, then the client must also have a personal certificate. +To verify that a certificate is safe, one compares the stamped "seal" [commonly called +an I<encrypted digest/hash/signature>] on the certificate with the official "seal" of +the Certificate Authority to make sure that they are the same. To do this, you will +need the [unfortunately named] certificate of the Certificate Authority. With all these +in hand, you can set up a SSL connection and be reasonably confident that no-one is +reading your data. + +=head2 The Short of It (Summary) + +For servers, you will need to generate a cryptographic private key and a certificate +request. You will need to send the certificate request to a Certificate Authority to +get a real certificate back, after which you can start serving people. For clients, +you will not need anything unless the server wants validation, in which case you will +also need a private key and a real certificate. For more information about how to +get these, see L<http://www.modssl.org/docs/2.8/ssl_faq.html#ToC24>. + +=cut diff --git a/Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm b/Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm new file mode 100755 index 00000000000..baa092ba1fb --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm @@ -0,0 +1,143 @@ +# 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; +our(@ISA, $VERSION); +use IO::Socket; +use Carp; + +@ISA = qw(IO::Socket); +$VERSION = "1.23"; +$VERSION = eval $VERSION; + +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; + +=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 Create a listen socket + +If the constructor is only passed a single argument, it is assumed to +be a C<Peer> specification. + + + 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 + +=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 <perl5-porters@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/Master/tlpkg/tlperl/lib/IO/String.pm b/Master/tlpkg/tlperl/lib/IO/String.pm new file mode 100755 index 00000000000..4bc8e719601 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/String.pm @@ -0,0 +1,551 @@ +package IO::String; + +# Copyright 1998-2005 Gisle Aas. +# +# This library is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +require 5.005_03; +use strict; +use vars qw($VERSION $DEBUG $IO_CONSTANTS); +$VERSION = "1.08"; # $Date: 2005/12/05 12:00:47 $ + +use Symbol (); + +sub new +{ + my $class = shift; + my $self = bless Symbol::gensym(), ref($class) || $class; + tie *$self, $self; + $self->open(@_); + return $self; +} + +sub open +{ + my $self = shift; + return $self->new(@_) unless ref($self); + + if (@_) { + my $bufref = ref($_[0]) ? $_[0] : \$_[0]; + $$bufref = "" unless defined $$bufref; + *$self->{buf} = $bufref; + } + else { + my $buf = ""; + *$self->{buf} = \$buf; + } + *$self->{pos} = 0; + *$self->{lno} = 0; + return $self; +} + +sub pad +{ + my $self = shift; + my $old = *$self->{pad}; + *$self->{pad} = substr($_[0], 0, 1) if @_; + return "\0" unless defined($old) && length($old); + return $old; +} + +sub dump +{ + require Data::Dumper; + my $self = shift; + print Data::Dumper->Dump([$self], ['*self']); + print Data::Dumper->Dump([*$self{HASH}], ['$self{HASH}']); + return; +} + +sub TIEHANDLE +{ + print "TIEHANDLE @_\n" if $DEBUG; + return $_[0] if ref($_[0]); + my $class = shift; + my $self = bless Symbol::gensym(), $class; + $self->open(@_); + return $self; +} + +sub DESTROY +{ + print "DESTROY @_\n" if $DEBUG; +} + +sub close +{ + my $self = shift; + delete *$self->{buf}; + delete *$self->{pos}; + delete *$self->{lno}; + undef *$self if $] eq "5.008"; # workaround for some bug + return 1; +} + +sub opened +{ + my $self = shift; + return defined *$self->{buf}; +} + +sub binmode +{ + my $self = shift; + return 1 unless @_; + # XXX don't know much about layers yet :-( + return 0; +} + +sub getc +{ + my $self = shift; + my $buf; + return $buf if $self->read($buf, 1); + return undef; +} + +sub ungetc +{ + my $self = shift; + $self->setpos($self->getpos() - 1); + return 1; +} + +sub eof +{ + my $self = shift; + return length(${*$self->{buf}}) <= *$self->{pos}; +} + +sub print +{ + my $self = shift; + if (defined $\) { + if (defined $,) { + $self->write(join($,, @_).$\); + } + else { + $self->write(join("",@_).$\); + } + } + else { + if (defined $,) { + $self->write(join($,, @_)); + } + else { + $self->write(join("",@_)); + } + } + return 1; +} +*printflush = \*print; + +sub printf +{ + my $self = shift; + print "PRINTF(@_)\n" if $DEBUG; + my $fmt = shift; + $self->write(sprintf($fmt, @_)); + return 1; +} + + +my($SEEK_SET, $SEEK_CUR, $SEEK_END); + +sub _init_seek_constants +{ + if ($IO_CONSTANTS) { + require IO::Handle; + $SEEK_SET = &IO::Handle::SEEK_SET; + $SEEK_CUR = &IO::Handle::SEEK_CUR; + $SEEK_END = &IO::Handle::SEEK_END; + } + else { + $SEEK_SET = 0; + $SEEK_CUR = 1; + $SEEK_END = 2; + } +} + + +sub seek +{ + my($self,$off,$whence) = @_; + my $buf = *$self->{buf} || return 0; + my $len = length($$buf); + my $pos = *$self->{pos}; + + _init_seek_constants() unless defined $SEEK_SET; + + if ($whence == $SEEK_SET) { $pos = $off } + elsif ($whence == $SEEK_CUR) { $pos += $off } + elsif ($whence == $SEEK_END) { $pos = $len + $off } + else { die "Bad whence ($whence)" } + print "SEEK(POS=$pos,OFF=$off,LEN=$len)\n" if $DEBUG; + + $pos = 0 if $pos < 0; + $self->truncate($pos) if $pos > $len; # extend file + *$self->{pos} = $pos; + return 1; +} + +sub pos +{ + my $self = shift; + my $old = *$self->{pos}; + if (@_) { + my $pos = shift || 0; + my $buf = *$self->{buf}; + my $len = $buf ? length($$buf) : 0; + $pos = $len if $pos > $len; + *$self->{pos} = $pos; + } + return $old; +} + +sub getpos { shift->pos; } + +*sysseek = \&seek; +*setpos = \&pos; +*tell = \&getpos; + + + +sub getline +{ + my $self = shift; + my $buf = *$self->{buf} || return; + my $len = length($$buf); + my $pos = *$self->{pos}; + return if $pos >= $len; + + unless (defined $/) { # slurp + *$self->{pos} = $len; + return substr($$buf, $pos); + } + + unless (length $/) { # paragraph mode + # XXX slow&lazy implementation using getc() + my $para = ""; + my $eol = 0; + my $c; + while (defined($c = $self->getc)) { + if ($c eq "\n") { + $eol++; + next if $eol > 2; + } + elsif ($eol > 1) { + $self->ungetc($c); + last; + } + else { + $eol = 0; + } + $para .= $c; + } + return $para; # XXX wantarray + } + + my $idx = index($$buf,$/,$pos); + if ($idx < 0) { + # return rest of it + *$self->{pos} = $len; + $. = ++ *$self->{lno}; + return substr($$buf, $pos); + } + $len = $idx - $pos + length($/); + *$self->{pos} += $len; + $. = ++ *$self->{lno}; + return substr($$buf, $pos, $len); +} + +sub getlines +{ + die "getlines() called in scalar context\n" unless wantarray; + my $self = shift; + my($line, @lines); + push(@lines, $line) while defined($line = $self->getline); + return @lines; +} + +sub READLINE +{ + goto &getlines if wantarray; + goto &getline; +} + +sub input_line_number +{ + my $self = shift; + my $old = *$self->{lno}; + *$self->{lno} = shift if @_; + return $old; +} + +sub truncate +{ + my $self = shift; + my $len = shift || 0; + my $buf = *$self->{buf}; + if (length($$buf) >= $len) { + substr($$buf, $len) = ''; + *$self->{pos} = $len if $len < *$self->{pos}; + } + else { + $$buf .= ($self->pad x ($len - length($$buf))); + } + return 1; +} + +sub read +{ + my $self = shift; + my $buf = *$self->{buf}; + return undef unless $buf; + + my $pos = *$self->{pos}; + my $rem = length($$buf) - $pos; + my $len = $_[1]; + $len = $rem if $len > $rem; + return undef if $len < 0; + if (@_ > 2) { # read offset + substr($_[0],$_[2]) = substr($$buf, $pos, $len); + } + else { + $_[0] = substr($$buf, $pos, $len); + } + *$self->{pos} += $len; + return $len; +} + +sub write +{ + my $self = shift; + my $buf = *$self->{buf}; + return unless $buf; + + my $pos = *$self->{pos}; + my $slen = length($_[0]); + my $len = $slen; + my $off = 0; + if (@_ > 1) { + $len = $_[1] if $_[1] < $len; + if (@_ > 2) { + $off = $_[2] || 0; + die "Offset outside string" if $off > $slen; + if ($off < 0) { + $off += $slen; + die "Offset outside string" if $off < 0; + } + my $rem = $slen - $off; + $len = $rem if $rem < $len; + } + } + substr($$buf, $pos, $len) = substr($_[0], $off, $len); + *$self->{pos} += $len; + return $len; +} + +*sysread = \&read; +*syswrite = \&write; + +sub stat +{ + my $self = shift; + return unless $self->opened; + return 1 unless wantarray; + my $len = length ${*$self->{buf}}; + + return ( + undef, undef, # dev, ino + 0666, # filemode + 1, # links + $>, # user id + $), # group id + undef, # device id + $len, # size + undef, # atime + undef, # mtime + undef, # ctime + 512, # blksize + int(($len+511)/512) # blocks + ); +} + +sub FILENO { + return undef; # XXX perlfunc says this means the file is closed +} + +sub blocking { + my $self = shift; + my $old = *$self->{blocking} || 0; + *$self->{blocking} = shift if @_; + return $old; +} + +my $notmuch = sub { return }; + +*fileno = $notmuch; +*error = $notmuch; +*clearerr = $notmuch; +*sync = $notmuch; +*flush = $notmuch; +*setbuf = $notmuch; +*setvbuf = $notmuch; + +*untaint = $notmuch; +*autoflush = $notmuch; +*fcntl = $notmuch; +*ioctl = $notmuch; + +*GETC = \&getc; +*PRINT = \&print; +*PRINTF = \&printf; +*READ = \&read; +*WRITE = \&write; +*SEEK = \&seek; +*TELL = \&getpos; +*EOF = \&eof; +*CLOSE = \&close; +*BINMODE = \&binmode; + + +sub string_ref +{ + my $self = shift; + return *$self->{buf}; +} +*sref = \&string_ref; + +1; + +__END__ + +=head1 NAME + +IO::String - Emulate file interface for in-core strings + +=head1 SYNOPSIS + + use IO::String; + $io = IO::String->new; + $io = IO::String->new($var); + tie *IO, 'IO::String'; + + # read data + <$io>; + $io->getline; + read($io, $buf, 100); + + # write data + print $io "string\n"; + $io->print(@data); + syswrite($io, $buf, 100); + + select $io; + printf "Some text %s\n", $str; + + # seek + $pos = $io->getpos; + $io->setpos(0); # rewind + $io->seek(-30, -1); + seek($io, 0, 0); + +=head1 DESCRIPTION + +The C<IO::String> module provides the C<IO::File> interface for in-core +strings. An C<IO::String> object can be attached to a string, and +makes it possible to use the normal file operations for reading or +writing data, as well as for seeking to various locations of the string. +This is useful when you want to use a library module that only +provides an interface to file handles on data that you have in a string +variable. + +Note that perl-5.8 and better has built-in support for "in memory" +files, which are set up by passing a reference instead of a filename +to the open() call. The reason for using this module is that it +makes the code backwards compatible with older versions of Perl. + +The C<IO::String> module provides an interface compatible with +C<IO::File> as distributed with F<IO-1.20>, but the following methods +are not available: new_from_fd, fdopen, format_write, +format_page_number, format_lines_per_page, format_lines_left, +format_name, format_top_name. + +The following methods are specific to the C<IO::String> class: + +=over 4 + +=item $io = IO::String->new + +=item $io = IO::String->new( $string ) + +The constructor returns a newly-created C<IO::String> object. It +takes an optional argument, which is the string to read from or write +into. If no $string argument is given, then an internal buffer +(initially empty) is allocated. + +The C<IO::String> object returned is tied to itself. This means +that you can use most Perl I/O built-ins on it too: readline, <>, getc, +print, printf, syswrite, sysread, close. + +=item $io->open + +=item $io->open( $string ) + +Attaches an existing IO::String object to some other $string, or +allocates a new internal buffer (if no argument is given). The +position is reset to 0. + +=item $io->string_ref + +Returns a reference to the string that is attached to +the C<IO::String> object. Most useful when you let the C<IO::String> +create an internal buffer to write into. + +=item $io->pad + +=item $io->pad( $char ) + +Specifies the padding to use if +the string is extended by either the seek() or truncate() methods. It +is a single character and defaults to "\0". + +=item $io->pos + +=item $io->pos( $newpos ) + +Yet another interface for reading and setting the current read/write +position within the string (the normal getpos/setpos/tell/seek +methods are also available). The pos() method always returns the +old position, and if you pass it an argument it sets the new +position. + +There is (deliberately) a difference between the setpos() and seek() +methods in that seek() extends the string (with the specified +padding) if you go to a location past the end, whereas setpos() +just snaps back to the end. If truncate() is used to extend the string, +then it works as seek(). + +=back + +=head1 BUGS + +In Perl versions < 5.6, the TIEHANDLE interface was incomplete. +If you use such a Perl, then seek(), tell(), eof(), fileno(), binmode() will +not do anything on an C<IO::String> handle. See L<perltie> for +details. + +=head1 SEE ALSO + +L<IO::File>, L<IO::Stringy>, L<perlfunc/open> + +=head1 COPYRIGHT + +Copyright 1998-2005 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/IO/Stringy.pm b/Master/tlpkg/tlperl/lib/IO/Stringy.pm new file mode 100755 index 00000000000..978e53caf3f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Stringy.pm @@ -0,0 +1,446 @@ +package IO::Stringy; + +use vars qw($VERSION); +$VERSION = "2.110"; + +1; +__END__ + + +=head1 NAME + +IO-stringy - I/O on in-core objects like strings and arrays + + +=head1 SYNOPSIS + + IO:: + ::AtomicFile adpO Write a file which is updated atomically ERYQ + ::Lines bdpO I/O handle to read/write to array of lines ERYQ + ::Scalar RdpO I/O handle to read/write to a string ERYQ + ::ScalarArray RdpO I/O handle to read/write to array of scalars ERYQ + ::Wrap RdpO Wrap old-style FHs in standard OO interface ERYQ + ::WrapTie adpO Tie your handles & retain full OO interface ERYQ + + +=head1 DESCRIPTION + +This toolkit primarily provides modules for performing both traditional +and object-oriented i/o) on things I<other> than normal filehandles; +in particular, L<IO::Scalar|IO::Scalar>, L<IO::ScalarArray|IO::ScalarArray>, +and L<IO::Lines|IO::Lines>. + +In the more-traditional IO::Handle front, we +have L<IO::AtomicFile|IO::AtomicFile> +which may be used to painlessly create files which are updated +atomically. + +And in the "this-may-prove-useful" corner, we have L<IO::Wrap|IO::Wrap>, +whose exported wraphandle() function will clothe anything that's not +a blessed object in an IO::Handle-like wrapper... so you can just +use OO syntax and stop worrying about whether your function's caller +handed you a string, a globref, or a FileHandle. + + +=head1 WARNINGS + +Perl's TIEHANDLE spec was incomplete prior to 5.005_57; +it was missing support for C<seek()>, C<tell()>, and C<eof()>. +Attempting to use these functions with an IO::Scalar, IO::ScalarArray, +IO::Lines, etc. B<will not work> prior to 5.005_57. +None of the relevant methods will be invoked by Perl; +and even worse, this kind of bug can lie dormant for a while. +If you turn warnings on (via C<$^W> or C<perl -w>), and you see +something like this... + + seek() on unopened file + +...then you are probably trying to use one of these functions +on one of our IO:: classes with an old Perl. The remedy is to simply +use the OO version; e.g.: + + $SH->seek(0,0); ### GOOD: will work on any 5.005 + seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond + + + +=head1 INSTALLATION + + +=head2 Requirements + +As of version 2.x, this toolkit requires Perl 5.005 for +the IO::Handle subclasses, and 5.005_57 or better is +B<strongly> recommended. See L<"WARNINGS"> for details. + + +=head2 Directions + +Most of you already know the drill... + + perl Makefile.PL + make + make test + make install + +For everyone else out there... +if you've never installed Perl code before, or you're trying to use +this in an environment where your sysadmin or ISP won't let you do +interesting things, B<relax:> since this module contains no binary +extensions, you can cheat. That means copying the directory tree +under my "./lib" directory into someplace where your script can "see" +it. For example, under Linux: + + cp -r IO-stringy-1.234/lib/* /path/to/my/perl/ + +Now, in your Perl code, do this: + + use lib "/path/to/my/perl"; + use IO::Scalar; ### or whatever + +Ok, now you've been told. At this point, anyone who whines about +not being given enough information gets an unflattering haiku +written about them in the next change log. I'll do it. +Don't think I won't. + + + +=head1 VERSION + +$Id: Stringy.pm,v 1.3 2005/02/10 21:24:05 dfs Exp $ + + + +=head1 TO DO + +=over 4 + +=item (2000/08/02) Finalize $/ support + +Graham Barr submitted this patch half a I<year> ago; +Like a moron, I lost his message under a ton of others, +and only now have the experimental implementation done. + +Will the sudden sensitivity to $/ hose anyone out there? +I'm worried, so you have to enable it explicitly in 1.x. +It will be on by default in 2.x, though only IO::Scalar +has been implemented. + +=item (2001/08/08) Remove IO::WrapTie from new IO:: classes + +It's not needed. Backwards compatibility could be maintained +by having new_tie() be identical to new(). Heck, I'll bet +that IO::WrapTie should be reimplemented so the returned +object is just like an IO::Scalar in its use of globrefs. + + +=back + + + +=head1 CHANGE LOG + +=over 4 + + +=item Version 2.110 (2005/02/10) + +Maintainership taken over by DSKOLL <dfs@roaringpenguin.com> + +Closed the following bugs at +https://rt.cpan.org/NoAuth/Bugs.html?Dist=IO-stringy: + +=item + +2208 IO::ScalarArray->getline does not return undef for EOF if undef($/) + +=item + +7132 IO-stringy/Makefile.PL bug - name should be module name + +=item + +11249 IO::Scalar flush shouldn't return undef + +=item + +2172 $\ (output record separator) not respected + +=item + +8605 IO::InnerFile::seek() should return 1 on success + +=item + +4798 *.html in lib/ + +=item + +4369 Improvement: handling of fixed-size reads in IO::Scalar + +(Actually, bug 4369 was closed in Version 2.109) + +=item Version 2.109 (2003/12/21) + +IO::Scalar::getline now works with ref to int. +I<Thanks to Dominique Quatravaux for this patch.> + + +=item Version 2.108 (2001/08/20) + +The terms-of-use have been placed in the distribution file "COPYING". +Also, small documentation tweaks were made. + + +=item Version 2.105 (2001/08/09) + +Added support for various seek() whences to IO::ScalarArray. + +Added support for consulting $/ in IO::Scalar and IO::ScalarArray. +The old C<use_RS()> is not even an option. +Unsupported record separators will cause a croak(). + +Added a lot of regression tests to supoprt the above. + +Better on-line docs (hyperlinks to individual functions). + + +=item Version 2.103 (2001/08/08) + +After sober consideration I have reimplemented IO::Scalar::print() +so that it once again always seeks to the end of the string. +Benchmarks show the new implementation to be just as fast as +Juergen's contributed patch; until someone can convince me otherwise, +the current, safer implementation stays. + +I thought more about giving IO::Scalar two separate handles, +one for reading and one for writing, as suggested by Binkley. +His points about what tell() and eof() return are, I think, +show-stoppers for this feature. Even the manpages for stdio's fseek() +seem to imply a I<single> file position indicator, not two. +So I think I will take this off the TO DO list. +B<Remedy:> you can always have two handles open on the same +scalar, one which you only write to, and one which you only read from. +That should give the same effect. + + +=item Version 2.101 (2001/08/07) + +B<Alpha release.> +This is the initial release of the "IO::Scalar and friends are +now subclasses of IO::Handle". I'm flinging it against the wall. +Please tell me if the banana sticks. When it does, the banana +will be called 2.2x. + +First off, I<many many thanks to Doug Wilson>, who +has provided an I<invaluable> service by patching IO::Scalar +and friends so that they (1) inherit from IO::Handle, (2) automatically +tie themselves so that the C<new()> objects can be used in native i/o +constructs, and (3) doing it so that the whole damn thing passes +its regression tests. As Doug knows, my globref Kung-Fu was not +up to the task; he graciously provided the patches. This has earned +him a seat at the L<Co-Authors|"AUTHOR"> table, and the +right to have me address him as I<sensei>. + +Performance of IO::Scalar::print() has been improved by as much as 2x +for lots of little prints, with the cost of forcing those +who print-then-seek-then-print to explicitly seek to end-of-string +before printing again. +I<Thanks to Juergen Zeller for this patch.> + +Added the COPYING file, which had been missing from prior versions. +I<Thanks to Albert Chin-A-Young for pointing this out.> + +IO::Scalar consults $/ by default (1.x ignored it by default). +Yes, I still need to support IO::ScalarArray. + + +=item Version 1.221 (2001/08/07) + +I threatened in L<"INSTALLATION"> to write an unflattering haiku +about anyone who whined that I gave them insufficient information... +but it turns out that I left out a crucial direction. D'OH! +I<Thanks to David Beroff for the "patch" and the haiku...> + + Enough info there? + Here's unflattering haiku: + Forgot the line, "make"! ;-) + + + +=item Version 1.220 (2001/04/03) + +Added untested SEEK, TELL, and EOF methods to IO::Scalar +and IO::ScalarArray to support corresponding functions for +tied filehandles: untested, because I'm still running 5.00556 +and Perl is complaining about "tell() on unopened file". +I<Thanks to Graham Barr for the suggestion.> + +Removed not-fully-blank lines from modules; these were causing +lots of POD-related warnings. +I<Thanks to Nicolas Joly for the suggestion.> + + +=item Version 1.219 (2001/02/23) + +IO::Scalar objects can now be made sensitive to $/ . +Pains were taken to keep the fast code fast while adding this feature. +I<Cheers to Graham Barr for submitting his patch; +jeers to me for losing his email for 6 months.> + + +=item Version 1.218 (2001/02/23) + +IO::Scalar has a new sysseek() method. +I<Thanks again to Richard Jones.> + +New "TO DO" section, because people who submit patches/ideas should +at least know that they're in the system... and that I won't lose +their stuff. Please read it. + +New entries in L<"AUTHOR">. +Please read those too. + + + +=item Version 1.216 (2000/09/28) + +B<IO::Scalar and IO::ScalarArray now inherit from IO::Handle.> +I thought I'd remembered a problem with this ages ago, related to +the fact that these IO:: modules don't have "real" filehandles, +but the problem apparently isn't surfacing now. +If you suddenly encounter Perl warnings during global destruction +(especially if you're using tied filehandles), then please let me know! +I<Thanks to B. K. Oxley (binkley) for this.> + +B<Nasty bug fixed in IO::Scalar::write().> +Apparently, the offset and the number-of-bytes arguments were, +for all practical purposes, I<reversed.> You were okay if +you did all your writing with print(), but boy was I<this> a stupid bug! +I<Thanks to Richard Jones for finding this one. +For you, Rich, a double-length haiku:> + + Newspaper headline + typeset by dyslexic man + loses urgency + + BABY EATS FISH is + simply not equivalent + to FISH EATS BABY + +B<New sysread and syswrite methods for IO::Scalar.> +I<Thanks again to Richard Jones for this.> + + +=item Version 1.215 (2000/09/05) + +Added 'bool' overload to '""' overload, so object always evaluates +to true. (Whew. Glad I caught this before it went to CPAN.) + + +=item Version 1.214 (2000/09/03) + +Evaluating an IO::Scalar in a string context now yields +the underlying string. +I<Thanks to B. K. Oxley (binkley) for this.> + + +=item Version 1.213 (2000/08/16) + +Minor documentation fixes. + + +=item Version 1.212 (2000/06/02) + +Fixed IO::InnerFile incompatibility with Perl5.004. +I<Thanks to many folks for reporting this.> + + +=item Version 1.210 (2000/04/17) + +Added flush() and other no-op methods. +I<Thanks to Doru Petrescu for suggesting this.> + + +=item Version 1.209 (2000/03/17) + +Small bug fixes. + + +=item Version 1.208 (2000/03/14) + +Incorporated a number of contributed patches and extensions, +mostly related to speed hacks, support for "offset", and +WRITE/CLOSE methods. +I<Thanks to Richard Jones, Doru Petrescu, and many others.> + + + +=item Version 1.206 (1999/04/18) + +Added creation of ./testout when Makefile.PL is run. + + +=item Version 1.205 (1999/01/15) + +Verified for Perl5.005. + + +=item Version 1.202 (1998/04/18) + +New IO::WrapTie and IO::AtomicFile added. + + +=item Version 1.110 + +Added IO::WrapTie. + + +=item Version 1.107 + +Added IO::Lines, and made some bug fixes to IO::ScalarArray. +Also, added getc(). + + +=item Version 1.105 + +No real changes; just upgraded IO::Wrap to have a $VERSION string. + +=back + + + + +=head1 AUTHOR + +=over 4 + +=item Primary Maintainer + +David F. Skoll (F<dfs@roaringpenguin.com>). + +=item Original Author + +Eryq (F<eryq@zeegee.com>). +President, ZeeGee Software Inc (F<http://www.zeegee.com>). + +=item Co-Authors + +For all their bug reports and patch submissions, the following +are officially recognized: + + Richard Jones + B. K. Oxley (binkley) + Doru Petrescu + Doug Wilson (for picking up the ball I dropped, and doing tie() right) + + +=back + +Go to F<http://www.zeegee.com> for the latest downloads +and on-line documentation for this module. + +Enjoy. Yell if it breaks. + + +=cut diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Bunzip2.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Bunzip2.pm new file mode 100755 index 00000000000..98677e3c09f --- /dev/null +++ b/Master/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.024 qw(:Status); + +use Compress::Raw::Bzip2 2.024 ; + +our ($VERSION, @ISA); +$VERSION = '2.024'; + +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/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm new file mode 100755 index 00000000000..27de6e0f36b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm @@ -0,0 +1,105 @@ +package IO::Uncompress::Adapter::Identity; + +use warnings; +use strict; +use bytes; + +use IO::Compress::Base::Common 2.024 qw(:Status); + +our ($VERSION); + +$VERSION = '2.024'; + +use Compress::Raw::Zlib 2.024 (); + +sub mkUncompObject +{ + my $crc32 = 1; #shift ; + my $adler32 = shift; + + bless { 'CompSize' => 0, + 'UnCompSize' => 0, + 'wantCRC32' => $crc32, + 'CRC32' => Compress::Raw::Zlib::crc32(''), + 'wantADLER32'=> $adler32, + 'ADLER32' => Compress::Raw::Zlib::adler32(''), + 'ConsumesInput' => 1, + + } ; +} + +sub uncompr +{ + my $self = shift; + my $eof = $_[2]; + + if (defined ${ $_[0] } && length ${ $_[0] }) { + $self->{CompSize} += length ${ $_[0] } ; + $self->{UnCompSize} = $self->{CompSize} ; + + $self->{CRC32} = Compress::Raw::Zlib::crc32($_[0], $self->{CRC32}) + if $self->{wantCRC32}; + + $self->{ADLER32} = Compress::Zlib::adler32($_[0], $self->{ADLER32}) + if $self->{wantADLER32}; + + ${ $_[1] } .= ${ $_[0] }; + ${ $_[0] } = ""; + } + + 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->{UnCompSize} ; +} + +sub uncompressedBytes +{ + my $self = shift ; + return $self->{UnCompSize} ; +} + +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/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Inflate.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Inflate.pm new file mode 100755 index 00000000000..aac1e413ffe --- /dev/null +++ b/Master/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.024 qw(:Status); +use Compress::Raw::Zlib 2.024 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); + +our ($VERSION); +$VERSION = '2.024'; + + + +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/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm new file mode 100755 index 00000000000..68038f5d374 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm @@ -0,0 +1,987 @@ +package IO::Uncompress::AnyInflate ; + +# for RFC1950, RFC1951 or RFC1952 + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject); + +use IO::Uncompress::Adapter::Inflate 2.024 (); + + +use IO::Uncompress::Base 2.024 ; +use IO::Uncompress::Gunzip 2.024 ; +use IO::Uncompress::Inflate 2.024 ; +use IO::Uncompress::RawInflate 2.024 ; +use IO::Uncompress::Unzip 2.024 ; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError); + +$VERSION = '2.024'; +$AnyInflateError = ''; + +@ISA = qw( Exporter IO::Uncompress::Base ); +@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 = createSelfTiedObject($class, \$AnyInflateError); + $obj->_create(undef, 0, @_); +} + +sub anyinflate +{ + my $obj = createSelfTiedObject(undef, \$AnyInflateError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + use IO::Compress::Base::Common 2.024 qw(:Parse); + return ( 'RawInflate' => [1, 1, Parse_boolean, 0] ) ; +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # any always needs both crc32 and adler32 + $got->value('CRC32' => 1); + $got->value('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->value('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 => $output [,OPTS] + or die "anyinflate failed: $AnyInflateError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 anyinflate $input => $output [, OPTS] + +C<anyinflate> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +=head3 The C<$output> parameter + +The parameter C<$output> 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> 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> 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> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> 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 appened 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<$$output>. + +=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/bufffer 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 the 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 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. + +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 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 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::Uncompress::AnyInflate::FAQ|IO::Uncompress::AnyInflate::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<Compress::Zlib::FAQ|Compress::Zlib::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 +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm new file mode 100755 index 00000000000..5984921e25b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm @@ -0,0 +1,1018 @@ +package IO::Uncompress::AnyUncompress ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject); + +use IO::Uncompress::Base 2.024 ; + + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError); + +$VERSION = '2.024'; +$AnyUncompressError = ''; + +@ISA = qw( Exporter IO::Uncompress::Base ); +@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 +{ + eval ' use IO::Uncompress::Adapter::Inflate 2.024 ;'; + eval ' use IO::Uncompress::Adapter::Bunzip2 2.024 ;'; + eval ' use IO::Uncompress::Adapter::LZO 2.024 ;'; + eval ' use IO::Uncompress::Adapter::Lzf 2.024 ;'; + eval ' use IO::Uncompress::Adapter::UnLzma 2.020 ;'; + eval ' use IO::Uncompress::Adapter::UnXz 2.020 ;'; + + eval ' use IO::Uncompress::Bunzip2 2.024 ;'; + eval ' use IO::Uncompress::UnLzop 2.024 ;'; + eval ' use IO::Uncompress::Gunzip 2.024 ;'; + eval ' use IO::Uncompress::Inflate 2.024 ;'; + eval ' use IO::Uncompress::RawInflate 2.024 ;'; + eval ' use IO::Uncompress::Unzip 2.024 ;'; + eval ' use IO::Uncompress::UnLzf 2.024 ;'; + eval ' use IO::Uncompress::UnLzma 2.024 ;'; + eval ' use IO::Uncompress::UnXz 2.024 ;'; +} + +sub new +{ + my $class = shift ; + my $obj = createSelfTiedObject($class, \$AnyUncompressError); + $obj->_create(undef, 0, @_); +} + +sub anyuncompress +{ + my $obj = createSelfTiedObject(undef, \$AnyUncompressError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + use IO::Compress::Base::Common 2.024 qw(:Parse); + return ( 'RawInflate' => [1, 1, Parse_boolean, 0] , + 'UnLzma' => [1, 1, Parse_boolean, 0] ) ; +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # any always needs both crc32 and adler32 + $got->value('CRC32' => 1); + $got->value('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->value('RawInflate'); + + $magic = $self->ckMagic( @possible ); + + if ($magic) { + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + return 1; + } + } + + if (defined $IO::Uncompress::UnLzma::VERSION && $got->value('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->value('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 => $output [,OPTS] + or die "anyuncompress failed: $AnyUncompressError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 anyuncompress $input => $output [, OPTS] + +C<anyuncompress> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +=head3 The C<$output> parameter + +The parameter C<$output> 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> 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> 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> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> 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 appened 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<$$output>. + +=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/bufffer 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 the 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 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. + +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 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 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<Compress::Zlib::FAQ|Compress::Zlib::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, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Uncompress/Base.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Base.pm new file mode 100755 index 00000000000..33f2ac23758 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Base.pm @@ -0,0 +1,1474 @@ + +package IO::Uncompress::Base ; + +use strict ; +use warnings; +use bytes; + +our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS); +@ISA = qw(Exporter IO::File); + + +$VERSION = '2.024'; + +use constant G_EOF => 0 ; +use constant G_ERR => -1 ; + +use IO::Compress::Base::Common 2.024 ; +#use Parse::Parameters ; + +use IO::File ; +use Symbol; +use Scalar::Util qw(readonly); +use List::Util qw(min); +use Carp ; + +%EXPORT_TAGS = ( ); +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +#Exporter::export_ok_tags('all') ; + + + +sub smartRead +{ + my $self = $_[0]; + my $out = $_[1]; + my $size = $_[2]; + $$out = "" ; + + my $offset = 0 ; + + + if (defined *$self->{InputLength}) { + return 0 + if *$self->{InputLengthRemaining} <= 0 ; + $size = min($size, *$self->{InputLengthRemaining}); + } + + if ( length *$self->{Prime} ) { + #$$out = substr(*$self->{Prime}, 0, $size, '') ; + $$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 = ''; + *$self->{FH}->read($tmp, $get_size) && + (substr($$out, $offset) = $tmp); + } + else + { *$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), ''); + *$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 ; + #$$out = '' unless defined $$out ; + 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}; + + $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; + #print "smartSeek to $offset\n"; + + # TODO -- need to take prime into account + if (defined *$self->{FH}) + { *$self->{FH}->seek($offset, SEEK_SET) } + else { + *$self->{BufferOffset} = $offset ; + substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = '' + if $truncate; + return 1; + } +} + +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 ; + #return $errno unless $errno || ! defined *$self->{ErrorNo}; + #return $errno unless $errno ; + + *$self->{ErrorNo} = $errno; + ${ *$self->{Error} } = '' ; + + return *$self->{ErrorNo} ; +} + + +sub saveErrorString +{ + my $self = shift ; + my $retval = shift ; + + #return $retval if ${ *$self->{Error} }; + + ${ *$self->{Error} } = shift ; + *$self->{ErrorNo} = shift() + 0 if @_ ; + + #warn "saveErrorString: " . ${ *$self->{Error} } . " " . *$self->{Error} . "\n" ; + 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' => [1, 1, Parse_unsigned, 16 * 1024], + 'AutoClose' => [1, 1, Parse_boolean, 0], + 'Strict' => [1, 1, Parse_boolean, 0], + 'Append' => [1, 1, Parse_boolean, 0], + 'Prime' => [1, 1, Parse_any, undef], + 'MultiStream' => [1, 1, Parse_boolean, 0], + 'Transparent' => [1, 1, Parse_any, 1], + 'Scan' => [1, 1, Parse_boolean, 0], + 'InputLength' => [1, 1, Parse_unsigned, undef], + 'BinModeOut' => [1, 1, Parse_boolean, 0], + #'Encode' => [1, 1, Parse_any, undef], + + #'ConsumeInput' => [1, 1, Parse_boolean, 0], + + $self->getExtraParams(), + + #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0, + # ContinueAfterEof + } ; + + $Valid->{TrailingData} = [1, 1, Parse_writable_scalar, undef] + if *$self->{OneShot} ; + + $got->parse($Valid, @_ ) + or $self->croakError("${class}: $got->{Error}") ; + + $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->value('Scan'); + } + else { + no warnings ; + my $mode = '<'; + $mode = '+<' if $got->value('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->parsed('Encode')) { + my $want_encoding = $got->value('Encode'); + *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding); + } + + + *$obj->{InputLength} = $got->parsed('InputLength') + ? $got->value('InputLength') + : undef ; + *$obj->{InputLengthRemaining} = $got->value('InputLength'); + *$obj->{BufferOffset} = 0 ; + *$obj->{AutoClose} = $got->value('AutoClose'); + *$obj->{Strict} = $got->value('Strict'); + *$obj->{BlockSize} = $got->value('BlockSize'); + *$obj->{Append} = $got->value('Append'); + *$obj->{AppendOutput} = $append_mode || $got->value('Append'); + *$obj->{ConsumeInput} = $got->value('ConsumeInput'); + *$obj->{Transparent} = $got->value('Transparent'); + *$obj->{MultiStream} = $got->value('MultiStream'); + + # TODO - move these two into RawDeflate + *$obj->{Scan} = $got->value('Scan'); + *$obj->{ParseExtra} = $got->value('ParseExtra') + || $got->value('Strict') ; + *$obj->{Type} = ''; + *$obj->{Prime} = $got->value('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; + + if ( ! $status) { + return undef + unless *$obj->{Transparent}; + + $obj->clearError(); + *$obj->{Type} = 'plain'; + *$obj->{Plain} = 1; + #$status = $obj->mkIdentityUncomp($class, $got); + $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')) + { + *$obj->{TrailingData} = $got->value('TrailingData'); + } + + *$obj->{MultiStream} = $got->value('MultiStream'); + $got->value('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}->value('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}->value('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}->value('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}->value('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 = 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) { + 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 if $status < 0 ; + + 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 = min($size, *$self->{CompressedInputLengthRemaining} ); + *$self->{CompressedInputLengthRemaining} -= $size ; + } + + my $status = $self->smartRead($buff, $size) ; + return $self->saveErrorString(STATUS_ERROR, "Error Reading Data") + if $status < 0 ; + + 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 !length *$self->{Pending} && *$self->{EndStream} ; + 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 < 0 ; + + 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); + + if (*$self->{Encoding}) { + $$buffer = *$self->{Encoding}->decode($$buffer); + } + } + + if ($status == STATUS_ENDSTREAM) { + + *$self->{EndStream} = 1 ; +#$self->pushBack($temp_buf) ; +#$temp_buf = ''; + + 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 to file 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->reset(); + *$self->{UnCompSize}->reset(); + *$self->{CompSize}->reset(); + + my $magic = $self->ckMagic(); + #*$self->{EndStream} = 0 ; + + if ( ! defined $magic) { + if (! *$self->{Transparent} ) + { + *$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 +{ + # return codes + # >0 - ok, number of bytes read + # =0 - ok, eof + # <0 - not ok + + my $self = shift ; + + return G_EOF if *$self->{Closed} ; + + my $buffer ; + + if (ref $_[0] ) { + $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only") + if 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 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) = ''; + } + } + } + + 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($$buffer, $offset) = substr($$out_buffer, 0, $length) ; + substr($$out_buffer, 0, $length) = '' ; + + return $length ; +} + +sub _getline +{ + my $self = shift ; + + # Slurp Mode + if ( ! defined $/ ) { + my $data ; + 1 while $self->read($data) > 0 ; + return \$data ; + } + + # Record Mode + if ( ref $/ eq 'SCALAR' && ${$/} =~ /^\d+$/ && ${$/} > 0) { + my $reclen = ${$/} ; + my $data ; + $self->read($data, $reclen) ; + return \$data ; + } + + # Paragraph Mode + if ( ! length $/ ) { + my $paragraph ; + while ($self->read($paragraph) > 0 ) { + if ($paragraph =~ s/^(.*?\n\n+)//s) { + *$self->{Pending} = $paragraph ; + my $par = $1 ; + return \$par ; + } + } + return \$paragraph; + } + + # $/ isn't empty, or a reference, so it's Line Mode. + { + my $line ; + my $offset; + my $p = \*$self->{Pending} ; + + if (length(*$self->{Pending}) && + ($offset = index(*$self->{Pending}, $/)) >=0) { + my $l = substr(*$self->{Pending}, 0, $offset + length $/ ); + substr(*$self->{Pending}, 0, $offset + length $/) = ''; + return \$l; + } + + while ($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 \$l; + } + } + + return \$line; + } +} + +sub getline +{ + my $self = shift; + my $current_append = *$self->{AppendOutput} ; + *$self->{AppendOutput} = 1; + my $lineref = $self->_getline(); + $. = ++ *$self->{LineNo} if defined $$lineref ; + *$self->{AppendOutput} = $current_append; + 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}) { + #if ( *$self->{AutoClose}) { + 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, 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" ; } ; + 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 if to to be sub-classed by IO::Unompress 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<Compress::Zlib::FAQ|Compress::Zlib::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, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm new file mode 100755 index 00000000000..b3988c41851 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm @@ -0,0 +1,858 @@ +package IO::Uncompress::Bunzip2 ; + +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject); + +use IO::Uncompress::Base 2.024 ; +use IO::Uncompress::Adapter::Bunzip2 2.024 ; + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error); + +$VERSION = '2.024'; +$Bunzip2Error = ''; + +@ISA = qw( Exporter IO::Uncompress::Base ); +@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 = createSelfTiedObject($class, \$Bunzip2Error); + + $obj->_create(undef, 0, @_); +} + +sub bunzip2 +{ + my $obj = createSelfTiedObject(undef, \$Bunzip2Error); + return $obj->_inf(@_); +} + +sub getExtraParams +{ + my $self = shift ; + + use IO::Compress::Base::Common 2.024 qw(:Parse); + + return ( + 'Verbosity' => [1, 1, Parse_boolean, 0], + 'Small' => [1, 1, 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->value('Small'); + my $Verbosity = $got->value('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 => $output [,OPTS] + or die "bunzip2 failed: $Bunzip2Error\n"; + +The functional interface needs Perl5.005 or better. + +=head2 bunzip2 $input => $output [, OPTS] + +C<bunzip2> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +=head3 The C<$output> parameter + +The parameter C<$output> 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> 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> 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> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> 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 >> + +TODO + +=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 +compressed 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<$$output>. + +=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/bufffer 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 the 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 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. + +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 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 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::Uncompress::Bunzip2::FAQ|IO::Uncompress::Bunzip2::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::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> + +L<Compress::Zlib::FAQ|Compress::Zlib::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 F<http://www.bzip.org>. + +See the module L<Compress::Bzip2|Compress::Bzip2> + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2008 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/Master/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm new file mode 100755 index 00000000000..f3e4e6561f0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm @@ -0,0 +1,1111 @@ + +package IO::Uncompress::Gunzip ; + +require 5.004 ; + +# for RFC1952 + +use strict ; +use warnings; +use bytes; + +use IO::Uncompress::RawInflate 2.024 ; + +use Compress::Raw::Zlib 2.024 qw( crc32 ) ; +use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject); +use IO::Compress::Gzip::Constants 2.024 ; +use IO::Compress::Zlib::Extra 2.024 ; + +require Exporter ; + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GunzipError); + +@ISA = qw( Exporter IO::Uncompress::RawInflate ); +@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.024'; + +sub new +{ + my $class = shift ; + $GunzipError = ''; + my $obj = createSelfTiedObject($class, \$GunzipError); + + $obj->_create(undef, 0, @_); +} + +sub gunzip +{ + my $obj = createSelfTiedObject(undef, \$GunzipError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + use IO::Compress::Base::Common 2.024 qw(:Parse); + return ( 'ParseExtra' => [1, 1, Parse_boolean, 0] ) ; +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # gunzip always needs crc32 + $got->value('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 = 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 => $output [,OPTS] + or die "gunzip failed: $GunzipError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 gunzip $input => $output [, OPTS] + +C<gunzip> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +=head3 The C<$output> parameter + +The parameter C<$output> 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> 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> 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> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> 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 appened 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<$$output>. + +=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/bufffer 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 the 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 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. + +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 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 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::Uncompress::Gunzip::FAQ|IO::Uncompress::Gunzip::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<Compress::Zlib::FAQ|Compress::Zlib::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 +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm new file mode 100755 index 00000000000..956f62e0835 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm @@ -0,0 +1,982 @@ +package IO::Uncompress::Inflate ; +# for RFC1950 + +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject); +use IO::Compress::Zlib::Constants 2.024 ; + +use IO::Uncompress::RawInflate 2.024 ; + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError); + +$VERSION = '2.024'; +$InflateError = ''; + +@ISA = qw( Exporter IO::Uncompress::RawInflate ); +@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 = createSelfTiedObject($class, \$InflateError); + + $obj->_create(undef, 0, @_); +} + +sub inflate +{ + my $obj = createSelfTiedObject(undef, \$InflateError); + return $obj->_inf(@_); +} + +sub getExtraParams +{ + return (); +} + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + # gunzip always needs adler32 + $got->value('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 => $output [,OPTS] + or die "inflate failed: $InflateError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 inflate $input => $output [, OPTS] + +C<inflate> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +=head3 The C<$output> parameter + +The parameter C<$output> 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> 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> 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> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> 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 appened 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<$$output>. + +=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/bufffer 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 the 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 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. + +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 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 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::Uncompress::Inflate::FAQ|IO::Uncompress::Inflate::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<Compress::Zlib::FAQ|Compress::Zlib::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 +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm new file mode 100755 index 00000000000..f017fa0f599 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm @@ -0,0 +1,1110 @@ +package IO::Uncompress::RawInflate ; +# for RFC1951 + +use strict ; +use warnings; +use bytes; + +use Compress::Raw::Zlib 2.024 ; +use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject); + +use IO::Uncompress::Base 2.024 ; +use IO::Uncompress::Adapter::Inflate 2.024 ; + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError); + +$VERSION = '2.024'; +$RawInflateError = ''; + +@ISA = qw( Exporter IO::Uncompress::Base ); +@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 = createSelfTiedObject($class, \$RawInflateError); + $obj->_create(undef, 0, @_); +} + +sub rawinflate +{ + my $obj = 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->value('CRC32'), + $got->value('ADLER32'), + $got->value('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}->value('CRC32'), + -ADLER32 => *$self->{Params}->value('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 => $output [,OPTS] + or die "rawinflate failed: $RawInflateError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 rawinflate $input => $output [, OPTS] + +C<rawinflate> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +=head3 The C<$output> parameter + +The parameter C<$output> 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> 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> 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> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> 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 appened 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<$$output>. + +=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/bufffer 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 the 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 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. + +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 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 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::Uncompress::RawInflate::FAQ|IO::Uncompress::RawInflate::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<Compress::Zlib::FAQ|Compress::Zlib::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 +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm new file mode 100755 index 00000000000..e7d6849f66b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm @@ -0,0 +1,1549 @@ +package IO::Uncompress::Unzip; + +require 5.004 ; + +# for RFC1952 + +use strict ; +use warnings; +use bytes; + +use IO::Uncompress::RawInflate 2.024 ; +use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject); +use IO::Uncompress::Adapter::Inflate 2.024 ; +use IO::Uncompress::Adapter::Identity 2.024 ; +use IO::Compress::Zlib::Extra 2.024 ; +use IO::Compress::Zip::Constants 2.024 ; + +use Compress::Raw::Zlib 2.024 qw(crc32) ; + +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.024'; +$UnzipError = ''; + +@ISA = qw(Exporter IO::Uncompress::RawInflate); +@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 = createSelfTiedObject($class, \$UnzipError); + $obj->_create(undef, 0, @_); +} + +sub unzip +{ + my $obj = createSelfTiedObject(undef, \$UnzipError); + return $obj->_inf(@_) ; +} + +sub getExtraParams +{ + use IO::Compress::Base::Common 2.024 qw(:Parse); + + + return ( +# # Zip header fields + 'Name' => [1, 1, Parse_any, undef], + +# 'Stream' => [1, 1, Parse_boolean, 1], + # 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->value('CRC32' => 1); + + *$self->{UnzipData}{Name} = $got->value('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 * 0xFFFFFFFF + $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, 2)); + #my $offsetToCD = unpack ("V", substr($buffer, 16-4, 2)); + 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("Streamed Stored content not supported") + if $streamingMode && $compressedMethod == 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 ($uncompressedLength->get32bit() == 0xFFFFFFFF ) { + $uncompressedLength + = U64::newUnpack_V64 substr($buff, 0, 8); + + $offset += 8 ; + } + + if ($compressedLength->get32bit() == 0xFFFFFFFF) { + + $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} = 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"); +# #my $LzmaInfo = unpack ("C", substr($LzmaPropertyData, 0, 1)); +# #my $LzmaDictSize = unpack ("V", substr($LzmaPropertyData, 1, 4)); +# +# # Create an LZMA_Alone header +# $self->pushBack($LzmaPropertyData . +# $uncompressedLength->getPacked_V64()); +# +# my $obj = +# IO::Uncompress::Adapter::UnLzma::mkUncompObject(); +# +# *$self->{Uncomp} = $obj; +# } + elsif ($compressedMethod == ZIP_CM_STORE) + { + # TODO -- add support for reading uncompressed + + *$self->{Type} = 'zip-stored'; + + my $obj = IO::Uncompress::Adapter::Identity::mkUncompObject(); + + *$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} = crc32(${$_[0]}, *$self->{ZipData}{CRC32}); + } +} + + +# 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; +} + + +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 => $output [,OPTS] + or die "unzip failed: $UnzipError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 unzip $input => $output [, OPTS] + +C<unzip> expects at least two parameters, C<$input> and C<$output>. + +=head3 The C<$input> parameter + +The parameter, C<$input>, 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 C<$input> 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> 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> is a scalar reference, the input data will be read +from C<$$input>. + +=item An array reference + +If C<$input> 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> 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. + +If the fileglob does not match any files ... + +See L<File::GlobMapper|File::GlobMapper> for more details. + +=back + +If the C<$input> parameter is any other type, C<undef> will be returned. + +=head3 The C<$output> parameter + +The parameter C<$output> 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> 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> 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> is a scalar reference, the uncompressed data will be +stored in C<$$output>. + +=item An Array Reference + +If C<$output> is an array reference, the uncompressed data will be +pushed onto the array. + +=item An Output FileGlob + +If C<$output> 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> is an fileglob string, C<$input> must also be a fileglob +string. Anything else is an error. + +=back + +If the C<$output> parameter is any other type, C<undef> will be returned. + +=head2 Notes + +When C<$input> maps to multiple compressed files/buffers and C<$output> is +a single file/buffer, after uncompression C<$output> 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 appened 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.zip> and write the +uncompressed data to the file C<file1.txt>. + + use strict ; + use warnings ; + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + my $input = "file1.txt.zip"; + my $output = "file1.txt"; + unzip $input => $output + or die "unzip failed: $UnzipError\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::Unzip qw(unzip $UnzipError) ; + use IO::File ; + + my $input = new IO::File "<file1.txt.zip" + or die "Cannot open 'file1.txt.zip': $!\n" ; + my $buffer ; + unzip $input => \$buffer + or die "unzip failed: $UnzipError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.zip" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::Unzip qw(unzip $UnzipError) ; + + unzip '</my/home/*.txt.zip>' => '</my/home/#1.txt>' + or die "unzip failed: $UnzipError\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::Unzip qw(unzip $UnzipError) ; + + for my $input ( glob "/my/home/*.txt.zip" ) + { + my $output = $input; + $output =~ s/.zip// ; + unzip $input => $output + or die "Error compressing '$input': $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<$$output>. + +=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::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/bufffer 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 the 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 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. + +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 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 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::Uncompress::Unzip::FAQ|IO::Uncompress::Unzip::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<Compress::Zlib::FAQ|Compress::Zlib::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 +F<http://www.faqs.org/rfcs/rfc1950.html>, +F<http://www.faqs.org/rfcs/rfc1951.html> and +F<http://www.faqs.org/rfcs/rfc1952.html> + +The I<zlib> compression library was written by Jean-loup Gailly +F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>. + +The primary site for the I<zlib> compression library is +F<http://www.zlib.org>. + +The primary site for gzip is F<http://www.gzip.org>. + +=head1 AUTHOR + +This module was written by Paul Marquess, F<pmqs@cpan.org>. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2010 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/Master/tlpkg/tlperl/lib/IO/Wrap.pm b/Master/tlpkg/tlperl/lib/IO/Wrap.pm new file mode 100755 index 00000000000..5a28392dd23 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/Wrap.pm @@ -0,0 +1,222 @@ +package IO::Wrap; + +# SEE DOCUMENTATION AT BOTTOM OF FILE + +require 5.002; + +use strict; +use vars qw(@ISA @EXPORT $VERSION); +@ISA = qw(Exporter); +@EXPORT = qw(wraphandle); + +use FileHandle; +use Carp; + +# The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.110"; + + +#------------------------------ +# wraphandle RAW +#------------------------------ +sub wraphandle { + my $raw = shift; + new IO::Wrap $raw; +} + +#------------------------------ +# new STREAM +#------------------------------ +sub new { + my ($class, $stream) = @_; + no strict 'refs'; + + ### Convert raw scalar to globref: + ref($stream) or $stream = \*$stream; + + ### Wrap globref and incomplete objects: + if ((ref($stream) eq 'GLOB') or ### globref + (ref($stream) eq 'FileHandle') && !defined(&FileHandle::read)) { + return bless \$stream, $class; + } + $stream; ### already okay! +} + +#------------------------------ +# I/O methods... +#------------------------------ +sub close { + my $self = shift; + return close($$self); +} +sub getline { + my $self = shift; + my $fh = $$self; + return scalar(<$fh>); +} +sub getlines { + my $self = shift; + wantarray or croak("Can't call getlines in scalar context!"); + my $fh = $$self; + <$fh>; +} +sub print { + my $self = shift; + print { $$self } @_; +} +sub read { + my $self = shift; + return read($$self, $_[0], $_[1]); +} +sub seek { + my $self = shift; + return seek($$self, $_[0], $_[1]); +} +sub tell { + my $self = shift; + return tell($$self); +} + +#------------------------------ +1; +__END__ + + +=head1 NAME + +IO::Wrap - wrap raw filehandles in IO::Handle interface + + +=head1 SYNOPSIS + + use IO::Wrap; + + ### Do stuff with any kind of filehandle (including a bare globref), or + ### any kind of blessed object that responds to a print() message. + ### + sub do_stuff { + my $fh = shift; + + ### At this point, we have no idea what the user gave us... + ### a globref? a FileHandle? a scalar filehandle name? + + $fh = wraphandle($fh); + + ### At this point, we know we have an IO::Handle-like object! + + $fh->print("Hey there!"); + ... + } + + +=head1 DESCRIPTION + +Let's say you want to write some code which does I/O, but you don't +want to force the caller to provide you with a FileHandle or IO::Handle +object. You want them to be able to say: + + do_stuff(\*STDOUT); + do_stuff('STDERR'); + do_stuff($some_FileHandle_object); + do_stuff($some_IO_Handle_object); + +And even: + + do_stuff($any_object_with_a_print_method); + +Sure, one way to do it is to force the caller to use tiehandle(). +But that puts the burden on them. Another way to do it is to +use B<IO::Wrap>, which provides you with the following functions: + + +=over 4 + +=item wraphandle SCALAR + +This function will take a single argument, and "wrap" it based on +what it seems to be... + +=over 4 + +=item * + +B<A raw scalar filehandle name,> like C<"STDOUT"> or C<"Class::HANDLE">. +In this case, the filehandle name is wrapped in an IO::Wrap object, +which is returned. + +=item * + +B<A raw filehandle glob,> like C<\*STDOUT>. +In this case, the filehandle glob is wrapped in an IO::Wrap object, +which is returned. + +=item * + +B<A blessed FileHandle object.> +In this case, the FileHandle is wrapped in an IO::Wrap object if and only +if your FileHandle class does not support the C<read()> method. + +=item * + +B<Any other kind of blessed object,> which is assumed to be already +conformant to the IO::Handle interface. +In this case, you just get back that object. + +=back + +=back + + +If you get back an IO::Wrap object, it will obey a basic subset of +the IO:: interface. That is, the following methods (note: I said +I<methods>, not named operators) should work on the thing you get back: + + close + getline + getlines + print ARGS... + read BUFFER,NBYTES + seek POS,WHENCE + tell + + + +=head1 NOTES + +Clearly, when wrapping a raw external filehandle (like \*STDOUT), +I didn't want to close the file descriptor when the "wrapper" object is +destroyed... since the user might not appreciate that! Hence, +there's no DESTROY method in this class. + +When wrapping a FileHandle object, however, I believe that Perl will +invoke the FileHandle::DESTROY when the last reference goes away, +so in that case, the filehandle is closed if the wrapped FileHandle +really was the last reference to it. + + +=head1 WARNINGS + +This module does not allow you to wrap filehandle names which are given +as strings that lack the package they were opened in. That is, if a user +opens FOO in package Foo, they must pass it to you either as C<\*FOO> +or as C<"Foo::FOO">. However, C<"STDIN"> and friends will work just fine. + + +=head1 VERSION + +$Id: Wrap.pm,v 1.2 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHOR + +=item Primary Maintainer + +David F. Skoll (F<dfs@roaringpenguin.com>). + +=item Original Author + +Eryq (F<eryq@zeegee.com>). +President, ZeeGee Software Inc (F<http://www.zeegee.com>). + +=cut + diff --git a/Master/tlpkg/tlperl/lib/IO/WrapTie.pm b/Master/tlpkg/tlperl/lib/IO/WrapTie.pm new file mode 100755 index 00000000000..5e22508bbd9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/IO/WrapTie.pm @@ -0,0 +1,491 @@ +# SEE DOCUMENTATION AT BOTTOM OF FILE + + +#------------------------------------------------------------ +package IO::WrapTie; +#------------------------------------------------------------ +require 5.004; ### for tie +use strict; +use vars qw(@ISA @EXPORT $VERSION); +use Exporter; + +# Inheritance, exporting, and package version: +@ISA = qw(Exporter); +@EXPORT = qw(wraptie); +$VERSION = "2.110"; + +# Function, exported. +sub wraptie { + IO::WrapTie::Master->new(@_); +} + +# Class method; BACKWARDS-COMPATIBILITY ONLY! +sub new { + shift; + IO::WrapTie::Master->new(@_); +} + + + +#------------------------------------------------------------ +package IO::WrapTie::Master; +#------------------------------------------------------------ + +use strict; +use vars qw(@ISA $AUTOLOAD); +use IO::Handle; + +# We inherit from IO::Handle to get methods which invoke i/o operators, +# like print(), on our tied handle: +@ISA = qw(IO::Handle); + +#------------------------------ +# new SLAVE, TIEARGS... +#------------------------------ +# Create a new subclass of IO::Handle which... +# +# (1) Handles i/o OPERATORS because it is tied to an instance of +# an i/o-like class, like IO::Scalar. +# +# (2) Handles i/o METHODS by delegating them to that same tied object!. +# +# Arguments are the slave class (e.g., IO::Scalar), followed by all +# the arguments normally sent into that class's TIEHANDLE method. +# In other words, much like the arguments to tie(). :-) +# +# NOTE: +# The thing $x we return must be a BLESSED REF, for ($x->print()). +# The underlying symbol must be a FILEHANDLE, for (print $x "foo"). +# It has to have a way of getting to the "real" back-end object... +# +sub new { + my $master = shift; + my $io = IO::Handle->new; ### create a new handle + my $slave = shift; + tie *$io, $slave, @_; ### tie: will invoke slave's TIEHANDLE + bless $io, $master; ### return a master +} + +#------------------------------ +# AUTOLOAD +#------------------------------ +# Delegate method invocations on the master to the underlying slave. +# +sub AUTOLOAD { + my $method = $AUTOLOAD; + $method =~ s/.*:://; + my $self = shift; tied(*$self)->$method(\@_); +} + +#------------------------------ +# PRELOAD +#------------------------------ +# Utility. +# +# Most methods like print(), getline(), etc. which work on the tied object +# via Perl's i/o operators (like 'print') are inherited from IO::Handle. +# +# Other methods, like seek() and sref(), we must delegate ourselves. +# AUTOLOAD takes care of these. +# +# However, it may be necessary to preload delegators into your +# own class. PRELOAD will do this. +# +sub PRELOAD { + my $class = shift; + foreach (@_) { + eval "sub ${class}::$_ { my \$s = shift; tied(*\$s)->$_(\@_) }"; + } +} + +# Preload delegators for some standard methods which we can't simply +# inherit from IO::Handle... for example, some IO::Handle methods +# assume that there is an underlying file descriptor. +# +PRELOAD IO::WrapTie::Master + qw(open opened close read clearerr eof seek tell setpos getpos); + + + +#------------------------------------------------------------ +package IO::WrapTie::Slave; +#------------------------------------------------------------ +# Teeny private class providing a new_tie constructor... +# +# HOW IT ALL WORKS: +# +# Slaves inherit from this class. +# +# When you send a new_tie() message to a tie-slave class (like IO::Scalar), +# it first determines what class should provide its master, via TIE_MASTER. +# In this case, IO::Scalar->TIE_MASTER would return IO::Scalar::Master. +# Then, we create a new master (an IO::Scalar::Master) with the same args +# sent to new_tie. +# +# In general, the new() method of the master is inherited directly +# from IO::WrapTie::Master. +# +sub new_tie { + my $self = shift; + $self->TIE_MASTER->new($self,@_); ### e.g., IO::Scalar::Master->new(@_) +} + +# Default class method for new_tie(). +# All your tie-slave class (like IO::Scalar) has to do is override this +# method with a method that returns the name of an appropriate "master" +# class for tying that slave. +# +sub TIE_MASTER { 'IO::WrapTie::Master' } + +#------------------------------ +1; +__END__ + + +package IO::WrapTie; ### for doc generator + + +=head1 NAME + +IO::WrapTie - wrap tieable objects in IO::Handle interface + +I<This is currently Alpha code, released for comments. + Please give me your feedback!> + + +=head1 SYNOPSIS + +First of all, you'll need tie(), so: + + require 5.004; + +I<Function interface (experimental).> +Use this with any existing class... + + use IO::WrapTie; + use FooHandle; ### implements TIEHANDLE interface + + ### Suppose we want a "FooHandle->new(&FOO_RDWR, 2)". + ### We can instead say... + + $FH = wraptie('FooHandle', &FOO_RDWR, 2); + + ### Now we can use... + print $FH "Hello, "; ### traditional operator syntax... + $FH->print("world!\n"); ### ...and OO syntax as well! + +I<OO interface (preferred).> +You can inherit from the IO::WrapTie::Slave mixin to get a +nifty C<new_tie()> constructor... + + #------------------------------ + package FooHandle; ### a class which can TIEHANDLE + + use IO::WrapTie; + @ISA = qw(IO::WrapTie::Slave); ### inherit new_tie() + ... + + + #------------------------------ + package main; + + $FH = FooHandle->new_tie(&FOO_RDWR, 2); ### $FH is an IO::WrapTie::Master + print $FH "Hello, "; ### traditional operator syntax + $FH->print("world!\n"); ### OO syntax + +See IO::Scalar as an example. It also shows you how to create classes +which work both with and without 5.004. + + +=head1 DESCRIPTION + +Suppose you have a class C<FooHandle>, where... + +=over 4 + +=item * + +B<FooHandle does not inherit from IO::Handle;> that is, it performs +filehandle-like I/O, but to something other than an underlying +file descriptor. Good examples are IO::Scalar (for printing to a +string) and IO::Lines (for printing to an array of lines). + +=item * + +B<FooHandle implements the TIEHANDLE interface> (see L<perltie>); +that is, it provides methods TIEHANDLE, GETC, PRINT, PRINTF, +READ, and READLINE. + +=item * + +B<FooHandle implements the traditional OO interface> of +FileHandle and IO::Handle; i.e., it contains methods like getline(), +read(), print(), seek(), tell(), eof(), etc. + +=back + + +Normally, users of your class would have two options: + + +=over 4 + +=item * + +B<Use only OO syntax,> and forsake named I/O operators like 'print'. + +=item * + +B<Use with tie,> and forsake treating it as a first-class object +(i.e., class-specific methods can only be invoked through the underlying +object via tied()... giving the object a "split personality"). + +=back + + +But now with IO::WrapTie, you can say: + + $WT = wraptie('FooHandle', &FOO_RDWR, 2); + $WT->print("Hello, world\n"); ### OO syntax + print $WT "Yes!\n"; ### Named operator syntax too! + $WT->weird_stuff; ### Other methods! + +And if you're authoring a class like FooHandle, just have it inherit +from C<IO::WrapTie::Slave> and that first line becomes even prettier: + + $WT = FooHandle->new_tie(&FOO_RDWR, 2); + +B<The bottom line:> now, almost any class can look and work exactly like +an IO::Handle... and be used both with OO and non-OO filehandle syntax. + + +=head1 HOW IT ALL WORKS + + +=head2 The data structures + +Consider this example code, using classes in this distribution: + + use IO::Scalar; + use IO::WrapTie; + + $WT = wraptie('IO::Scalar',\$s); + print $WT "Hello, "; + $WT->print("world!\n"); + +In it, the wraptie() function creates a data structure as follows: + + * $WT is a blessed reference to a tied filehandle + $WT glob; that glob is tied to the "Slave" object. + | * You would do all your i/o with $WT directly. + | + | + | ,---isa--> IO::WrapTie::Master >--isa--> IO::Handle + V / + .-------------. + | | + | | * Perl i/o operators work on the tied object, + | "Master" | invoking the TIEHANDLE methods. + | | * Method invocations are delegated to the tied + | | slave. + `-------------' + | + tied(*$WT) | .---isa--> IO::WrapTie::Slave + V / + .-------------. + | | + | "Slave" | * Instance of FileHandle-like class which doesn't + | | actually use file descriptors, like IO::Scalar. + | IO::Scalar | * The slave can be any kind of object. + | | * Must implement the TIEHANDLE interface. + `-------------' + + +I<NOTE:> just as an IO::Handle is really just a blessed reference to a +I<traditional> filehandle glob... so also, an IO::WrapTie::Master +is really just a blessed reference to a filehandle +glob I<which has been tied to some "slave" class.> + + +=head2 How wraptie() works + +=over 4 + +=item 1. + +The call to function C<wraptie(SLAVECLASS, TIEARGS...)> is +passed onto C<IO::WrapTie::Master::new()>. +Note that class IO::WrapTie::Master is a subclass of IO::Handle. + +=item 2. + +The C<IO::WrapTie::Master::new> method creates a new IO::Handle object, +reblessed into class IO::WrapTie::Master. This object is the I<master>, +which will be returned from the constructor. At the same time... + +=item 3. + +The C<new> method also creates the I<slave>: this is an instance +of SLAVECLASS which is created by tying the master's IO::Handle +to SLAVECLASS via C<tie(HANDLE, SLAVECLASS, TIEARGS...)>. +This call to C<tie()> creates the slave in the following manner: + +=item 4. + +Class SLAVECLASS is sent the message C<TIEHANDLE(TIEARGS...)>; it +will usually delegate this to C<SLAVECLASS::new(TIEARGS...)>, resulting +in a new instance of SLAVECLASS being created and returned. + +=item 5. + +Once both master and slave have been created, the master is returned +to the caller. + +=back + + +=head2 How I/O operators work (on the master) + +Consider using an i/o operator on the master: + + print $WT "Hello, world!\n"; + +Since the master ($WT) is really a [blessed] reference to a glob, +the normal Perl i/o operators like C<print> may be used on it. +They will just operate on the symbol part of the glob. + +Since the glob is tied to the slave, the slave's PRINT method +(part of the TIEHANDLE interface) will be automatically invoked. + +If the slave is an IO::Scalar, that means IO::Scalar::PRINT will be +invoked, and that method happens to delegate to the C<print()> method +of the same class. So the I<real> work is ultimately done by +IO::Scalar::print(). + + +=head2 How methods work (on the master) + +Consider using a method on the master: + + $WT->print("Hello, world!\n"); + +Since the master ($WT) is blessed into the class IO::WrapTie::Master, +Perl first attempts to find a C<print()> method there. Failing that, +Perl next attempts to find a C<print()> method in the superclass, +IO::Handle. It just so happens that there I<is> such a method; +that method merely invokes the C<print> i/o operator on the self object... +and for that, see above! + +But let's suppose we're dealing with a method which I<isn't> part +of IO::Handle... for example: + + my $sref = $WT->sref; + +In this case, the intuitive behavior is to have the master delegate the +method invocation to the slave (now do you see where the designations +come from?). This is indeed what happens: IO::WrapTie::Master contains +an AUTOLOAD method which performs the delegation. + +So: when C<sref()> can't be found in IO::Handle, the AUTOLOAD method +of IO::WrapTie::Master is invoked, and the standard behavior of +delegating the method to the underlying slave (here, an IO::Scalar) +is done. + +Sometimes, to get this to work properly, you may need to create +a subclass of IO::WrapTie::Master which is an effective master for +I<your> class, and do the delegation there. + + + + +=head1 NOTES + +B<Why not simply use the object's OO interface?> + Because that means forsaking the use of named operators +like print(), and you may need to pass the object to a subroutine +which will attempt to use those operators: + + $O = FooHandle->new(&FOO_RDWR, 2); + $O->print("Hello, world\n"); ### OO syntax is okay, BUT.... + + sub nope { print $_[0] "Nope!\n" } + X nope($O); ### ERROR!!! (not a glob ref) + + +B<Why not simply use tie()?> + Because (1) you have to use tied() to invoke methods in the +object's public interface (yuck), and (2) you may need to pass +the tied symbol to another subroutine which will attempt to treat +it in an OO-way... and that will break it: + + tie *T, 'FooHandle', &FOO_RDWR, 2; + print T "Hello, world\n"; ### Operator is okay, BUT... + + tied(*T)->other_stuff; ### yuck! AND... + + sub nope { shift->print("Nope!\n") } + X nope(\*T); ### ERROR!!! (method "print" on unblessed ref) + + +B<Why a master and slave? + Why not simply write FooHandle to inherit from IO::Handle?> + I tried this, with an implementation similar to that of IO::Socket. +The problem is that I<the whole point is to use this with objects +that don't have an underlying file/socket descriptor.>. +Subclassing IO::Handle will work fine for the OO stuff, and fine with +named operators I<if> you tie()... but if you just attempt to say: + + $IO = FooHandle->new(&FOO_RDWR, 2); + print $IO "Hello!\n"; + +you get a warning from Perl like: + + Filehandle GEN001 never opened + +because it's trying to do system-level i/o on an (unopened) file +descriptor. To avoid this, you apparently have to tie() the handle... +which brings us right back to where we started! At least the +IO::WrapTie mixin lets us say: + + $IO = FooHandle->new_tie(&FOO_RDWR, 2); + print $IO "Hello!\n"; + +and so is not I<too> bad. C<:-)> + + +=head1 WARNINGS + +Remember: this stuff is for doing FileHandle-like i/o on things +I<without underlying file descriptors>. If you have an underlying +file descriptor, you're better off just inheriting from IO::Handle. + +B<Be aware that new_tie() always returns an instance of a +kind of IO::WrapTie::Master...> it does B<not> return an instance +of the i/o class you're tying to! + +Invoking some methods on the master object causes AUTOLOAD to delegate +them to the slave object... so it I<looks> like you're manipulating a +"FooHandle" object directly, but you're not. + +I have not explored all the ramifications of this use of tie(). +I<Here there be dragons>. + + +=head1 VERSION + +$Id: WrapTie.pm,v 1.2 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHOR + +=item Primary Maintainer + +David F. Skoll (F<dfs@roaringpenguin.com>). + +=item Original Author + +Eryq (F<eryq@zeegee.com>). +President, ZeeGee Software Inc (F<http://www.zeegee.com>). + +=cut + diff --git a/Master/tlpkg/tlperl/lib/IO/Zlib.pm b/Master/tlpkg/tlperl/lib/IO/Zlib.pm new file mode 100755 index 00000000000..55534b4f374 --- /dev/null +++ b/Master/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; |