diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/IO | |
parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff) |
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/IO')
46 files changed, 0 insertions, 28010 deletions
diff --git a/Master/tlpkg/tlperl/lib/IO/AtomicFile.pm b/Master/tlpkg/tlperl/lib/IO/AtomicFile.pm deleted file mode 100755 index 89ad6f0e8f5..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/AtomicFile.pm +++ /dev/null @@ -1,196 +0,0 @@ -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 deleted file mode 100755 index 3e2e89f8e12..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm +++ /dev/null @@ -1,162 +0,0 @@ -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 deleted file mode 100755 index f23a9819c67..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm +++ /dev/null @@ -1,165 +0,0 @@ -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 deleted file mode 100755 index 16f14d8e7f3..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Identity.pm +++ /dev/null @@ -1,101 +0,0 @@ -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 deleted file mode 100755 index 5a20f60007b..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Base.pm +++ /dev/null @@ -1,981 +0,0 @@ - -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 deleted file mode 100755 index 4f8b4dadc36..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm +++ /dev/null @@ -1,956 +0,0 @@ -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 deleted file mode 100755 index 2a85ef55b19..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm +++ /dev/null @@ -1,758 +0,0 @@ -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 deleted file mode 100755 index 0f46e59d3a4..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Deflate.pm +++ /dev/null @@ -1,930 +0,0 @@ -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 deleted file mode 100755 index 1978b91b283..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Gzip.pm +++ /dev/null @@ -1,1242 +0,0 @@ - -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 deleted file mode 100755 index 8504330d188..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Gzip/Constants.pm +++ /dev/null @@ -1,148 +0,0 @@ -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 deleted file mode 100755 index b97b51c0509..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm +++ /dev/null @@ -1,1017 +0,0 @@ -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 deleted file mode 100755 index 5e37d78f97d..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Zip.pm +++ /dev/null @@ -1,1612 +0,0 @@ -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 deleted file mode 100755 index c8cb95342a2..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm +++ /dev/null @@ -1,105 +0,0 @@ -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 deleted file mode 100755 index 10fcf345f63..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Constants.pm +++ /dev/null @@ -1,77 +0,0 @@ - -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 deleted file mode 100755 index 6812bb409dc..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm +++ /dev/null @@ -1,198 +0,0 @@ -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 deleted file mode 100755 index cce392c2ce3..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Dir.pm +++ /dev/null @@ -1,248 +0,0 @@ -# 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 deleted file mode 100755 index d33d090d0b2..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/File.pm +++ /dev/null @@ -1,204 +0,0 @@ -# - -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 deleted file mode 100755 index 2f1f1b423bc..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Handle.pm +++ /dev/null @@ -1,635 +0,0 @@ -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 deleted file mode 100755 index 2023e42b8aa..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/InnerFile.pm +++ /dev/null @@ -1,282 +0,0 @@ -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 deleted file mode 100755 index 46c40a5492b..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Lines.pm +++ /dev/null @@ -1,184 +0,0 @@ -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 deleted file mode 100755 index 827cc48bfcd..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Pipe.pm +++ /dev/null @@ -1,257 +0,0 @@ -# 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 deleted file mode 100755 index e7fb0135069..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Poll.pm +++ /dev/null @@ -1,209 +0,0 @@ - -# 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 deleted file mode 100755 index 7a522821343..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Scalar.pm +++ /dev/null @@ -1,778 +0,0 @@ -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 deleted file mode 100755 index 8877ce60472..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/ScalarArray.pm +++ /dev/null @@ -1,791 +0,0 @@ -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 deleted file mode 100755 index db1effda287..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Seekable.pm +++ /dev/null @@ -1,128 +0,0 @@ -# - -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 deleted file mode 100755 index fc05fe70e9c..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Select.pm +++ /dev/null @@ -1,381 +0,0 @@ -# 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 deleted file mode 100755 index 2ef05a72fa7..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Socket.pm +++ /dev/null @@ -1,529 +0,0 @@ -# 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 deleted file mode 100755 index 2f0e5d1d7a6..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Socket/INET.pm +++ /dev/null @@ -1,464 +0,0 @@ -# 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 deleted file mode 100755 index bcf098f58f3..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Socket/SSL.pm +++ /dev/null @@ -1,2303 +0,0 @@ -#!/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 deleted file mode 100755 index baa092ba1fb..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm +++ /dev/null @@ -1,143 +0,0 @@ -# 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 deleted file mode 100755 index 4bc8e719601..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/String.pm +++ /dev/null @@ -1,551 +0,0 @@ -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 deleted file mode 100755 index 978e53caf3f..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Stringy.pm +++ /dev/null @@ -1,446 +0,0 @@ -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 deleted file mode 100755 index 98677e3c09f..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Bunzip2.pm +++ /dev/null @@ -1,112 +0,0 @@ -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 deleted file mode 100755 index 27de6e0f36b..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm +++ /dev/null @@ -1,105 +0,0 @@ -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 deleted file mode 100755 index aac1e413ffe..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Inflate.pm +++ /dev/null @@ -1,158 +0,0 @@ -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 deleted file mode 100755 index 68038f5d374..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm +++ /dev/null @@ -1,987 +0,0 @@ -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 deleted file mode 100755 index 5984921e25b..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm +++ /dev/null @@ -1,1018 +0,0 @@ -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 deleted file mode 100755 index 33f2ac23758..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/Base.pm +++ /dev/null @@ -1,1474 +0,0 @@ - -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 deleted file mode 100755 index b3988c41851..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm +++ /dev/null @@ -1,858 +0,0 @@ -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 deleted file mode 100755 index f3e4e6561f0..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm +++ /dev/null @@ -1,1111 +0,0 @@ - -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 deleted file mode 100755 index 956f62e0835..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm +++ /dev/null @@ -1,982 +0,0 @@ -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 deleted file mode 100755 index f017fa0f599..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm +++ /dev/null @@ -1,1110 +0,0 @@ -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 deleted file mode 100755 index e7d6849f66b..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm +++ /dev/null @@ -1,1549 +0,0 @@ -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 deleted file mode 100755 index 5a28392dd23..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Wrap.pm +++ /dev/null @@ -1,222 +0,0 @@ -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 deleted file mode 100755 index 5e22508bbd9..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/WrapTie.pm +++ /dev/null @@ -1,491 +0,0 @@ -# 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 deleted file mode 100755 index 55534b4f374..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Zlib.pm +++ /dev/null @@ -1,652 +0,0 @@ -# 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; |