summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/IO
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/IO
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (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')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/AtomicFile.pm196
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm162
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm165
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Adapter/Identity.pm101
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Base.pm981
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm956
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm758
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Deflate.pm930
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Gzip.pm1242
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Gzip/Constants.pm148
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm1017
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Zip.pm1612
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm105
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Zlib/Constants.pm77
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm198
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Dir.pm248
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/File.pm204
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Handle.pm635
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/InnerFile.pm282
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Lines.pm184
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Pipe.pm257
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Poll.pm209
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Scalar.pm778
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/ScalarArray.pm791
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Seekable.pm128
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Select.pm381
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Socket.pm529
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Socket/INET.pm464
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Socket/SSL.pm2303
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Socket/UNIX.pm143
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/String.pm551
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Stringy.pm446
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Bunzip2.pm112
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm105
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Inflate.pm158
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm987
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm1018
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/Base.pm1474
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm858
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm1111
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm982
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm1110
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm1549
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Wrap.pm222
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/WrapTie.pm491
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IO/Zlib.pm652
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;