summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/IO
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2010-05-12 16:54:37 +0000
committerNorbert Preining <preining@logic.at>2010-05-12 16:54:37 +0000
commit661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch)
tree2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/lib/IO
parentb645030efc22e13c2498a1522083634ab91b2de1 (diff)
move tlperl.straw to tlperl
git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/IO')
-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, 28010 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/IO/AtomicFile.pm b/Master/tlpkg/tlperl/lib/IO/AtomicFile.pm
new file mode 100755
index 00000000000..89ad6f0e8f5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/AtomicFile.pm
@@ -0,0 +1,196 @@
+package IO::AtomicFile;
+
+### DOCUMENTATION AT BOTTOM OF FILE
+
+# Be strict:
+use strict;
+
+# External modules:
+use IO::File;
+
+
+#------------------------------
+#
+# GLOBALS...
+#
+#------------------------------
+use vars qw($VERSION @ISA);
+
+# The package version, both in 1.23 style *and* usable by MakeMaker:
+$VERSION = "2.110";
+
+# Inheritance:
+@ISA = qw(IO::File);
+
+
+#------------------------------
+# new ARGS...
+#------------------------------
+# Class method, constructor.
+# Any arguments are sent to open().
+#
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new();
+ ${*$self}{'io_atomicfile_suffix'} = '';
+ $self->open(@_) if @_;
+ $self;
+}
+
+#------------------------------
+# DESTROY
+#------------------------------
+# Destructor.
+#
+sub DESTROY {
+ shift->close(1); ### like close, but raises fatal exception on failure
+}
+
+#------------------------------
+# open PATH, MODE
+#------------------------------
+# Class/instance method.
+#
+sub open {
+ my ($self, $path, $mode) = @_;
+ ref($self) or $self = $self->new; ### now we have an instance!
+
+ ### Create tmp path, and remember this info:
+ my $temp = "${path}..TMP" . ${*$self}{'io_atomicfile_suffix'};
+ ${*$self}{'io_atomicfile_temp'} = $temp;
+ ${*$self}{'io_atomicfile_path'} = $path;
+
+ ### Open the file! Returns filehandle on success, for use as a constructor:
+ $self->SUPER::open($temp, $mode) ? $self : undef;
+}
+
+#------------------------------
+# _closed [YESNO]
+#------------------------------
+# Instance method, private.
+# Are we already closed? Argument sets new value, returns previous one.
+#
+sub _closed {
+ my $self = shift;
+ my $oldval = ${*$self}{'io_atomicfile_closed'};
+ ${*$self}{'io_atomicfile_closed'} = shift if @_;
+ $oldval;
+}
+
+#------------------------------
+# close
+#------------------------------
+# Instance method.
+# Close the handle, and rename the temp file to its final name.
+#
+sub close {
+ my ($self, $die) = @_;
+ unless ($self->_closed(1)) { ### sentinel...
+ $self->SUPER::close();
+ rename(${*$self}{'io_atomicfile_temp'},
+ ${*$self}{'io_atomicfile_path'})
+ or ($die ? die "close atomic file: $!\n" : return undef);
+ }
+ 1;
+}
+
+#------------------------------
+# delete
+#------------------------------
+# Instance method.
+# Close the handle, and delete the temp file.
+#
+sub delete {
+ my $self = shift;
+ unless ($self->_closed(1)) { ### sentinel...
+ $self->SUPER::close();
+ return unlink(${*$self}{'io_atomicfile_temp'});
+ }
+ 1;
+}
+
+#------------------------------
+# detach
+#------------------------------
+# Instance method.
+# Close the handle, but DO NOT delete the temp file.
+#
+sub detach {
+ my $self = shift;
+ $self->SUPER::close() unless ($self->_closed(1));
+ 1;
+}
+
+#------------------------------
+1;
+__END__
+
+
+=head1 NAME
+
+IO::AtomicFile - write a file which is updated atomically
+
+
+=head1 SYNOPSIS
+
+ use IO::AtomicFile;
+
+ ### Write a temp file, and have it install itself when closed:
+ my $FH = IO::AtomicFile->open("bar.dat", "w");
+ print $FH "Hello!\n";
+ $FH->close || die "couldn't install atomic file: $!";
+
+ ### Write a temp file, but delete it before it gets installed:
+ my $FH = IO::AtomicFile->open("bar.dat", "w");
+ print $FH "Hello!\n";
+ $FH->delete;
+
+ ### Write a temp file, but neither install it nor delete it:
+ my $FH = IO::AtomicFile->open("bar.dat", "w");
+ print $FH "Hello!\n";
+ $FH->detach;
+
+
+=head1 DESCRIPTION
+
+This module is intended for people who need to update files
+reliably in the face of unexpected program termination.
+
+For example, you generally don't want to be halfway in the middle of
+writing I</etc/passwd> and have your program terminate! Even
+the act of writing a single scalar to a filehandle is I<not> atomic.
+
+But this module gives you true atomic updates, via rename().
+When you open a file I</foo/bar.dat> via this module, you are I<actually>
+opening a temporary file I</foo/bar.dat..TMP>, and writing your
+output there. The act of closing this file (either explicitly
+via close(), or implicitly via the destruction of the object)
+will cause rename() to be called... therefore, from the point
+of view of the outside world, the file's contents are updated
+in a single time quantum.
+
+To ensure that problems do not go undetected, the "close" method
+done by the destructor will raise a fatal exception if the rename()
+fails. The explicit close() just returns undef.
+
+You can also decide at any point to trash the file you've been
+building.
+
+
+=head1 AUTHOR
+
+=head2 Primary Maintainer
+
+David F. Skoll (F<dfs@roaringpenguin.com>).
+
+=head2 Original Author
+
+Eryq (F<eryq@zeegee.com>).
+President, ZeeGee Software Inc (F<http://www.zeegee.com>).
+
+
+=head1 REVISION
+
+$Revision: 1.2 $
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm
new file mode 100755
index 00000000000..3e2e89f8e12
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Bzip2.pm
@@ -0,0 +1,162 @@
+package IO::Compress::Adapter::Bzip2 ;
+
+use strict;
+use warnings;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(:Status);
+
+#use Compress::Bzip2 ;
+use Compress::Raw::Bzip2 2.024 ;
+
+our ($VERSION);
+$VERSION = '2.024';
+
+sub mkCompObject
+{
+ my $BlockSize100K = shift ;
+ my $WorkFactor = shift ;
+ my $Verbosity = shift ;
+
+ my ($def, $status) = new Compress::Raw::Bzip2(1, $BlockSize100K,
+ $WorkFactor, $Verbosity);
+ #my ($def, $status) = bzdeflateInit();
+ #-BlockSize100K => $params->value('BlockSize100K'),
+ #-WorkFactor => $params->value('WorkFactor');
+
+ return (undef, "Could not create Deflate object: $status", $status)
+ if $status != BZ_OK ;
+
+ return bless {'Def' => $def,
+ 'Error' => '',
+ 'ErrorNo' => 0,
+ } ;
+}
+
+sub compr
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ #my ($out, $status) = $def->bzdeflate(defined ${$_[0]} ? ${$_[0]} : "") ;
+ my $status = $def->bzdeflate($_[0], $_[1]) ;
+ $self->{ErrorNo} = $status;
+
+ if ($status != BZ_RUN_OK)
+ {
+ $self->{Error} = "Deflate Error: $status";
+ return STATUS_ERROR;
+ }
+
+ #${ $_[1] } .= $out if defined $out;
+
+ return STATUS_OK;
+}
+
+sub flush
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ #my ($out, $status) = $def->bzflush($opt);
+ #my $status = $def->bzflush($_[0], $opt);
+ my $status = $def->bzflush($_[0]);
+ $self->{ErrorNo} = $status;
+
+ if ($status != BZ_RUN_OK)
+ {
+ $self->{Error} = "Deflate Error: $status";
+ return STATUS_ERROR;
+ }
+
+ #${ $_[0] } .= $out if defined $out ;
+ return STATUS_OK;
+
+}
+
+sub close
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ #my ($out, $status) = $def->bzclose();
+ my $status = $def->bzclose($_[0]);
+ $self->{ErrorNo} = $status;
+
+ if ($status != BZ_STREAM_END)
+ {
+ $self->{Error} = "Deflate Error: $status";
+ return STATUS_ERROR;
+ }
+
+ #${ $_[0] } .= $out if defined $out ;
+ return STATUS_OK;
+
+}
+
+
+sub reset
+{
+ my $self = shift ;
+
+ my $outer = $self->{Outer};
+
+ my ($def, $status) = new Compress::Raw::Bzip2();
+ $self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ;
+
+ if ($status != BZ_OK)
+ {
+ $self->{Error} = "Cannot create Deflate object: $status";
+ return STATUS_ERROR;
+ }
+
+ $self->{Def} = $def;
+
+ return STATUS_OK;
+}
+
+sub compressedBytes
+{
+ my $self = shift ;
+ $self->{Def}->compressedBytes();
+}
+
+sub uncompressedBytes
+{
+ my $self = shift ;
+ $self->{Def}->uncompressedBytes();
+}
+
+#sub total_out
+#{
+# my $self = shift ;
+# 0;
+#}
+#
+
+#sub total_in
+#{
+# my $self = shift ;
+# $self->{Def}->total_in();
+#}
+#
+#sub crc32
+#{
+# my $self = shift ;
+# $self->{Def}->crc32();
+#}
+#
+#sub adler32
+#{
+# my $self = shift ;
+# $self->{Def}->adler32();
+#}
+
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm
new file mode 100755
index 00000000000..f23a9819c67
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Deflate.pm
@@ -0,0 +1,165 @@
+package IO::Compress::Adapter::Deflate ;
+
+use strict;
+use warnings;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(:Status);
+
+use Compress::Raw::Zlib 2.024 qw(Z_OK Z_FINISH MAX_WBITS) ;
+our ($VERSION);
+
+$VERSION = '2.024';
+
+sub mkCompObject
+{
+ my $crc32 = shift ;
+ my $adler32 = shift ;
+ my $level = shift ;
+ my $strategy = shift ;
+
+ my ($def, $status) = new Compress::Raw::Zlib::Deflate
+ -AppendOutput => 1,
+ -CRC32 => $crc32,
+ -ADLER32 => $adler32,
+ -Level => $level,
+ -Strategy => $strategy,
+ -WindowBits => - MAX_WBITS;
+
+ return (undef, "Cannot create Deflate object: $status", $status)
+ if $status != Z_OK;
+
+ return bless {'Def' => $def,
+ 'Error' => '',
+ } ;
+}
+
+sub compr
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ my $status = $def->deflate($_[0], $_[1]) ;
+ $self->{ErrorNo} = $status;
+
+ if ($status != Z_OK)
+ {
+ $self->{Error} = "Deflate Error: $status";
+ return STATUS_ERROR;
+ }
+
+ return STATUS_OK;
+}
+
+sub flush
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ my $opt = $_[1] || Z_FINISH;
+ my $status = $def->flush($_[0], $opt);
+ $self->{ErrorNo} = $status;
+
+ if ($status != Z_OK)
+ {
+ $self->{Error} = "Deflate Error: $status";
+ return STATUS_ERROR;
+ }
+
+ return STATUS_OK;
+
+}
+
+sub close
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ $def->flush($_[0], Z_FINISH)
+ if defined $def ;
+}
+
+sub reset
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ my $status = $def->deflateReset() ;
+ $self->{ErrorNo} = $status;
+ if ($status != Z_OK)
+ {
+ $self->{Error} = "Deflate Error: $status";
+ return STATUS_ERROR;
+ }
+
+ return STATUS_OK;
+}
+
+sub deflateParams
+{
+ my $self = shift ;
+
+ my $def = $self->{Def};
+
+ my $status = $def->deflateParams(@_);
+ $self->{ErrorNo} = $status;
+ if ($status != Z_OK)
+ {
+ $self->{Error} = "deflateParams Error: $status";
+ return STATUS_ERROR;
+ }
+
+ return STATUS_OK;
+}
+
+
+
+#sub total_out
+#{
+# my $self = shift ;
+# $self->{Def}->total_out();
+#}
+#
+#sub total_in
+#{
+# my $self = shift ;
+# $self->{Def}->total_in();
+#}
+
+sub compressedBytes
+{
+ my $self = shift ;
+
+ $self->{Def}->compressedBytes();
+}
+
+sub uncompressedBytes
+{
+ my $self = shift ;
+ $self->{Def}->uncompressedBytes();
+}
+
+
+
+
+sub crc32
+{
+ my $self = shift ;
+ $self->{Def}->crc32();
+}
+
+sub adler32
+{
+ my $self = shift ;
+ $self->{Def}->adler32();
+}
+
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Identity.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Identity.pm
new file mode 100755
index 00000000000..16f14d8e7f3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Adapter/Identity.pm
@@ -0,0 +1,101 @@
+package IO::Compress::Adapter::Identity ;
+
+use strict;
+use warnings;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(:Status);
+our ($VERSION);
+
+$VERSION = '2.024';
+
+sub mkCompObject
+{
+ my $level = shift ;
+ my $strategy = shift ;
+
+ return bless {
+ 'CompSize' => 0,
+ 'UnCompSize' => 0,
+ 'Error' => '',
+ 'ErrorNo' => 0,
+ } ;
+}
+
+sub compr
+{
+ my $self = shift ;
+
+ if (defined ${ $_[0] } && length ${ $_[0] }) {
+ $self->{CompSize} += length ${ $_[0] } ;
+ $self->{UnCompSize} = $self->{CompSize} ;
+
+ if ( ref $_[1] )
+ { ${ $_[1] } .= ${ $_[0] } }
+ else
+ { $_[1] .= ${ $_[0] } }
+ }
+
+ return STATUS_OK ;
+}
+
+sub flush
+{
+ my $self = shift ;
+
+ return STATUS_OK;
+}
+
+sub close
+{
+ my $self = shift ;
+
+ return STATUS_OK;
+}
+
+sub reset
+{
+ my $self = shift ;
+
+ $self->{CompSize} = 0;
+ $self->{UnCompSize} = 0;
+
+ return STATUS_OK;
+}
+
+sub deflateParams
+{
+ my $self = shift ;
+
+ return STATUS_OK;
+}
+
+#sub total_out
+#{
+# my $self = shift ;
+# return $self->{UnCompSize} ;
+#}
+#
+#sub total_in
+#{
+# my $self = shift ;
+# return $self->{UnCompSize} ;
+#}
+
+sub compressedBytes
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+sub uncompressedBytes
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+1;
+
+
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Base.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Base.pm
new file mode 100755
index 00000000000..5a20f60007b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Base.pm
@@ -0,0 +1,981 @@
+
+package IO::Compress::Base ;
+
+require 5.004 ;
+
+use strict ;
+use warnings;
+
+use IO::Compress::Base::Common 2.024 ;
+
+use IO::File ;
+use Scalar::Util qw(blessed readonly);
+
+#use File::Glob;
+#require Exporter ;
+use Carp ;
+use Symbol;
+use bytes;
+
+our (@ISA, $VERSION);
+@ISA = qw(Exporter IO::File);
+
+$VERSION = '2.024';
+
+#Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16.
+
+sub saveStatus
+{
+ my $self = shift ;
+ ${ *$self->{ErrorNo} } = shift() + 0 ;
+ ${ *$self->{Error} } = '' ;
+
+ return ${ *$self->{ErrorNo} } ;
+}
+
+
+sub saveErrorString
+{
+ my $self = shift ;
+ my $retval = shift ;
+ ${ *$self->{Error} } = shift ;
+ ${ *$self->{ErrorNo} } = shift() + 0 if @_ ;
+
+ return $retval;
+}
+
+sub croakError
+{
+ my $self = shift ;
+ $self->saveErrorString(0, $_[0]);
+ croak $_[0];
+}
+
+sub closeError
+{
+ my $self = shift ;
+ my $retval = shift ;
+
+ my $errno = *$self->{ErrorNo};
+ my $error = ${ *$self->{Error} };
+
+ $self->close();
+
+ *$self->{ErrorNo} = $errno ;
+ ${ *$self->{Error} } = $error ;
+
+ return $retval;
+}
+
+
+
+sub error
+{
+ my $self = shift ;
+ return ${ *$self->{Error} } ;
+}
+
+sub errorNo
+{
+ my $self = shift ;
+ return ${ *$self->{ErrorNo} } ;
+}
+
+
+sub writeAt
+{
+ my $self = shift ;
+ my $offset = shift;
+ my $data = shift;
+
+ if (defined *$self->{FH}) {
+ my $here = tell(*$self->{FH});
+ return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!)
+ if $here < 0 ;
+ seek(*$self->{FH}, $offset, SEEK_SET)
+ or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
+ defined *$self->{FH}->write($data, length $data)
+ or return $self->saveErrorString(undef, $!, $!) ;
+ seek(*$self->{FH}, $here, SEEK_SET)
+ or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
+ }
+ else {
+ substr(${ *$self->{Buffer} }, $offset, length($data)) = $data ;
+ }
+
+ return 1;
+}
+
+sub output
+{
+ my $self = shift ;
+ my $data = shift ;
+ my $last = shift ;
+
+ return 1
+ if length $data == 0 && ! $last ;
+
+ if ( *$self->{FilterEnvelope} ) {
+ *_ = \$data;
+ &{ *$self->{FilterEnvelope} }();
+ }
+
+ if (length $data) {
+ if ( defined *$self->{FH} ) {
+ defined *$self->{FH}->write( $data, length $data )
+ or return $self->saveErrorString(0, $!, $!);
+ }
+ else {
+ ${ *$self->{Buffer} } .= $data ;
+ }
+ }
+
+ return 1;
+}
+
+sub getOneShotParams
+{
+ return ( 'MultiStream' => [1, 1, Parse_boolean, 1],
+ );
+}
+
+sub checkParams
+{
+ my $self = shift ;
+ my $class = shift ;
+
+ my $got = shift || IO::Compress::Base::Parameters::new();
+
+ $got->parse(
+ {
+ # Generic Parameters
+ 'AutoClose' => [1, 1, Parse_boolean, 0],
+ #'Encode' => [1, 1, Parse_any, undef],
+ 'Strict' => [0, 1, Parse_boolean, 1],
+ 'Append' => [1, 1, Parse_boolean, 0],
+ 'BinModeIn' => [1, 1, Parse_boolean, 0],
+
+ 'FilterEnvelope' => [1, 1, Parse_any, undef],
+
+ $self->getExtraParams(),
+ *$self->{OneShot} ? $self->getOneShotParams()
+ : (),
+ },
+ @_) or $self->croakError("${class}: $got->{Error}") ;
+
+ return $got ;
+}
+
+sub _create
+{
+ my $obj = shift;
+ my $got = shift;
+
+ *$obj->{Closed} = 1 ;
+
+ my $class = ref $obj;
+ $obj->croakError("$class: Missing Output parameter")
+ if ! @_ && ! $got ;
+
+ my $outValue = shift ;
+ my $oneShot = 1 ;
+
+ if (! $got)
+ {
+ $oneShot = 0 ;
+ $got = $obj->checkParams($class, undef, @_)
+ or return undef ;
+ }
+
+ my $lax = ! $got->value('Strict') ;
+
+ my $outType = whatIsOutput($outValue);
+
+ $obj->ckOutputParam($class, $outValue)
+ or return undef ;
+
+ if ($outType eq 'buffer') {
+ *$obj->{Buffer} = $outValue;
+ }
+ else {
+ my $buff = "" ;
+ *$obj->{Buffer} = \$buff ;
+ }
+
+ # Merge implies Append
+ my $merge = $got->value('Merge') ;
+ my $appendOutput = $got->value('Append') || $merge ;
+ *$obj->{Append} = $appendOutput;
+ *$obj->{FilterEnvelope} = $got->value('FilterEnvelope') ;
+
+ if ($merge)
+ {
+ # Switch off Merge mode if output file/buffer is empty/doesn't exist
+ if (($outType eq 'buffer' && length $$outValue == 0 ) ||
+ ($outType ne 'buffer' && (! -e $outValue || (-w _ && -z _))) )
+ { $merge = 0 }
+ }
+
+ # If output is a file, check that it is writable
+ #no warnings;
+ #if ($outType eq 'filename' && -e $outValue && ! -w _)
+ # { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) }
+
+
+
+ if ($got->parsed('Encode')) {
+ my $want_encoding = $got->value('Encode');
+ *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding);
+ }
+
+ $obj->ckParams($got)
+ or $obj->croakError("${class}: " . $obj->error());
+
+
+ $obj->saveStatus(STATUS_OK) ;
+
+ my $status ;
+ if (! $merge)
+ {
+ *$obj->{Compress} = $obj->mkComp($got)
+ or return undef;
+
+ *$obj->{UnCompSize} = new U64 ;
+ *$obj->{CompSize} = new U64 ;
+
+ if ( $outType eq 'buffer') {
+ ${ *$obj->{Buffer} } = ''
+ unless $appendOutput ;
+ }
+ else {
+ if ($outType eq 'handle') {
+ *$obj->{FH} = $outValue ;
+ setBinModeOutput(*$obj->{FH}) ;
+ $outValue->flush() ;
+ *$obj->{Handle} = 1 ;
+ if ($appendOutput)
+ {
+ seek(*$obj->{FH}, 0, SEEK_END)
+ or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
+
+ }
+ }
+ elsif ($outType eq 'filename') {
+ no warnings;
+ my $mode = '>' ;
+ $mode = '>>'
+ if $appendOutput;
+ *$obj->{FH} = new IO::File "$mode $outValue"
+ or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ;
+ *$obj->{StdIO} = ($outValue eq '-');
+ setBinModeOutput(*$obj->{FH}) ;
+ }
+ }
+
+ *$obj->{Header} = $obj->mkHeader($got) ;
+ $obj->output( *$obj->{Header} )
+ or return undef;
+ }
+ else
+ {
+ *$obj->{Compress} = $obj->createMerge($outValue, $outType)
+ or return undef;
+ }
+
+ *$obj->{Closed} = 0 ;
+ *$obj->{AutoClose} = $got->value('AutoClose') ;
+ *$obj->{Output} = $outValue;
+ *$obj->{ClassName} = $class;
+ *$obj->{Got} = $got;
+ *$obj->{OneShot} = 0 ;
+
+ return $obj ;
+}
+
+sub ckOutputParam
+{
+ my $self = shift ;
+ my $from = shift ;
+ my $outType = whatIsOutput($_[0]);
+
+ $self->croakError("$from: output parameter not a filename, filehandle or scalar ref")
+ if ! $outType ;
+
+ #$self->croakError("$from: output filename is undef or null string")
+ #if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ;
+
+ $self->croakError("$from: output buffer is read-only")
+ if $outType eq 'buffer' && readonly(${ $_[0] });
+
+ return 1;
+}
+
+
+sub _def
+{
+ my $obj = shift ;
+
+ my $class= (caller)[0] ;
+ my $name = (caller(1))[3] ;
+
+ $obj->croakError("$name: expected at least 1 parameters\n")
+ unless @_ >= 1 ;
+
+ my $input = shift ;
+ my $haveOut = @_ ;
+ my $output = shift ;
+
+ my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output)
+ or return undef ;
+
+ push @_, $output if $haveOut && $x->{Hash};
+
+ *$obj->{OneShot} = 1 ;
+
+ my $got = $obj->checkParams($name, undef, @_)
+ or return undef ;
+
+ $x->{Got} = $got ;
+
+# if ($x->{Hash})
+# {
+# while (my($k, $v) = each %$input)
+# {
+# $v = \$input->{$k}
+# unless defined $v ;
+#
+# $obj->_singleTarget($x, 1, $k, $v, @_)
+# or return undef ;
+# }
+#
+# return keys %$input ;
+# }
+
+ if ($x->{GlobMap})
+ {
+ $x->{oneInput} = 1 ;
+ foreach my $pair (@{ $x->{Pairs} })
+ {
+ my ($from, $to) = @$pair ;
+ $obj->_singleTarget($x, 1, $from, $to, @_)
+ or return undef ;
+ }
+
+ return scalar @{ $x->{Pairs} } ;
+ }
+
+ if (! $x->{oneOutput} )
+ {
+ my $inFile = ($x->{inType} eq 'filenames'
+ || $x->{inType} eq 'filename');
+
+ $x->{inType} = $inFile ? 'filename' : 'buffer';
+
+ foreach my $in ($x->{oneInput} ? $input : @$input)
+ {
+ my $out ;
+ $x->{oneInput} = 1 ;
+
+ $obj->_singleTarget($x, $inFile, $in, \$out, @_)
+ or return undef ;
+
+ push @$output, \$out ;
+ #if ($x->{outType} eq 'array')
+ # { push @$output, \$out }
+ #else
+ # { $output->{$in} = \$out }
+ }
+
+ return 1 ;
+ }
+
+ # finally the 1 to 1 and n to 1
+ return $obj->_singleTarget($x, 1, $input, $output, @_);
+
+ croak "should not be here" ;
+}
+
+sub _singleTarget
+{
+ my $obj = shift ;
+ my $x = shift ;
+ my $inputIsFilename = shift;
+ my $input = shift;
+
+ if ($x->{oneInput})
+ {
+ $obj->getFileInfo($x->{Got}, $input)
+ if isaFilename($input) and $inputIsFilename ;
+
+ my $z = $obj->_create($x->{Got}, @_)
+ or return undef ;
+
+
+ defined $z->_wr2($input, $inputIsFilename)
+ or return $z->closeError(undef) ;
+
+ return $z->close() ;
+ }
+ else
+ {
+ my $afterFirst = 0 ;
+ my $inputIsFilename = ($x->{inType} ne 'array');
+ my $keep = $x->{Got}->clone();
+
+ #for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
+ for my $element ( @$input)
+ {
+ my $isFilename = isaFilename($element);
+
+ if ( $afterFirst ++ )
+ {
+ defined addInterStream($obj, $element, $isFilename)
+ or return $obj->closeError(undef) ;
+ }
+ else
+ {
+ $obj->getFileInfo($x->{Got}, $element)
+ if $isFilename;
+
+ $obj->_create($x->{Got}, @_)
+ or return undef ;
+ }
+
+ defined $obj->_wr2($element, $isFilename)
+ or return $obj->closeError(undef) ;
+
+ *$obj->{Got} = $keep->clone();
+ }
+ return $obj->close() ;
+ }
+
+}
+
+sub _wr2
+{
+ my $self = shift ;
+
+ my $source = shift ;
+ my $inputIsFilename = shift;
+
+ my $input = $source ;
+ if (! $inputIsFilename)
+ {
+ $input = \$source
+ if ! ref $source;
+ }
+
+ if ( ref $input && ref $input eq 'SCALAR' )
+ {
+ return $self->syswrite($input, @_) ;
+ }
+
+ if ( ! ref $input || isaFilehandle($input))
+ {
+ my $isFilehandle = isaFilehandle($input) ;
+
+ my $fh = $input ;
+
+ if ( ! $isFilehandle )
+ {
+ $fh = new IO::File "<$input"
+ or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ;
+ }
+ binmode $fh if *$self->{Got}->valueOrDefault('BinModeIn') ;
+
+ my $status ;
+ my $buff ;
+ my $count = 0 ;
+ while ($status = read($fh, $buff, 16 * 1024)) {
+ $count += length $buff;
+ defined $self->syswrite($buff, @_)
+ or return undef ;
+ }
+
+ return $self->saveErrorString(undef, $!, $!)
+ if ! defined $status ;
+
+ if ( (!$isFilehandle || *$self->{AutoClose}) && $input ne '-')
+ {
+ $fh->close()
+ or return undef ;
+ }
+
+ return $count ;
+ }
+
+ croak "Should not be here";
+ return undef;
+}
+
+sub addInterStream
+{
+ my $self = shift ;
+ my $input = shift ;
+ my $inputIsFilename = shift ;
+
+ if (*$self->{Got}->value('MultiStream'))
+ {
+ $self->getFileInfo(*$self->{Got}, $input)
+ #if isaFilename($input) and $inputIsFilename ;
+ if isaFilename($input) ;
+
+ # TODO -- newStream needs to allow gzip/zip header to be modified
+ return $self->newStream();
+ }
+ elsif (*$self->{Got}->value('AutoFlush'))
+ {
+ #return $self->flush(Z_FULL_FLUSH);
+ }
+
+ return 1 ;
+}
+
+sub getFileInfo
+{
+}
+
+sub TIEHANDLE
+{
+ return $_[0] if ref($_[0]);
+ die "OOPS\n" ;
+}
+
+sub UNTIE
+{
+ my $self = shift ;
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ local ($., $@, $!, $^E, $?);
+
+ $self->close() ;
+
+ # TODO - memory leak with 5.8.0 - this isn't called until
+ # global destruction
+ #
+ %{ *$self } = () ;
+ undef $self ;
+}
+
+
+
+sub filterUncompressed
+{
+}
+
+sub syswrite
+{
+ my $self = shift ;
+
+ my $buffer ;
+ if (ref $_[0] ) {
+ $self->croakError( *$self->{ClassName} . "::write: not a scalar reference" )
+ unless ref $_[0] eq 'SCALAR' ;
+ $buffer = $_[0] ;
+ }
+ else {
+ $buffer = \$_[0] ;
+ }
+
+ $] >= 5.008 and ( utf8::downgrade($$buffer, 1)
+ or croak "Wide character in " . *$self->{ClassName} . "::write:");
+
+
+ if (@_ > 1) {
+ my $slen = defined $$buffer ? length($$buffer) : 0;
+ my $len = $slen;
+ my $offset = 0;
+ $len = $_[1] if $_[1] < $len;
+
+ if (@_ > 2) {
+ $offset = $_[2] || 0;
+ $self->croakError(*$self->{ClassName} . "::write: offset outside string")
+ if $offset > $slen;
+ if ($offset < 0) {
+ $offset += $slen;
+ $self->croakError( *$self->{ClassName} . "::write: offset outside string") if $offset < 0;
+ }
+ my $rem = $slen - $offset;
+ $len = $rem if $rem < $len;
+ }
+
+ $buffer = \substr($$buffer, $offset, $len) ;
+ }
+
+ return 0 if ! defined $$buffer || length $$buffer == 0 ;
+
+ if (*$self->{Encoding}) {
+ $$buffer = *$self->{Encoding}->encode($$buffer);
+ }
+
+ $self->filterUncompressed($buffer);
+
+ my $buffer_length = defined $$buffer ? length($$buffer) : 0 ;
+ *$self->{UnCompSize}->add($buffer_length) ;
+
+ my $outBuffer='';
+ my $status = *$self->{Compress}->compr($buffer, $outBuffer) ;
+
+ return $self->saveErrorString(undef, *$self->{Compress}{Error},
+ *$self->{Compress}{ErrorNo})
+ if $status == STATUS_ERROR;
+
+ *$self->{CompSize}->add(length $outBuffer) ;
+
+ $self->output($outBuffer)
+ or return undef;
+
+ return $buffer_length;
+}
+
+sub print
+{
+ my $self = shift;
+
+ #if (ref $self) {
+ # $self = *$self{GLOB} ;
+ #}
+
+ if (defined $\) {
+ if (defined $,) {
+ defined $self->syswrite(join($,, @_) . $\);
+ } else {
+ defined $self->syswrite(join("", @_) . $\);
+ }
+ } else {
+ if (defined $,) {
+ defined $self->syswrite(join($,, @_));
+ } else {
+ defined $self->syswrite(join("", @_));
+ }
+ }
+}
+
+sub printf
+{
+ my $self = shift;
+ my $fmt = shift;
+ defined $self->syswrite(sprintf($fmt, @_));
+}
+
+
+
+sub flush
+{
+ my $self = shift ;
+
+ my $outBuffer='';
+ my $status = *$self->{Compress}->flush($outBuffer, @_) ;
+ return $self->saveErrorString(0, *$self->{Compress}{Error},
+ *$self->{Compress}{ErrorNo})
+ if $status == STATUS_ERROR;
+
+ if ( defined *$self->{FH} ) {
+ *$self->{FH}->clearerr();
+ }
+
+ *$self->{CompSize}->add(length $outBuffer) ;
+
+ $self->output($outBuffer)
+ or return 0;
+
+ if ( defined *$self->{FH} ) {
+ defined *$self->{FH}->flush()
+ or return $self->saveErrorString(0, $!, $!);
+ }
+
+ return 1;
+}
+
+sub newStream
+{
+ my $self = shift ;
+
+ $self->_writeTrailer()
+ or return 0 ;
+
+ my $got = $self->checkParams('newStream', *$self->{Got}, @_)
+ or return 0 ;
+
+ $self->ckParams($got)
+ or $self->croakError("newStream: $self->{Error}");
+
+ *$self->{Compress} = $self->mkComp($got)
+ or return 0;
+
+ *$self->{Header} = $self->mkHeader($got) ;
+ $self->output(*$self->{Header} )
+ or return 0;
+
+ *$self->{UnCompSize}->reset();
+ *$self->{CompSize}->reset();
+
+ return 1 ;
+}
+
+sub reset
+{
+ my $self = shift ;
+ return *$self->{Compress}->reset() ;
+}
+
+sub _writeTrailer
+{
+ my $self = shift ;
+
+ my $trailer = '';
+
+ my $status = *$self->{Compress}->close($trailer) ;
+ return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo})
+ if $status == STATUS_ERROR;
+
+ *$self->{CompSize}->add(length $trailer) ;
+
+ $trailer .= $self->mkTrailer();
+ defined $trailer
+ or return 0;
+
+ return $self->output($trailer);
+}
+
+sub _writeFinalTrailer
+{
+ my $self = shift ;
+
+ return $self->output($self->mkFinalTrailer());
+}
+
+sub close
+{
+ my $self = shift ;
+
+ return 1 if *$self->{Closed} || ! *$self->{Compress} ;
+ *$self->{Closed} = 1 ;
+
+ untie *$self
+ if $] >= 5.008 ;
+
+ $self->_writeTrailer()
+ or return 0 ;
+
+ $self->_writeFinalTrailer()
+ or return 0 ;
+
+ $self->output( "", 1 )
+ or return 0;
+
+ if (defined *$self->{FH}) {
+
+ #if (! *$self->{Handle} || *$self->{AutoClose}) {
+ if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
+ $! = 0 ;
+ *$self->{FH}->close()
+ or return $self->saveErrorString(0, $!, $!);
+ }
+ delete *$self->{FH} ;
+ # This delete can set $! in older Perls, so reset the errno
+ $! = 0 ;
+ }
+
+ return 1;
+}
+
+
+#sub total_in
+#sub total_out
+#sub msg
+#
+#sub crc
+#{
+# my $self = shift ;
+# return *$self->{Compress}->crc32() ;
+#}
+#
+#sub msg
+#{
+# my $self = shift ;
+# return *$self->{Compress}->msg() ;
+#}
+#
+#sub dict_adler
+#{
+# my $self = shift ;
+# return *$self->{Compress}->dict_adler() ;
+#}
+#
+#sub get_Level
+#{
+# my $self = shift ;
+# return *$self->{Compress}->get_Level() ;
+#}
+#
+#sub get_Strategy
+#{
+# my $self = shift ;
+# return *$self->{Compress}->get_Strategy() ;
+#}
+
+
+sub tell
+{
+ my $self = shift ;
+
+ return *$self->{UnCompSize}->get32bit() ;
+}
+
+sub eof
+{
+ my $self = shift ;
+
+ return *$self->{Closed} ;
+}
+
+
+sub seek
+{
+ my $self = shift ;
+ my $position = shift;
+ my $whence = shift ;
+
+ my $here = $self->tell() ;
+ my $target = 0 ;
+
+ #use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
+ use IO::Handle ;
+
+ if ($whence == IO::Handle::SEEK_SET) {
+ $target = $position ;
+ }
+ elsif ($whence == IO::Handle::SEEK_CUR || $whence == IO::Handle::SEEK_END) {
+ $target = $here + $position ;
+ }
+ else {
+ $self->croakError(*$self->{ClassName} . "::seek: unknown value, $whence, for whence parameter");
+ }
+
+ # short circuit if seeking to current offset
+ return 1 if $target == $here ;
+
+ # Outlaw any attempt to seek backwards
+ $self->croakError(*$self->{ClassName} . "::seek: cannot seek backwards")
+ if $target < $here ;
+
+ # Walk the file to the new offset
+ my $offset = $target - $here ;
+
+ my $buffer ;
+ defined $self->syswrite("\x00" x $offset)
+ or return 0;
+
+ return 1 ;
+}
+
+sub binmode
+{
+ 1;
+# my $self = shift ;
+# return defined *$self->{FH}
+# ? binmode *$self->{FH}
+# : 1 ;
+}
+
+sub fileno
+{
+ my $self = shift ;
+ return defined *$self->{FH}
+ ? *$self->{FH}->fileno()
+ : undef ;
+}
+
+sub opened
+{
+ my $self = shift ;
+ return ! *$self->{Closed} ;
+}
+
+sub autoflush
+{
+ my $self = shift ;
+ return defined *$self->{FH}
+ ? *$self->{FH}->autoflush(@_)
+ : undef ;
+}
+
+sub input_line_number
+{
+ return undef ;
+}
+
+
+sub _notAvailable
+{
+ my $name = shift ;
+ return sub { croak "$name Not Available: File opened only for output" ; } ;
+}
+
+*read = _notAvailable('read');
+*READ = _notAvailable('read');
+*readline = _notAvailable('readline');
+*READLINE = _notAvailable('readline');
+*getc = _notAvailable('getc');
+*GETC = _notAvailable('getc');
+
+*FILENO = \&fileno;
+*PRINT = \&print;
+*PRINTF = \&printf;
+*WRITE = \&syswrite;
+*write = \&syswrite;
+*SEEK = \&seek;
+*TELL = \&tell;
+*EOF = \&eof;
+*CLOSE = \&close;
+*BINMODE = \&binmode;
+
+#*sysread = \&_notAvailable;
+#*syswrite = \&_write;
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Compress::Base - Base Class for IO::Compress modules
+
+=head1 SYNOPSIS
+
+ use IO::Compress::Base ;
+
+=head1 DESCRIPTION
+
+This module is not intended for direct use in application code. Its sole
+purpose if to to be sub-classed by IO::Compress modules.
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm
new file mode 100755
index 00000000000..4f8b4dadc36
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Base/Common.pm
@@ -0,0 +1,956 @@
+package IO::Compress::Base::Common;
+
+use strict ;
+use warnings;
+use bytes;
+
+use Carp;
+use Scalar::Util qw(blessed readonly);
+use File::GlobMapper;
+
+require Exporter;
+our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
+@ISA = qw(Exporter);
+$VERSION = '2.024';
+
+@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput
+ isaFileGlobString cleanFileGlobString oneTarget
+ setBinModeInput setBinModeOutput
+ ckInOutParams
+ createSelfTiedObject
+ getEncoding
+
+ WANT_CODE
+ WANT_EXT
+ WANT_UNDEF
+ WANT_HASH
+
+ STATUS_OK
+ STATUS_ENDSTREAM
+ STATUS_EOF
+ STATUS_ERROR
+ );
+
+%EXPORT_TAGS = ( Status => [qw( STATUS_OK
+ STATUS_ENDSTREAM
+ STATUS_EOF
+ STATUS_ERROR
+ )]);
+
+
+use constant STATUS_OK => 0;
+use constant STATUS_ENDSTREAM => 1;
+use constant STATUS_EOF => 2;
+use constant STATUS_ERROR => -1;
+
+sub hasEncode()
+{
+ if (! defined $HAS_ENCODE) {
+ eval
+ {
+ require Encode;
+ Encode->import();
+ };
+
+ $HAS_ENCODE = $@ ? 0 : 1 ;
+ }
+
+ return $HAS_ENCODE;
+}
+
+sub getEncoding($$$)
+{
+ my $obj = shift;
+ my $class = shift ;
+ my $want_encoding = shift ;
+
+ $obj->croakError("$class: Encode module needed to use -Encode")
+ if ! hasEncode();
+
+ my $encoding = Encode::find_encoding($want_encoding);
+
+ $obj->croakError("$class: Encoding '$want_encoding' is not available")
+ if ! $encoding;
+
+ return $encoding;
+}
+
+our ($needBinmode);
+$needBinmode = ($^O eq 'MSWin32' ||
+ ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
+ ? 1 : 1 ;
+
+sub setBinModeInput($)
+{
+ my $handle = shift ;
+
+ binmode $handle
+ if $needBinmode;
+}
+
+sub setBinModeOutput($)
+{
+ my $handle = shift ;
+
+ binmode $handle
+ if $needBinmode;
+}
+
+sub isaFilehandle($)
+{
+ use utf8; # Pragma needed to keep Perl 5.6.0 happy
+ return (defined $_[0] and
+ (UNIVERSAL::isa($_[0],'GLOB') or
+ UNIVERSAL::isa($_[0],'IO::Handle') or
+ UNIVERSAL::isa(\$_[0],'GLOB'))
+ )
+}
+
+sub isaFilename($)
+{
+ return (defined $_[0] and
+ ! ref $_[0] and
+ UNIVERSAL::isa(\$_[0], 'SCALAR'));
+}
+
+sub isaFileGlobString
+{
+ return defined $_[0] && $_[0] =~ /^<.*>$/;
+}
+
+sub cleanFileGlobString
+{
+ my $string = shift ;
+
+ $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
+
+ return $string;
+}
+
+use constant WANT_CODE => 1 ;
+use constant WANT_EXT => 2 ;
+use constant WANT_UNDEF => 4 ;
+#use constant WANT_HASH => 8 ;
+use constant WANT_HASH => 0 ;
+
+sub whatIsInput($;$)
+{
+ my $got = whatIs(@_);
+
+ if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
+ {
+ #use IO::File;
+ $got = 'handle';
+ $_[0] = *STDIN;
+ #$_[0] = new IO::File("<-");
+ }
+
+ return $got;
+}
+
+sub whatIsOutput($;$)
+{
+ my $got = whatIs(@_);
+
+ if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
+ {
+ $got = 'handle';
+ $_[0] = *STDOUT;
+ #$_[0] = new IO::File(">-");
+ }
+
+ return $got;
+}
+
+sub whatIs ($;$)
+{
+ return 'handle' if isaFilehandle($_[0]);
+
+ my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
+ my $extended = defined $_[1] && $_[1] & WANT_EXT ;
+ my $undef = defined $_[1] && $_[1] & WANT_UNDEF ;
+ my $hash = defined $_[1] && $_[1] & WANT_HASH ;
+
+ return 'undef' if ! defined $_[0] && $undef ;
+
+ if (ref $_[0]) {
+ return '' if blessed($_[0]); # is an object
+ #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
+ return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
+ return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ;
+ return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ;
+ return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ;
+ return '';
+ }
+
+ return 'fileglob' if $extended && isaFileGlobString($_[0]);
+ return 'filename';
+}
+
+sub oneTarget
+{
+ return $_[0] =~ /^(code|handle|buffer|filename)$/;
+}
+
+sub IO::Compress::Base::Validator::new
+{
+ my $class = shift ;
+
+ my $Class = shift ;
+ my $error_ref = shift ;
+ my $reportClass = shift ;
+
+ my %data = (Class => $Class,
+ Error => $error_ref,
+ reportClass => $reportClass,
+ ) ;
+
+ my $obj = bless \%data, $class ;
+
+ local $Carp::CarpLevel = 1;
+
+ my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH);
+ my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
+
+ my $oneInput = $data{oneInput} = oneTarget($inType);
+ my $oneOutput = $data{oneOutput} = oneTarget($outType);
+
+ if (! $inType)
+ {
+ $obj->croakError("$reportClass: illegal input parameter") ;
+ #return undef ;
+ }
+
+# if ($inType eq 'hash')
+# {
+# $obj->{Hash} = 1 ;
+# $obj->{oneInput} = 1 ;
+# return $obj->validateHash($_[0]);
+# }
+
+ if (! $outType)
+ {
+ $obj->croakError("$reportClass: illegal output parameter") ;
+ #return undef ;
+ }
+
+
+ if ($inType ne 'fileglob' && $outType eq 'fileglob')
+ {
+ $obj->croakError("Need input fileglob for outout fileglob");
+ }
+
+# if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
+# {
+# $obj->croakError("input must ne filename or fileglob when output is a hash");
+# }
+
+ if ($inType eq 'fileglob' && $outType eq 'fileglob')
+ {
+ $data{GlobMap} = 1 ;
+ $data{inType} = $data{outType} = 'filename';
+ my $mapper = new File::GlobMapper($_[0], $_[1]);
+ if ( ! $mapper )
+ {
+ return $obj->saveErrorString($File::GlobMapper::Error) ;
+ }
+ $data{Pairs} = $mapper->getFileMap();
+
+ return $obj;
+ }
+
+ $obj->croakError("$reportClass: input and output $inType are identical")
+ if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
+
+ if ($inType eq 'fileglob') # && $outType ne 'fileglob'
+ {
+ my $glob = cleanFileGlobString($_[0]);
+ my @inputs = glob($glob);
+
+ if (@inputs == 0)
+ {
+ # TODO -- legal or die?
+ die "globmap matched zero file -- legal or die???" ;
+ }
+ elsif (@inputs == 1)
+ {
+ $obj->validateInputFilenames($inputs[0])
+ or return undef;
+ $_[0] = $inputs[0] ;
+ $data{inType} = 'filename' ;
+ $data{oneInput} = 1;
+ }
+ else
+ {
+ $obj->validateInputFilenames(@inputs)
+ or return undef;
+ $_[0] = [ @inputs ] ;
+ $data{inType} = 'filenames' ;
+ }
+ }
+ elsif ($inType eq 'filename')
+ {
+ $obj->validateInputFilenames($_[0])
+ or return undef;
+ }
+ elsif ($inType eq 'array')
+ {
+ $data{inType} = 'filenames' ;
+ $obj->validateInputArray($_[0])
+ or return undef ;
+ }
+
+ return $obj->saveErrorString("$reportClass: output buffer is read-only")
+ if $outType eq 'buffer' && readonly(${ $_[1] });
+
+ if ($outType eq 'filename' )
+ {
+ $obj->croakError("$reportClass: output filename is undef or null string")
+ if ! defined $_[1] || $_[1] eq '' ;
+
+ if (-e $_[1])
+ {
+ if (-d _ )
+ {
+ return $obj->saveErrorString("output file '$_[1]' is a directory");
+ }
+ }
+ }
+
+ return $obj ;
+}
+
+sub IO::Compress::Base::Validator::saveErrorString
+{
+ my $self = shift ;
+ ${ $self->{Error} } = shift ;
+ return undef;
+
+}
+
+sub IO::Compress::Base::Validator::croakError
+{
+ my $self = shift ;
+ $self->saveErrorString($_[0]);
+ croak $_[0];
+}
+
+
+
+sub IO::Compress::Base::Validator::validateInputFilenames
+{
+ my $self = shift ;
+
+ foreach my $filename (@_)
+ {
+ $self->croakError("$self->{reportClass}: input filename is undef or null string")
+ if ! defined $filename || $filename eq '' ;
+
+ next if $filename eq '-';
+
+ if (! -e $filename )
+ {
+ return $self->saveErrorString("input file '$filename' does not exist");
+ }
+
+ if (-d _ )
+ {
+ return $self->saveErrorString("input file '$filename' is a directory");
+ }
+
+ if (! -r _ )
+ {
+ return $self->saveErrorString("cannot open file '$filename': $!");
+ }
+ }
+
+ return 1 ;
+}
+
+sub IO::Compress::Base::Validator::validateInputArray
+{
+ my $self = shift ;
+
+ if ( @{ $_[0] } == 0 )
+ {
+ return $self->saveErrorString("empty array reference") ;
+ }
+
+ foreach my $element ( @{ $_[0] } )
+ {
+ my $inType = whatIsInput($element);
+
+ if (! $inType)
+ {
+ $self->croakError("unknown input parameter") ;
+ }
+ elsif($inType eq 'filename')
+ {
+ $self->validateInputFilenames($element)
+ or return undef ;
+ }
+ else
+ {
+ $self->croakError("not a filename") ;
+ }
+ }
+
+ return 1 ;
+}
+
+#sub IO::Compress::Base::Validator::validateHash
+#{
+# my $self = shift ;
+# my $href = shift ;
+#
+# while (my($k, $v) = each %$href)
+# {
+# my $ktype = whatIsInput($k);
+# my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
+#
+# if ($ktype ne 'filename')
+# {
+# return $self->saveErrorString("hash key not filename") ;
+# }
+#
+# my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
+# if (! $valid{$vtype})
+# {
+# return $self->saveErrorString("hash value not ok") ;
+# }
+# }
+#
+# return $self ;
+#}
+
+sub createSelfTiedObject
+{
+ my $class = shift || (caller)[0] ;
+ my $error_ref = shift ;
+
+ my $obj = bless Symbol::gensym(), ref($class) || $class;
+ tie *$obj, $obj if $] >= 5.005;
+ *$obj->{Closed} = 1 ;
+ $$error_ref = '';
+ *$obj->{Error} = $error_ref ;
+ my $errno = 0 ;
+ *$obj->{ErrorNo} = \$errno ;
+
+ return $obj;
+}
+
+
+
+#package Parse::Parameters ;
+#
+#
+#require Exporter;
+#our ($VERSION, @ISA, @EXPORT);
+#$VERSION = '2.000_08';
+#@ISA = qw(Exporter);
+
+$EXPORT_TAGS{Parse} = [qw( ParseParameters
+ Parse_any Parse_unsigned Parse_signed
+ Parse_boolean Parse_custom Parse_string
+ Parse_multiple Parse_writable_scalar
+ )
+ ];
+
+push @EXPORT, @{ $EXPORT_TAGS{Parse} } ;
+
+use constant Parse_any => 0x01;
+use constant Parse_unsigned => 0x02;
+use constant Parse_signed => 0x04;
+use constant Parse_boolean => 0x08;
+use constant Parse_string => 0x10;
+use constant Parse_custom => 0x12;
+
+#use constant Parse_store_ref => 0x100 ;
+use constant Parse_multiple => 0x100 ;
+use constant Parse_writable => 0x200 ;
+use constant Parse_writable_scalar => 0x400 | Parse_writable ;
+
+use constant OFF_PARSED => 0 ;
+use constant OFF_TYPE => 1 ;
+use constant OFF_DEFAULT => 2 ;
+use constant OFF_FIXED => 3 ;
+use constant OFF_FIRST_ONLY => 4 ;
+use constant OFF_STICKY => 5 ;
+
+
+
+sub ParseParameters
+{
+ my $level = shift || 0 ;
+
+ my $sub = (caller($level + 1))[3] ;
+ local $Carp::CarpLevel = 1 ;
+
+ return $_[1]
+ if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters");
+
+ my $p = new IO::Compress::Base::Parameters() ;
+ $p->parse(@_)
+ or croak "$sub: $p->{Error}" ;
+
+ return $p;
+}
+
+#package IO::Compress::Base::Parameters;
+
+use strict;
+use warnings;
+use Carp;
+
+sub IO::Compress::Base::Parameters::new
+{
+ my $class = shift ;
+
+ my $obj = { Error => '',
+ Got => {},
+ } ;
+
+ #return bless $obj, ref($class) || $class || __PACKAGE__ ;
+ return bless $obj, 'IO::Compress::Base::Parameters' ;
+}
+
+sub IO::Compress::Base::Parameters::setError
+{
+ my $self = shift ;
+ my $error = shift ;
+ my $retval = @_ ? shift : undef ;
+
+ $self->{Error} = $error ;
+ return $retval;
+}
+
+#sub getError
+#{
+# my $self = shift ;
+# return $self->{Error} ;
+#}
+
+sub IO::Compress::Base::Parameters::parse
+{
+ my $self = shift ;
+
+ my $default = shift ;
+
+ my $got = $self->{Got} ;
+ my $firstTime = keys %{ $got } == 0 ;
+ my $other;
+
+ my (@Bad) ;
+ my @entered = () ;
+
+ # Allow the options to be passed as a hash reference or
+ # as the complete hash.
+ if (@_ == 0) {
+ @entered = () ;
+ }
+ elsif (@_ == 1) {
+ my $href = $_[0] ;
+
+ return $self->setError("Expected even number of parameters, got 1")
+ if ! defined $href or ! ref $href or ref $href ne "HASH" ;
+
+ foreach my $key (keys %$href) {
+ push @entered, $key ;
+ push @entered, \$href->{$key} ;
+ }
+ }
+ else {
+ my $count = @_;
+ return $self->setError("Expected even number of parameters, got $count")
+ if $count % 2 != 0 ;
+
+ for my $i (0.. $count / 2 - 1) {
+ if ($_[2 * $i] eq '__xxx__') {
+ $other = $_[2 * $i + 1] ;
+ }
+ else {
+ push @entered, $_[2 * $i] ;
+ push @entered, \$_[2 * $i + 1] ;
+ }
+ }
+ }
+
+
+ while (my ($key, $v) = each %$default)
+ {
+ croak "need 4 params [@$v]"
+ if @$v != 4 ;
+
+ my ($first_only, $sticky, $type, $value) = @$v ;
+ my $x ;
+ $self->_checkType($key, \$value, $type, 0, \$x)
+ or return undef ;
+
+ $key = lc $key;
+
+ if ($firstTime || ! $sticky) {
+ $x = []
+ if $type & Parse_multiple;
+
+ $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
+ }
+
+ $got->{$key}[OFF_PARSED] = 0 ;
+ }
+
+ my %parsed = ();
+
+ if ($other)
+ {
+ for my $key (keys %$default)
+ {
+ my $canonkey = lc $key;
+ if ($other->parsed($canonkey))
+ {
+ my $value = $other->value($canonkey);
+#print "SET '$canonkey' to $value [$$value]\n";
+ ++ $parsed{$canonkey};
+ $got->{$canonkey}[OFF_PARSED] = 1;
+ $got->{$canonkey}[OFF_DEFAULT] = $value;
+ $got->{$canonkey}[OFF_FIXED] = $value;
+ }
+ }
+ }
+
+ for my $i (0.. @entered / 2 - 1) {
+ my $key = $entered[2* $i] ;
+ my $value = $entered[2* $i+1] ;
+
+ #print "Key [$key] Value [$value]" ;
+ #print defined $$value ? "[$$value]\n" : "[undef]\n";
+
+ $key =~ s/^-// ;
+ my $canonkey = lc $key;
+
+ if ($got->{$canonkey} && ($firstTime ||
+ ! $got->{$canonkey}[OFF_FIRST_ONLY] ))
+ {
+ my $type = $got->{$canonkey}[OFF_TYPE] ;
+ my $parsed = $parsed{$canonkey};
+ ++ $parsed{$canonkey};
+
+ return $self->setError("Muliple instances of '$key' found")
+ if $parsed && $type & Parse_multiple == 0 ;
+
+ my $s ;
+ $self->_checkType($key, $value, $type, 1, \$s)
+ or return undef ;
+
+ $value = $$value ;
+ if ($type & Parse_multiple) {
+ $got->{$canonkey}[OFF_PARSED] = 1;
+ push @{ $got->{$canonkey}[OFF_FIXED] }, $s ;
+ }
+ else {
+ $got->{$canonkey} = [1, $type, $value, $s] ;
+ }
+ }
+ else
+ { push (@Bad, $key) }
+ }
+
+ if (@Bad) {
+ my ($bad) = join(", ", @Bad) ;
+ return $self->setError("unknown key value(s) $bad") ;
+ }
+
+ return 1;
+}
+
+sub IO::Compress::Base::Parameters::_checkType
+{
+ my $self = shift ;
+
+ my $key = shift ;
+ my $value = shift ;
+ my $type = shift ;
+ my $validate = shift ;
+ my $output = shift;
+
+ #local $Carp::CarpLevel = $level ;
+ #print "PARSE $type $key $value $validate $sub\n" ;
+
+ if ($type & Parse_writable_scalar)
+ {
+ return $self->setError("Parameter '$key' not writable")
+ if $validate && readonly $$value ;
+
+ if (ref $$value)
+ {
+ return $self->setError("Parameter '$key' not a scalar reference")
+ if $validate && ref $$value ne 'SCALAR' ;
+
+ $$output = $$value ;
+ }
+ else
+ {
+ return $self->setError("Parameter '$key' not a scalar")
+ if $validate && ref $value ne 'SCALAR' ;
+
+ $$output = $value ;
+ }
+
+ return 1;
+ }
+
+# if ($type & Parse_store_ref)
+# {
+# #$value = $$value
+# # if ref ${ $value } ;
+#
+# $$output = $value ;
+# return 1;
+# }
+
+ $value = $$value ;
+
+ if ($type & Parse_any)
+ {
+ $$output = $value ;
+ return 1;
+ }
+ elsif ($type & Parse_unsigned)
+ {
+ return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
+ if $validate && ! defined $value ;
+ return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
+ if $validate && $value !~ /^\d+$/;
+
+ $$output = defined $value ? $value : 0 ;
+ return 1;
+ }
+ elsif ($type & Parse_signed)
+ {
+ return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
+ if $validate && ! defined $value ;
+ return $self->setError("Parameter '$key' must be a signed int, got '$value'")
+ if $validate && $value !~ /^-?\d+$/;
+
+ $$output = defined $value ? $value : 0 ;
+ return 1 ;
+ }
+ elsif ($type & Parse_boolean)
+ {
+ return $self->setError("Parameter '$key' must be an int, got '$value'")
+ if $validate && defined $value && $value !~ /^\d*$/;
+ $$output = defined $value ? $value != 0 : 0 ;
+ return 1;
+ }
+ elsif ($type & Parse_string)
+ {
+ $$output = defined $value ? $value : "" ;
+ return 1;
+ }
+
+ $$output = $value ;
+ return 1;
+}
+
+
+
+sub IO::Compress::Base::Parameters::parsed
+{
+ my $self = shift ;
+ my $name = shift ;
+
+ return $self->{Got}{lc $name}[OFF_PARSED] ;
+}
+
+sub IO::Compress::Base::Parameters::value
+{
+ my $self = shift ;
+ my $name = shift ;
+
+ if (@_)
+ {
+ $self->{Got}{lc $name}[OFF_PARSED] = 1;
+ $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
+ $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ;
+ }
+
+ return $self->{Got}{lc $name}[OFF_FIXED] ;
+}
+
+sub IO::Compress::Base::Parameters::valueOrDefault
+{
+ my $self = shift ;
+ my $name = shift ;
+ my $default = shift ;
+
+ my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
+
+ return $value if defined $value ;
+ return $default ;
+}
+
+sub IO::Compress::Base::Parameters::wantValue
+{
+ my $self = shift ;
+ my $name = shift ;
+
+ return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
+
+}
+
+sub IO::Compress::Base::Parameters::clone
+{
+ my $self = shift ;
+ my $obj = { };
+ my %got ;
+
+ while (my ($k, $v) = each %{ $self->{Got} }) {
+ $got{$k} = [ @$v ];
+ }
+
+ $obj->{Error} = $self->{Error};
+ $obj->{Got} = \%got ;
+
+ return bless $obj, 'IO::Compress::Base::Parameters' ;
+}
+
+package U64;
+
+use constant MAX32 => 0xFFFFFFFF ;
+use constant HI_1 => MAX32 + 1 ;
+use constant LOW => 0 ;
+use constant HIGH => 1;
+
+sub new
+{
+ my $class = shift ;
+
+ my $high = 0 ;
+ my $low = 0 ;
+
+ if (@_ == 2) {
+ $high = shift ;
+ $low = shift ;
+ }
+ elsif (@_ == 1) {
+ $low = shift ;
+ }
+
+ bless [$low, $high], $class;
+}
+
+sub newUnpack_V64
+{
+ my $string = shift;
+
+ my ($low, $hi) = unpack "V V", $string ;
+ bless [ $low, $hi ], "U64";
+}
+
+sub newUnpack_V32
+{
+ my $string = shift;
+
+ my $low = unpack "V", $string ;
+ bless [ $low, 0 ], "U64";
+}
+
+sub reset
+{
+ my $self = shift;
+ $self->[HIGH] = $self->[LOW] = 0;
+}
+
+sub clone
+{
+ my $self = shift;
+ bless [ @$self ], ref $self ;
+}
+
+sub getHigh
+{
+ my $self = shift;
+ return $self->[HIGH];
+}
+
+sub getLow
+{
+ my $self = shift;
+ return $self->[LOW];
+}
+
+sub get32bit
+{
+ my $self = shift;
+ return $self->[LOW];
+}
+
+sub get64bit
+{
+ my $self = shift;
+ # Not using << here because the result will still be
+ # a 32-bit value on systems where int size is 32-bits
+ return $self->[HIGH] * HI_1 + $self->[LOW];
+}
+
+sub add
+{
+ my $self = shift;
+ my $value = shift;
+
+ if (ref $value eq 'U64') {
+ $self->[HIGH] += $value->[HIGH] ;
+ $value = $value->[LOW];
+ }
+
+ my $available = MAX32 - $self->[LOW] ;
+
+ if ($value > $available) {
+ ++ $self->[HIGH] ;
+ $self->[LOW] = $value - $available - 1;
+ }
+ else {
+ $self->[LOW] += $value ;
+ }
+
+}
+
+sub equal
+{
+ my $self = shift;
+ my $other = shift;
+
+ return $self->[LOW] == $other->[LOW] &&
+ $self->[HIGH] == $other->[HIGH] ;
+}
+
+sub is64bit
+{
+ my $self = shift;
+ return $self->[HIGH] > 0 ;
+}
+
+sub getPacked_V64
+{
+ my $self = shift;
+
+ return pack "V V", @$self ;
+}
+
+sub getPacked_V32
+{
+ my $self = shift;
+
+ return pack "V", $self->[LOW] ;
+}
+
+sub pack_V64
+{
+ my $low = shift;
+
+ return pack "V V", $low, 0;
+}
+
+
+package IO::Compress::Base::Common;
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm
new file mode 100755
index 00000000000..2a85ef55b19
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Bzip2.pm
@@ -0,0 +1,758 @@
+package IO::Compress::Bzip2 ;
+
+use strict ;
+use warnings;
+use bytes;
+require Exporter ;
+
+use IO::Compress::Base 2.024 ;
+
+use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject);
+use IO::Compress::Adapter::Bzip2 2.024 ;
+
+
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error);
+
+$VERSION = '2.024';
+$Bzip2Error = '';
+
+@ISA = qw(Exporter IO::Compress::Base);
+@EXPORT_OK = qw( $Bzip2Error bzip2 ) ;
+%EXPORT_TAGS = %IO::Compress::Base::EXPORT_TAGS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+
+
+sub new
+{
+ my $class = shift ;
+
+ my $obj = createSelfTiedObject($class, \$Bzip2Error);
+ return $obj->_create(undef, @_);
+}
+
+sub bzip2
+{
+ my $obj = createSelfTiedObject(undef, \$Bzip2Error);
+ $obj->_def(@_);
+}
+
+
+sub mkHeader
+{
+ my $self = shift ;
+ return '';
+
+}
+
+sub getExtraParams
+{
+ my $self = shift ;
+
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+
+ return (
+ 'BlockSize100K' => [0, 1, Parse_unsigned, 1],
+ 'WorkFactor' => [0, 1, Parse_unsigned, 0],
+ 'Verbosity' => [0, 1, Parse_boolean, 0],
+ );
+}
+
+
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift;
+
+ # check that BlockSize100K is a number between 1 & 9
+ if ($got->parsed('BlockSize100K')) {
+ my $value = $got->value('BlockSize100K');
+ return $self->saveErrorString(undef, "Parameter 'BlockSize100K' not between 1 and 9, got $value")
+ unless defined $value && $value >= 1 && $value <= 9;
+
+ }
+
+ # check that WorkFactor between 0 & 250
+ if ($got->parsed('WorkFactor')) {
+ my $value = $got->value('WorkFactor');
+ return $self->saveErrorString(undef, "Parameter 'WorkFactor' not between 0 and 250, got $value")
+ unless $value >= 0 && $value <= 250;
+ }
+
+ return 1 ;
+}
+
+
+sub mkComp
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ my $BlockSize100K = $got->value('BlockSize100K');
+ my $WorkFactor = $got->value('WorkFactor');
+ my $Verbosity = $got->value('Verbosity');
+
+ my ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject(
+ $BlockSize100K, $WorkFactor,
+ $Verbosity);
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ return $obj;
+}
+
+
+sub mkTrailer
+{
+ my $self = shift ;
+ return '';
+}
+
+sub mkFinalTrailer
+{
+ return '';
+}
+
+#sub newHeader
+#{
+# my $self = shift ;
+# return '';
+#}
+
+sub getInverseClass
+{
+ return ('IO::Uncompress::Bunzip2');
+}
+
+sub getFileInfo
+{
+ my $self = shift ;
+ my $params = shift;
+ my $file = shift ;
+
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Compress::Bzip2 - Write bzip2 files/buffers
+
+
+
+=head1 SYNOPSIS
+
+ use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
+
+ my $status = bzip2 $input => $output [,OPTS]
+ or die "bzip2 failed: $Bzip2Error\n";
+
+ my $z = new IO::Compress::Bzip2 $output [,OPTS]
+ or die "bzip2 failed: $Bzip2Error\n";
+
+ $z->print($string);
+ $z->printf($format, $string);
+ $z->write($string);
+ $z->syswrite($string [, $length, $offset]);
+ $z->flush();
+ $z->tell();
+ $z->eof();
+ $z->seek($position, $whence);
+ $z->binmode();
+ $z->fileno();
+ $z->opened();
+ $z->autoflush();
+ $z->input_line_number();
+ $z->newStream( [OPTS] );
+
+ $z->close() ;
+
+ $Bzip2Error ;
+
+ # IO::File mode
+
+ print $z $string;
+ printf $z $format, $string;
+ tell $z
+ eof $z
+ seek $z, $position, $whence
+ binmode $z
+ fileno $z
+ close $z ;
+
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows writing bzip2
+compressed data to files or buffer.
+
+For reading bzip2 files/buffers, see the companion module
+L<IO::Uncompress::Bunzip2|IO::Uncompress::Bunzip2>.
+
+=head1 Functional Interface
+
+A top-level function, C<bzip2>, is provided to carry out
+"one-shot" compression between buffers and/or files. For finer
+control over the compression process, see the L</"OO Interface">
+section.
+
+ use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
+
+ bzip2 $input => $output [,OPTS]
+ or die "bzip2 failed: $Bzip2Error\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 bzip2 $input => $output [, OPTS]
+
+C<bzip2> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the uncompressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is compressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<bzip2> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+compressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<bzip2> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple files/buffers and C<$output> is a single
+file/buffer the input files/buffers will be stored
+in C<$output> as a concatenated series of compressed data streams.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<bzip2>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<bzip2> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<bzip2> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeIn => 0|1 >>
+
+When reading from a file or filehandle, set C<binmode> before reading.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+TODO
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt> and write the compressed
+data to the file C<file1.txt.bz2>.
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
+
+ my $input = "file1.txt";
+ bzip2 $input => "$input.bz2"
+ or die "bzip2 failed: $Bzip2Error\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+compressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt"
+ or die "Cannot open 'file1.txt': $!\n" ;
+ my $buffer ;
+ bzip2 $input => \$buffer
+ or die "bzip2 failed: $Bzip2Error\n";
+
+To compress all files in the directory "/my/home" that match "*.txt"
+and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
+
+ bzip2 '</my/home/*.txt>' => '<*.bz2>'
+ or die "bzip2 failed: $Bzip2Error\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
+
+ for my $input ( glob "/my/home/*.txt" )
+ {
+ my $output = "$input.bz2" ;
+ bzip2 $input => $output
+ or die "Error compressing '$input': $Bzip2Error\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for C<IO::Compress::Bzip2> is shown below
+
+ my $z = new IO::Compress::Bzip2 $output [,OPTS]
+ or die "IO::Compress::Bzip2 failed: $Bzip2Error\n";
+
+It returns an C<IO::Compress::Bzip2> object on success and undef on failure.
+The variable C<$Bzip2Error> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Compress::Bzip2 can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal output file operations can be carried out
+with C<$z>.
+For example, to write to a compressed file/buffer you can use either of
+these forms
+
+ $z->print("hello world\n");
+ print $z "hello world\n";
+
+The mandatory parameter C<$output> is used to control the destination
+of the compressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed data
+will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the compressed data will be
+written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the compressed data will be stored
+in C<$$output>.
+
+=back
+
+If the C<$output> parameter is any other type, C<IO::Compress::Bzip2>::new will
+return undef.
+
+=head2 Constructor Options
+
+C<OPTS> is any combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$output> parameter is a filehandle. If
+specified, and the value is true, it will result in the C<$output> being
+closed once either the C<close> method is called or the C<IO::Compress::Bzip2>
+object is destroyed.
+
+This parameter defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+Opens C<$output> in append mode.
+
+The behaviour of this option is dependent on the type of C<$output>.
+
+=over 5
+
+=item * A Buffer
+
+If C<$output> is a buffer and C<Append> is enabled, all compressed data
+will be append to the end if C<$output>. Otherwise C<$output> will be
+cleared before any data is written to it.
+
+=item * A Filename
+
+If C<$output> is a filename and C<Append> is enabled, the file will be
+opened in append mode. Otherwise the contents of the file, if any, will be
+truncated before any compressed data is written to it.
+
+=item * A Filehandle
+
+If C<$output> is a filehandle, the file pointer will be positioned to the
+end of the file via a call to C<seek> before any compressed data is written
+to it. Otherwise the file pointer will not be moved.
+
+=back
+
+This parameter defaults to 0.
+
+=item C<< BlockSize100K => number >>
+
+Specify the number of 100K blocks bzip2 uses during compression.
+
+Valid values are from 1 to 9, where 9 is best compression.
+
+The default is 1.
+
+=item C<< WorkFactor => number >>
+
+Specifies how much effort bzip2 should take before resorting to a slower
+fallback compression algorithm.
+
+Valid values range from 0 to 250, where 0 means use the default value 30.
+
+The default is 0.
+
+=item C<< Strict => 0|1 >>
+
+This is a placeholder option.
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 print
+
+Usage is
+
+ $z->print($data)
+ print $z $data
+
+Compresses and outputs the contents of the C<$data> parameter. This
+has the same behaviour as the C<print> built-in.
+
+Returns true if successful.
+
+=head2 printf
+
+Usage is
+
+ $z->printf($format, $data)
+ printf $z $format, $data
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns true if successful.
+
+=head2 syswrite
+
+Usage is
+
+ $z->syswrite $data
+ $z->syswrite $data, $length
+ $z->syswrite $data, $length, $offset
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns the number of uncompressed bytes written, or C<undef> if
+unsuccessful.
+
+=head2 write
+
+Usage is
+
+ $z->write $data
+ $z->write $data, $length
+ $z->write $data, $length, $offset
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns the number of uncompressed bytes written, or C<undef> if
+unsuccessful.
+
+=head2 flush
+
+Usage is
+
+ $z->flush;
+
+Flushes any pending compressed data to the output file/buffer.
+
+TODO
+
+Returns true on success.
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the C<close> method has been called.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the output file/buffer.
+It is a fatal error to attempt to seek backward.
+
+Empty parts of the file/buffer will have NULL (0x00) bytes written to them.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+This method always returns C<undef> when compressing.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Flushes any pending compressed data and then closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Compress::Bzip2 object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Compress::Bzip2
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 newStream([OPTS])
+
+Usage is
+
+ $z->newStream( [OPTS] )
+
+Closes the current compressed data stream and starts a new one.
+
+OPTS consists of any of the the options that are available when creating
+the C<$z> object.
+
+See the L</"Constructor Options"> section for more details.
+
+=head1 Importing
+
+No symbolic constants are required by this IO::Compress::Bzip2 at present.
+
+=over 5
+
+=item :all
+
+Imports C<bzip2> and C<$Bzip2Error>.
+Same as doing this
+
+ use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
+
+
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Apache::GZip Revisited
+
+See L<IO::Compress::Bzip2::FAQ|IO::Compress::Bzip2::FAQ/"Apache::GZip Revisited">
+
+
+
+=head2 Working with Net::FTP
+
+See L<IO::Compress::Bzip2::FAQ|IO::Compress::Bzip2::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+The primary site for the bzip2 program is F<http://www.bzip.org>.
+
+See the module L<Compress::Bzip2|Compress::Bzip2>
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2008 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Deflate.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Deflate.pm
new file mode 100755
index 00000000000..0f46e59d3a4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Deflate.pm
@@ -0,0 +1,930 @@
+package IO::Compress::Deflate ;
+
+use strict ;
+use warnings;
+use bytes;
+
+require Exporter ;
+
+use IO::Compress::RawDeflate 2.024 ;
+
+use Compress::Raw::Zlib 2.024 ;
+use IO::Compress::Zlib::Constants 2.024 ;
+use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject);
+
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $DeflateError);
+
+$VERSION = '2.024';
+$DeflateError = '';
+
+@ISA = qw(Exporter IO::Compress::RawDeflate);
+@EXPORT_OK = qw( $DeflateError deflate ) ;
+%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+
+sub new
+{
+ my $class = shift ;
+
+ my $obj = createSelfTiedObject($class, \$DeflateError);
+ return $obj->_create(undef, @_);
+}
+
+sub deflate
+{
+ my $obj = createSelfTiedObject(undef, \$DeflateError);
+ return $obj->_def(@_);
+}
+
+
+sub bitmask($$$$)
+{
+ my $into = shift ;
+ my $value = shift ;
+ my $offset = shift ;
+ my $mask = shift ;
+
+ return $into | (($value & $mask) << $offset ) ;
+}
+
+sub mkDeflateHdr($$$;$)
+{
+ my $method = shift ;
+ my $cinfo = shift;
+ my $level = shift;
+ my $fdict_adler = shift ;
+
+ my $cmf = 0;
+ my $flg = 0;
+ my $fdict = 0;
+ $fdict = 1 if defined $fdict_adler;
+
+ $cmf = bitmask($cmf, $method, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS);
+ $cmf = bitmask($cmf, $cinfo, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS);
+
+ $flg = bitmask($flg, $fdict, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS);
+ $flg = bitmask($flg, $level, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS);
+
+ my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ;
+ $flg = bitmask($flg, $fcheck, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS);
+
+ my $hdr = pack("CC", $cmf, $flg) ;
+ $hdr .= pack("N", $fdict_adler) if $fdict ;
+
+ return $hdr;
+}
+
+sub mkHeader
+{
+ my $self = shift ;
+ my $param = shift ;
+
+ my $level = $param->value('Level');
+ my $strategy = $param->value('Strategy');
+
+ my $lflag ;
+ $level = 6
+ if $level == Z_DEFAULT_COMPRESSION ;
+
+ if (ZLIB_VERNUM >= 0x1210)
+ {
+ if ($strategy >= Z_HUFFMAN_ONLY || $level < 2)
+ { $lflag = ZLIB_FLG_LEVEL_FASTEST }
+ elsif ($level < 6)
+ { $lflag = ZLIB_FLG_LEVEL_FAST }
+ elsif ($level == 6)
+ { $lflag = ZLIB_FLG_LEVEL_DEFAULT }
+ else
+ { $lflag = ZLIB_FLG_LEVEL_SLOWEST }
+ }
+ else
+ {
+ $lflag = ($level - 1) >> 1 ;
+ $lflag = 3 if $lflag > 3 ;
+ }
+
+ #my $wbits = (MAX_WBITS - 8) << 4 ;
+ my $wbits = 7;
+ mkDeflateHdr(ZLIB_CMF_CM_DEFLATED, $wbits, $lflag);
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift;
+
+ $got->value('ADLER32' => 1);
+ return 1 ;
+}
+
+
+sub mkTrailer
+{
+ my $self = shift ;
+ return pack("N", *$self->{Compress}->adler32()) ;
+}
+
+sub mkFinalTrailer
+{
+ return '';
+}
+
+#sub newHeader
+#{
+# my $self = shift ;
+# return *$self->{Header};
+#}
+
+sub getExtraParams
+{
+ my $self = shift ;
+ return $self->getZlibParams(),
+}
+
+sub getInverseClass
+{
+ return ('IO::Uncompress::Inflate',
+ \$IO::Uncompress::Inflate::InflateError);
+}
+
+sub getFileInfo
+{
+ my $self = shift ;
+ my $params = shift;
+ my $file = shift ;
+
+}
+
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Compress::Deflate - Write RFC 1950 files/buffers
+
+
+
+=head1 SYNOPSIS
+
+ use IO::Compress::Deflate qw(deflate $DeflateError) ;
+
+ my $status = deflate $input => $output [,OPTS]
+ or die "deflate failed: $DeflateError\n";
+
+ my $z = new IO::Compress::Deflate $output [,OPTS]
+ or die "deflate failed: $DeflateError\n";
+
+ $z->print($string);
+ $z->printf($format, $string);
+ $z->write($string);
+ $z->syswrite($string [, $length, $offset]);
+ $z->flush();
+ $z->tell();
+ $z->eof();
+ $z->seek($position, $whence);
+ $z->binmode();
+ $z->fileno();
+ $z->opened();
+ $z->autoflush();
+ $z->input_line_number();
+ $z->newStream( [OPTS] );
+
+ $z->deflateParams();
+
+ $z->close() ;
+
+ $DeflateError ;
+
+ # IO::File mode
+
+ print $z $string;
+ printf $z $format, $string;
+ tell $z
+ eof $z
+ seek $z, $position, $whence
+ binmode $z
+ fileno $z
+ close $z ;
+
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows writing compressed
+data to files or buffer as defined in RFC 1950.
+
+For reading RFC 1950 files/buffers, see the companion module
+L<IO::Uncompress::Inflate|IO::Uncompress::Inflate>.
+
+=head1 Functional Interface
+
+A top-level function, C<deflate>, is provided to carry out
+"one-shot" compression between buffers and/or files. For finer
+control over the compression process, see the L</"OO Interface">
+section.
+
+ use IO::Compress::Deflate qw(deflate $DeflateError) ;
+
+ deflate $input => $output [,OPTS]
+ or die "deflate failed: $DeflateError\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 deflate $input => $output [, OPTS]
+
+C<deflate> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the uncompressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is compressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<deflate> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+compressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<deflate> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple files/buffers and C<$output> is a single
+file/buffer the input files/buffers will be stored
+in C<$output> as a concatenated series of compressed data streams.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<deflate>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<deflate> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<deflate> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeIn => 0|1 >>
+
+When reading from a file or filehandle, set C<binmode> before reading.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+The behaviour of this option is dependent on the type of output data
+stream.
+
+=over 5
+
+=item * A Buffer
+
+If C<Append> is enabled, all compressed data will be append to the end of
+the output buffer. Otherwise the output buffer will be cleared before any
+compressed data is written to it.
+
+=item * A Filename
+
+If C<Append> is enabled, the file will be opened in append mode. Otherwise
+the contents of the file, if any, will be truncated before any compressed
+data is written to it.
+
+=item * A Filehandle
+
+If C<Append> is enabled, the filehandle will be positioned to the end of
+the file via a call to C<seek> before any compressed data is
+written to it. Otherwise the file pointer will not be moved.
+
+=back
+
+When C<Append> is specified, and set to true, it will I<append> all compressed
+data to the output data stream.
+
+So when the output is a filehandle it will carry out a seek to the eof
+before writing any compressed data. If the output is a filename, it will be opened for
+appending. If the output is a buffer, all compressed data will be appened to
+the existing buffer.
+
+Conversely when C<Append> is not specified, or it is present and is set to
+false, it will operate as follows.
+
+When the output is a filename, it will truncate the contents of the file
+before writing any compressed data. If the output is a filehandle
+its position will not be changed. If the output is a buffer, it will be
+wiped before any compressed data is output.
+
+Defaults to 0.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt> and write the compressed
+data to the file C<file1.txt.1950>.
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Deflate qw(deflate $DeflateError) ;
+
+ my $input = "file1.txt";
+ deflate $input => "$input.1950"
+ or die "deflate failed: $DeflateError\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+compressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Deflate qw(deflate $DeflateError) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt"
+ or die "Cannot open 'file1.txt': $!\n" ;
+ my $buffer ;
+ deflate $input => \$buffer
+ or die "deflate failed: $DeflateError\n";
+
+To compress all files in the directory "/my/home" that match "*.txt"
+and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Deflate qw(deflate $DeflateError) ;
+
+ deflate '</my/home/*.txt>' => '<*.1950>'
+ or die "deflate failed: $DeflateError\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Deflate qw(deflate $DeflateError) ;
+
+ for my $input ( glob "/my/home/*.txt" )
+ {
+ my $output = "$input.1950" ;
+ deflate $input => $output
+ or die "Error compressing '$input': $DeflateError\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for C<IO::Compress::Deflate> is shown below
+
+ my $z = new IO::Compress::Deflate $output [,OPTS]
+ or die "IO::Compress::Deflate failed: $DeflateError\n";
+
+It returns an C<IO::Compress::Deflate> object on success and undef on failure.
+The variable C<$DeflateError> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Compress::Deflate can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal output file operations can be carried out
+with C<$z>.
+For example, to write to a compressed file/buffer you can use either of
+these forms
+
+ $z->print("hello world\n");
+ print $z "hello world\n";
+
+The mandatory parameter C<$output> is used to control the destination
+of the compressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed data
+will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the compressed data will be
+written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the compressed data will be stored
+in C<$$output>.
+
+=back
+
+If the C<$output> parameter is any other type, C<IO::Compress::Deflate>::new will
+return undef.
+
+=head2 Constructor Options
+
+C<OPTS> is any combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$output> parameter is a filehandle. If
+specified, and the value is true, it will result in the C<$output> being
+closed once either the C<close> method is called or the C<IO::Compress::Deflate>
+object is destroyed.
+
+This parameter defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+Opens C<$output> in append mode.
+
+The behaviour of this option is dependent on the type of C<$output>.
+
+=over 5
+
+=item * A Buffer
+
+If C<$output> is a buffer and C<Append> is enabled, all compressed data
+will be append to the end of C<$output>. Otherwise C<$output> will be
+cleared before any data is written to it.
+
+=item * A Filename
+
+If C<$output> is a filename and C<Append> is enabled, the file will be
+opened in append mode. Otherwise the contents of the file, if any, will be
+truncated before any compressed data is written to it.
+
+=item * A Filehandle
+
+If C<$output> is a filehandle, the file pointer will be positioned to the
+end of the file via a call to C<seek> before any compressed data is written
+to it. Otherwise the file pointer will not be moved.
+
+=back
+
+This parameter defaults to 0.
+
+=item C<< Merge => 0|1 >>
+
+This option is used to compress input data and append it to an existing
+compressed data stream in C<$output>. The end result is a single compressed
+data stream stored in C<$output>.
+
+It is a fatal error to attempt to use this option when C<$output> is not an
+RFC 1950 data stream.
+
+There are a number of other limitations with the C<Merge> option:
+
+=over 5
+
+=item 1
+
+This module needs to have been built with zlib 1.2.1 or better to work. A
+fatal error will be thrown if C<Merge> is used with an older version of
+zlib.
+
+=item 2
+
+If C<$output> is a file or a filehandle, it must be seekable.
+
+=back
+
+This parameter defaults to 0.
+
+=item -Level
+
+Defines the compression level used by zlib. The value should either be
+a number between 0 and 9 (0 means no compression and 9 is maximum
+compression), or one of the symbolic constants defined below.
+
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+
+The default is Z_DEFAULT_COMPRESSION.
+
+Note, these constants are not imported by C<IO::Compress::Deflate> by default.
+
+ use IO::Compress::Deflate qw(:strategy);
+ use IO::Compress::Deflate qw(:constants);
+ use IO::Compress::Deflate qw(:all);
+
+=item -Strategy
+
+Defines the strategy used to tune the compression. Use one of the symbolic
+constants defined below.
+
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+
+The default is Z_DEFAULT_STRATEGY.
+
+=item C<< Strict => 0|1 >>
+
+This is a placeholder option.
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 print
+
+Usage is
+
+ $z->print($data)
+ print $z $data
+
+Compresses and outputs the contents of the C<$data> parameter. This
+has the same behaviour as the C<print> built-in.
+
+Returns true if successful.
+
+=head2 printf
+
+Usage is
+
+ $z->printf($format, $data)
+ printf $z $format, $data
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns true if successful.
+
+=head2 syswrite
+
+Usage is
+
+ $z->syswrite $data
+ $z->syswrite $data, $length
+ $z->syswrite $data, $length, $offset
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns the number of uncompressed bytes written, or C<undef> if
+unsuccessful.
+
+=head2 write
+
+Usage is
+
+ $z->write $data
+ $z->write $data, $length
+ $z->write $data, $length, $offset
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns the number of uncompressed bytes written, or C<undef> if
+unsuccessful.
+
+=head2 flush
+
+Usage is
+
+ $z->flush;
+ $z->flush($flush_type);
+
+Flushes any pending compressed data to the output file/buffer.
+
+This method takes an optional parameter, C<$flush_type>, that controls
+how the flushing will be carried out. By default the C<$flush_type>
+used is C<Z_FINISH>. Other valid values for C<$flush_type> are
+C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is
+strongly recommended that you only set the C<flush_type> parameter if
+you fully understand the implications of what it does - overuse of C<flush>
+can seriously degrade the level of compression achieved. See the C<zlib>
+documentation for details.
+
+Returns true on success.
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the C<close> method has been called.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the output file/buffer.
+It is a fatal error to attempt to seek backward.
+
+Empty parts of the file/buffer will have NULL (0x00) bytes written to them.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+This method always returns C<undef> when compressing.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Flushes any pending compressed data and then closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Compress::Deflate object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Compress::Deflate
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 newStream([OPTS])
+
+Usage is
+
+ $z->newStream( [OPTS] )
+
+Closes the current compressed data stream and starts a new one.
+
+OPTS consists of any of the the options that are available when creating
+the C<$z> object.
+
+See the L</"Constructor Options"> section for more details.
+
+=head2 deflateParams
+
+Usage is
+
+ $z->deflateParams
+
+TODO
+
+=head1 Importing
+
+A number of symbolic constants are required by some methods in
+C<IO::Compress::Deflate>. None are imported by default.
+
+=over 5
+
+=item :all
+
+Imports C<deflate>, C<$DeflateError> and all symbolic
+constants that can be used by C<IO::Compress::Deflate>. Same as doing this
+
+ use IO::Compress::Deflate qw(deflate $DeflateError :constants) ;
+
+=item :constants
+
+Import all symbolic constants. Same as doing this
+
+ use IO::Compress::Deflate qw(:flush :level :strategy) ;
+
+=item :flush
+
+These symbolic constants are used by the C<flush> method.
+
+ Z_NO_FLUSH
+ Z_PARTIAL_FLUSH
+ Z_SYNC_FLUSH
+ Z_FULL_FLUSH
+ Z_FINISH
+ Z_BLOCK
+
+=item :level
+
+These symbolic constants are used by the C<Level> option in the constructor.
+
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+
+=item :strategy
+
+These symbolic constants are used by the C<Strategy> option in the constructor.
+
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+
+
+
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Apache::GZip Revisited
+
+See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
+
+
+
+=head2 Working with Net::FTP
+
+See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Gzip.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Gzip.pm
new file mode 100755
index 00000000000..1978b91b283
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Gzip.pm
@@ -0,0 +1,1242 @@
+
+package IO::Compress::Gzip ;
+
+require 5.004 ;
+
+use strict ;
+use warnings;
+use bytes;
+
+
+use IO::Compress::RawDeflate 2.024 ;
+
+use Compress::Raw::Zlib 2.024 ;
+use IO::Compress::Base::Common 2.024 qw(:Status :Parse createSelfTiedObject);
+use IO::Compress::Gzip::Constants 2.024 ;
+use IO::Compress::Zlib::Extra 2.024 ;
+
+BEGIN
+{
+ if (defined &utf8::downgrade )
+ { *noUTF8 = \&utf8::downgrade }
+ else
+ { *noUTF8 = sub {} }
+}
+
+require Exporter ;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError);
+
+$VERSION = '2.024';
+$GzipError = '' ;
+
+@ISA = qw(Exporter IO::Compress::RawDeflate);
+@EXPORT_OK = qw( $GzipError gzip ) ;
+%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+sub new
+{
+ my $class = shift ;
+
+ my $obj = createSelfTiedObject($class, \$GzipError);
+
+ $obj->_create(undef, @_);
+}
+
+
+sub gzip
+{
+ my $obj = createSelfTiedObject(undef, \$GzipError);
+ return $obj->_def(@_);
+}
+
+#sub newHeader
+#{
+# my $self = shift ;
+# #return GZIP_MINIMUM_HEADER ;
+# return $self->mkHeader(*$self->{Got});
+#}
+
+sub getExtraParams
+{
+ my $self = shift ;
+
+ return (
+ # zlib behaviour
+ $self->getZlibParams(),
+
+ # Gzip header fields
+ 'Minimal' => [0, 1, Parse_boolean, 0],
+ 'Comment' => [0, 1, Parse_any, undef],
+ 'Name' => [0, 1, Parse_any, undef],
+ 'Time' => [0, 1, Parse_any, undef],
+ 'TextFlag' => [0, 1, Parse_boolean, 0],
+ 'HeaderCRC' => [0, 1, Parse_boolean, 0],
+ 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code],
+ 'ExtraField'=> [0, 1, Parse_any, undef],
+ 'ExtraFlags'=> [0, 1, Parse_any, undef],
+
+ );
+}
+
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ # gzip always needs crc32
+ $got->value('CRC32' => 1);
+
+ return 1
+ if $got->value('Merge') ;
+
+ my $strict = $got->value('Strict') ;
+
+
+ {
+ if (! $got->parsed('Time') ) {
+ # Modification time defaults to now.
+ $got->value('Time' => time) ;
+ }
+
+ # Check that the Name & Comment don't have embedded NULLs
+ # Also check that they only contain ISO 8859-1 chars.
+ if ($got->parsed('Name') && defined $got->value('Name')) {
+ my $name = $got->value('Name');
+
+ return $self->saveErrorString(undef, "Null Character found in Name",
+ Z_DATA_ERROR)
+ if $strict && $name =~ /\x00/ ;
+
+ return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Name",
+ Z_DATA_ERROR)
+ if $strict && $name =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ;
+ }
+
+ if ($got->parsed('Comment') && defined $got->value('Comment')) {
+ my $comment = $got->value('Comment');
+
+ return $self->saveErrorString(undef, "Null Character found in Comment",
+ Z_DATA_ERROR)
+ if $strict && $comment =~ /\x00/ ;
+
+ return $self->saveErrorString(undef, "Non ISO 8859-1 Character found in Comment",
+ Z_DATA_ERROR)
+ if $strict && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o;
+ }
+
+ if ($got->parsed('OS_Code') ) {
+ my $value = $got->value('OS_Code');
+
+ return $self->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'")
+ if $value < 0 || $value > 255 ;
+
+ }
+
+ # gzip only supports Deflate at present
+ $got->value('Method' => Z_DEFLATED) ;
+
+ if ( ! $got->parsed('ExtraFlags')) {
+ $got->value('ExtraFlags' => 2)
+ if $got->value('Level') == Z_BEST_SPEED ;
+ $got->value('ExtraFlags' => 4)
+ if $got->value('Level') == Z_BEST_COMPRESSION ;
+ }
+
+ my $data = $got->value('ExtraField') ;
+ if (defined $data) {
+ my $bad = IO::Compress::Zlib::Extra::parseExtraField($data, $strict, 1) ;
+ return $self->saveErrorString(undef, "Error with ExtraField Parameter: $bad", Z_DATA_ERROR)
+ if $bad ;
+
+ $got->value('ExtraField', $data) ;
+ }
+ }
+
+ return 1;
+}
+
+sub mkTrailer
+{
+ my $self = shift ;
+ return pack("V V", *$self->{Compress}->crc32(),
+ *$self->{UnCompSize}->get32bit());
+}
+
+sub getInverseClass
+{
+ return ('IO::Uncompress::Gunzip',
+ \$IO::Uncompress::Gunzip::GunzipError);
+}
+
+sub getFileInfo
+{
+ my $self = shift ;
+ my $params = shift;
+ my $filename = shift ;
+
+ my $defaultTime = (stat($filename))[9] ;
+
+ $params->value('Name' => $filename)
+ if ! $params->parsed('Name') ;
+
+ $params->value('Time' => $defaultTime)
+ if ! $params->parsed('Time') ;
+}
+
+
+sub mkHeader
+{
+ my $self = shift ;
+ my $param = shift ;
+
+ # stort-circuit if a minimal header is requested.
+ return GZIP_MINIMUM_HEADER if $param->value('Minimal') ;
+
+ # METHOD
+ my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ;
+
+ # FLAGS
+ my $flags = GZIP_FLG_DEFAULT ;
+ $flags |= GZIP_FLG_FTEXT if $param->value('TextFlag') ;
+ $flags |= GZIP_FLG_FHCRC if $param->value('HeaderCRC') ;
+ $flags |= GZIP_FLG_FEXTRA if $param->wantValue('ExtraField') ;
+ $flags |= GZIP_FLG_FNAME if $param->wantValue('Name') ;
+ $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('Comment') ;
+
+ # MTIME
+ my $time = $param->valueOrDefault('Time', GZIP_MTIME_DEFAULT) ;
+
+ # EXTRA FLAGS
+ my $extra_flags = $param->valueOrDefault('ExtraFlags', GZIP_XFL_DEFAULT);
+
+ # OS CODE
+ my $os_code = $param->valueOrDefault('OS_Code', GZIP_OS_DEFAULT) ;
+
+
+ my $out = pack("C4 V C C",
+ GZIP_ID1, # ID1
+ GZIP_ID2, # ID2
+ $method, # Compression Method
+ $flags, # Flags
+ $time, # Modification Time
+ $extra_flags, # Extra Flags
+ $os_code, # Operating System Code
+ ) ;
+
+ # EXTRA
+ if ($flags & GZIP_FLG_FEXTRA) {
+ my $extra = $param->value('ExtraField') ;
+ $out .= pack("v", length $extra) . $extra ;
+ }
+
+ # NAME
+ if ($flags & GZIP_FLG_FNAME) {
+ my $name .= $param->value('Name') ;
+ $name =~ s/\x00.*$//;
+ $out .= $name ;
+ # Terminate the filename with NULL unless it already is
+ $out .= GZIP_NULL_BYTE
+ if !length $name or
+ substr($name, 1, -1) ne GZIP_NULL_BYTE ;
+ }
+
+ # COMMENT
+ if ($flags & GZIP_FLG_FCOMMENT) {
+ my $comment .= $param->value('Comment') ;
+ $comment =~ s/\x00.*$//;
+ $out .= $comment ;
+ # Terminate the comment with NULL unless it already is
+ $out .= GZIP_NULL_BYTE
+ if ! length $comment or
+ substr($comment, 1, -1) ne GZIP_NULL_BYTE;
+ }
+
+ # HEADER CRC
+ $out .= pack("v", crc32($out) & 0x00FF ) if $param->value('HeaderCRC') ;
+
+ noUTF8($out);
+
+ return $out ;
+}
+
+sub mkFinalTrailer
+{
+ return '';
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Compress::Gzip - Write RFC 1952 files/buffers
+
+
+
+=head1 SYNOPSIS
+
+ use IO::Compress::Gzip qw(gzip $GzipError) ;
+
+ my $status = gzip $input => $output [,OPTS]
+ or die "gzip failed: $GzipError\n";
+
+ my $z = new IO::Compress::Gzip $output [,OPTS]
+ or die "gzip failed: $GzipError\n";
+
+ $z->print($string);
+ $z->printf($format, $string);
+ $z->write($string);
+ $z->syswrite($string [, $length, $offset]);
+ $z->flush();
+ $z->tell();
+ $z->eof();
+ $z->seek($position, $whence);
+ $z->binmode();
+ $z->fileno();
+ $z->opened();
+ $z->autoflush();
+ $z->input_line_number();
+ $z->newStream( [OPTS] );
+
+ $z->deflateParams();
+
+ $z->close() ;
+
+ $GzipError ;
+
+ # IO::File mode
+
+ print $z $string;
+ printf $z $format, $string;
+ tell $z
+ eof $z
+ seek $z, $position, $whence
+ binmode $z
+ fileno $z
+ close $z ;
+
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows writing compressed
+data to files or buffer as defined in RFC 1952.
+
+All the gzip headers defined in RFC 1952 can be created using
+this module.
+
+For reading RFC 1952 files/buffers, see the companion module
+L<IO::Uncompress::Gunzip|IO::Uncompress::Gunzip>.
+
+=head1 Functional Interface
+
+A top-level function, C<gzip>, is provided to carry out
+"one-shot" compression between buffers and/or files. For finer
+control over the compression process, see the L</"OO Interface">
+section.
+
+ use IO::Compress::Gzip qw(gzip $GzipError) ;
+
+ gzip $input => $output [,OPTS]
+ or die "gzip failed: $GzipError\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 gzip $input => $output [, OPTS]
+
+C<gzip> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the uncompressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is compressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<gzip> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+In addition, if C<$input> is a simple filename, the default values for
+the C<Name> and C<Time> options will be sourced from that file.
+
+If you do not want to use these defaults they can be overridden by
+explicitly setting the C<Name> and C<Time> options or by setting the
+C<Minimal> parameter.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+compressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<gzip> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple files/buffers and C<$output> is a single
+file/buffer the input files/buffers will be stored
+in C<$output> as a concatenated series of compressed data streams.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<gzip>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<gzip> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<gzip> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeIn => 0|1 >>
+
+When reading from a file or filehandle, set C<binmode> before reading.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+The behaviour of this option is dependent on the type of output data
+stream.
+
+=over 5
+
+=item * A Buffer
+
+If C<Append> is enabled, all compressed data will be append to the end of
+the output buffer. Otherwise the output buffer will be cleared before any
+compressed data is written to it.
+
+=item * A Filename
+
+If C<Append> is enabled, the file will be opened in append mode. Otherwise
+the contents of the file, if any, will be truncated before any compressed
+data is written to it.
+
+=item * A Filehandle
+
+If C<Append> is enabled, the filehandle will be positioned to the end of
+the file via a call to C<seek> before any compressed data is
+written to it. Otherwise the file pointer will not be moved.
+
+=back
+
+When C<Append> is specified, and set to true, it will I<append> all compressed
+data to the output data stream.
+
+So when the output is a filehandle it will carry out a seek to the eof
+before writing any compressed data. If the output is a filename, it will be opened for
+appending. If the output is a buffer, all compressed data will be appened to
+the existing buffer.
+
+Conversely when C<Append> is not specified, or it is present and is set to
+false, it will operate as follows.
+
+When the output is a filename, it will truncate the contents of the file
+before writing any compressed data. If the output is a filehandle
+its position will not be changed. If the output is a buffer, it will be
+wiped before any compressed data is output.
+
+Defaults to 0.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt> and write the compressed
+data to the file C<file1.txt.gz>.
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Gzip qw(gzip $GzipError) ;
+
+ my $input = "file1.txt";
+ gzip $input => "$input.gz"
+ or die "gzip failed: $GzipError\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+compressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Gzip qw(gzip $GzipError) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt"
+ or die "Cannot open 'file1.txt': $!\n" ;
+ my $buffer ;
+ gzip $input => \$buffer
+ or die "gzip failed: $GzipError\n";
+
+To compress all files in the directory "/my/home" that match "*.txt"
+and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Gzip qw(gzip $GzipError) ;
+
+ gzip '</my/home/*.txt>' => '<*.gz>'
+ or die "gzip failed: $GzipError\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Gzip qw(gzip $GzipError) ;
+
+ for my $input ( glob "/my/home/*.txt" )
+ {
+ my $output = "$input.gz" ;
+ gzip $input => $output
+ or die "Error compressing '$input': $GzipError\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for C<IO::Compress::Gzip> is shown below
+
+ my $z = new IO::Compress::Gzip $output [,OPTS]
+ or die "IO::Compress::Gzip failed: $GzipError\n";
+
+It returns an C<IO::Compress::Gzip> object on success and undef on failure.
+The variable C<$GzipError> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Compress::Gzip can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal output file operations can be carried out
+with C<$z>.
+For example, to write to a compressed file/buffer you can use either of
+these forms
+
+ $z->print("hello world\n");
+ print $z "hello world\n";
+
+The mandatory parameter C<$output> is used to control the destination
+of the compressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed data
+will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the compressed data will be
+written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the compressed data will be stored
+in C<$$output>.
+
+=back
+
+If the C<$output> parameter is any other type, C<IO::Compress::Gzip>::new will
+return undef.
+
+=head2 Constructor Options
+
+C<OPTS> is any combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$output> parameter is a filehandle. If
+specified, and the value is true, it will result in the C<$output> being
+closed once either the C<close> method is called or the C<IO::Compress::Gzip>
+object is destroyed.
+
+This parameter defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+Opens C<$output> in append mode.
+
+The behaviour of this option is dependent on the type of C<$output>.
+
+=over 5
+
+=item * A Buffer
+
+If C<$output> is a buffer and C<Append> is enabled, all compressed data
+will be append to the end of C<$output>. Otherwise C<$output> will be
+cleared before any data is written to it.
+
+=item * A Filename
+
+If C<$output> is a filename and C<Append> is enabled, the file will be
+opened in append mode. Otherwise the contents of the file, if any, will be
+truncated before any compressed data is written to it.
+
+=item * A Filehandle
+
+If C<$output> is a filehandle, the file pointer will be positioned to the
+end of the file via a call to C<seek> before any compressed data is written
+to it. Otherwise the file pointer will not be moved.
+
+=back
+
+This parameter defaults to 0.
+
+=item C<< Merge => 0|1 >>
+
+This option is used to compress input data and append it to an existing
+compressed data stream in C<$output>. The end result is a single compressed
+data stream stored in C<$output>.
+
+It is a fatal error to attempt to use this option when C<$output> is not an
+RFC 1952 data stream.
+
+There are a number of other limitations with the C<Merge> option:
+
+=over 5
+
+=item 1
+
+This module needs to have been built with zlib 1.2.1 or better to work. A
+fatal error will be thrown if C<Merge> is used with an older version of
+zlib.
+
+=item 2
+
+If C<$output> is a file or a filehandle, it must be seekable.
+
+=back
+
+This parameter defaults to 0.
+
+=item -Level
+
+Defines the compression level used by zlib. The value should either be
+a number between 0 and 9 (0 means no compression and 9 is maximum
+compression), or one of the symbolic constants defined below.
+
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+
+The default is Z_DEFAULT_COMPRESSION.
+
+Note, these constants are not imported by C<IO::Compress::Gzip> by default.
+
+ use IO::Compress::Gzip qw(:strategy);
+ use IO::Compress::Gzip qw(:constants);
+ use IO::Compress::Gzip qw(:all);
+
+=item -Strategy
+
+Defines the strategy used to tune the compression. Use one of the symbolic
+constants defined below.
+
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+
+The default is Z_DEFAULT_STRATEGY.
+
+=item C<< Minimal => 0|1 >>
+
+If specified, this option will force the creation of the smallest possible
+compliant gzip header (which is exactly 10 bytes long) as defined in
+RFC 1952.
+
+See the section titled "Compliance" in RFC 1952 for a definition
+of the values used for the fields in the gzip header.
+
+All other parameters that control the content of the gzip header will
+be ignored if this parameter is set to 1.
+
+This parameter defaults to 0.
+
+=item C<< Comment => $comment >>
+
+Stores the contents of C<$comment> in the COMMENT field in
+the gzip header.
+By default, no comment field is written to the gzip file.
+
+If the C<-Strict> option is enabled, the comment can only consist of ISO
+8859-1 characters plus line feed.
+
+If the C<-Strict> option is disabled, the comment field can contain any
+character except NULL. If any null characters are present, the field
+will be truncated at the first NULL.
+
+=item C<< Name => $string >>
+
+Stores the contents of C<$string> in the gzip NAME header field. If
+C<Name> is not specified, no gzip NAME field will be created.
+
+If the C<-Strict> option is enabled, C<$string> can only consist of ISO
+8859-1 characters.
+
+If C<-Strict> is disabled, then C<$string> can contain any character
+except NULL. If any null characters are present, the field will be
+truncated at the first NULL.
+
+=item C<< Time => $number >>
+
+Sets the MTIME field in the gzip header to $number.
+
+This field defaults to the time the C<IO::Compress::Gzip> object was created
+if this option is not specified.
+
+=item C<< TextFlag => 0|1 >>
+
+This parameter controls the setting of the FLG.FTEXT bit in the gzip
+header. It is used to signal that the data stored in the gzip file/buffer
+is probably text.
+
+The default is 0.
+
+=item C<< HeaderCRC => 0|1 >>
+
+When true this parameter will set the FLG.FHCRC bit to 1 in the gzip header
+and set the CRC16 header field to the CRC of the complete gzip header
+except the CRC16 field itself.
+
+B<Note> that gzip files created with the C<HeaderCRC> flag set to 1 cannot
+be read by most, if not all, of the the standard gunzip utilities, most
+notably gzip version 1.2.4. You should therefore avoid using this option if
+you want to maximize the portability of your gzip files.
+
+This parameter defaults to 0.
+
+=item C<< OS_Code => $value >>
+
+Stores C<$value> in the gzip OS header field. A number between 0 and 255 is
+valid.
+
+If not specified, this parameter defaults to the OS code of the Operating
+System this module was built on. The value 3 is used as a catch-all for all
+Unix variants and unknown Operating Systems.
+
+=item C<< ExtraField => $data >>
+
+This parameter allows additional metadata to be stored in the ExtraField in
+the gzip header. An RFC 1952 compliant ExtraField consists of zero or more
+subfields. Each subfield consists of a two byte header followed by the
+subfield data.
+
+The list of subfields can be supplied in any of the following formats
+
+ -ExtraField => [$id1, $data1,
+ $id2, $data2,
+ ...
+ ]
+ -ExtraField => [ [$id1 => $data1],
+ [$id2 => $data2],
+ ...
+ ]
+ -ExtraField => { $id1 => $data1,
+ $id2 => $data2,
+ ...
+ }
+
+Where C<$id1>, C<$id2> are two byte subfield ID's. The second byte of
+the ID cannot be 0, unless the C<Strict> option has been disabled.
+
+If you use the hash syntax, you have no control over the order in which
+the ExtraSubFields are stored, plus you cannot have SubFields with
+duplicate ID.
+
+Alternatively the list of subfields can by supplied as a scalar, thus
+
+ -ExtraField => $rawdata
+
+If you use the raw format, and the C<Strict> option is enabled,
+C<IO::Compress::Gzip> will check that C<$rawdata> consists of zero or more
+conformant sub-fields. When C<Strict> is disabled, C<$rawdata> can
+consist of any arbitrary byte stream.
+
+The maximum size of the Extra Field 65535 bytes.
+
+=item C<< ExtraFlags => $value >>
+
+Sets the XFL byte in the gzip header to C<$value>.
+
+If this option is not present, the value stored in XFL field will be
+determined by the setting of the C<Level> option.
+
+If C<< Level => Z_BEST_SPEED >> has been specified then XFL is set to 2.
+If C<< Level => Z_BEST_COMPRESSION >> has been specified then XFL is set to 4.
+Otherwise XFL is set to 0.
+
+=item C<< Strict => 0|1 >>
+
+C<Strict> will optionally police the values supplied with other options
+to ensure they are compliant with RFC1952.
+
+This option is enabled by default.
+
+If C<Strict> is enabled the following behaviour will be policed:
+
+=over 5
+
+=item *
+
+The value supplied with the C<Name> option can only contain ISO 8859-1
+characters.
+
+=item *
+
+The value supplied with the C<Comment> option can only contain ISO 8859-1
+characters plus line-feed.
+
+=item *
+
+The values supplied with the C<-Name> and C<-Comment> options cannot
+contain multiple embedded nulls.
+
+=item *
+
+If an C<ExtraField> option is specified and it is a simple scalar,
+it must conform to the sub-field structure as defined in RFC 1952.
+
+=item *
+
+If an C<ExtraField> option is specified the second byte of the ID will be
+checked in each subfield to ensure that it does not contain the reserved
+value 0x00.
+
+=back
+
+When C<Strict> is disabled the following behaviour will be policed:
+
+=over 5
+
+=item *
+
+The value supplied with C<-Name> option can contain
+any character except NULL.
+
+=item *
+
+The value supplied with C<-Comment> option can contain any character
+except NULL.
+
+=item *
+
+The values supplied with the C<-Name> and C<-Comment> options can contain
+multiple embedded nulls. The string written to the gzip header will
+consist of the characters up to, but not including, the first embedded
+NULL.
+
+=item *
+
+If an C<ExtraField> option is specified and it is a simple scalar, the
+structure will not be checked. The only error is if the length is too big.
+
+=item *
+
+The ID header in an C<ExtraField> sub-field can consist of any two bytes.
+
+=back
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 print
+
+Usage is
+
+ $z->print($data)
+ print $z $data
+
+Compresses and outputs the contents of the C<$data> parameter. This
+has the same behaviour as the C<print> built-in.
+
+Returns true if successful.
+
+=head2 printf
+
+Usage is
+
+ $z->printf($format, $data)
+ printf $z $format, $data
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns true if successful.
+
+=head2 syswrite
+
+Usage is
+
+ $z->syswrite $data
+ $z->syswrite $data, $length
+ $z->syswrite $data, $length, $offset
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns the number of uncompressed bytes written, or C<undef> if
+unsuccessful.
+
+=head2 write
+
+Usage is
+
+ $z->write $data
+ $z->write $data, $length
+ $z->write $data, $length, $offset
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns the number of uncompressed bytes written, or C<undef> if
+unsuccessful.
+
+=head2 flush
+
+Usage is
+
+ $z->flush;
+ $z->flush($flush_type);
+
+Flushes any pending compressed data to the output file/buffer.
+
+This method takes an optional parameter, C<$flush_type>, that controls
+how the flushing will be carried out. By default the C<$flush_type>
+used is C<Z_FINISH>. Other valid values for C<$flush_type> are
+C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is
+strongly recommended that you only set the C<flush_type> parameter if
+you fully understand the implications of what it does - overuse of C<flush>
+can seriously degrade the level of compression achieved. See the C<zlib>
+documentation for details.
+
+Returns true on success.
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the C<close> method has been called.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the output file/buffer.
+It is a fatal error to attempt to seek backward.
+
+Empty parts of the file/buffer will have NULL (0x00) bytes written to them.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+This method always returns C<undef> when compressing.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Flushes any pending compressed data and then closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Compress::Gzip object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Compress::Gzip
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 newStream([OPTS])
+
+Usage is
+
+ $z->newStream( [OPTS] )
+
+Closes the current compressed data stream and starts a new one.
+
+OPTS consists of any of the the options that are available when creating
+the C<$z> object.
+
+See the L</"Constructor Options"> section for more details.
+
+=head2 deflateParams
+
+Usage is
+
+ $z->deflateParams
+
+TODO
+
+=head1 Importing
+
+A number of symbolic constants are required by some methods in
+C<IO::Compress::Gzip>. None are imported by default.
+
+=over 5
+
+=item :all
+
+Imports C<gzip>, C<$GzipError> and all symbolic
+constants that can be used by C<IO::Compress::Gzip>. Same as doing this
+
+ use IO::Compress::Gzip qw(gzip $GzipError :constants) ;
+
+=item :constants
+
+Import all symbolic constants. Same as doing this
+
+ use IO::Compress::Gzip qw(:flush :level :strategy) ;
+
+=item :flush
+
+These symbolic constants are used by the C<flush> method.
+
+ Z_NO_FLUSH
+ Z_PARTIAL_FLUSH
+ Z_SYNC_FLUSH
+ Z_FULL_FLUSH
+ Z_FINISH
+ Z_BLOCK
+
+=item :level
+
+These symbolic constants are used by the C<Level> option in the constructor.
+
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+
+=item :strategy
+
+These symbolic constants are used by the C<Strategy> option in the constructor.
+
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+
+
+
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Apache::GZip Revisited
+
+See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
+
+
+
+=head2 Working with Net::FTP
+
+See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Gzip/Constants.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Gzip/Constants.pm
new file mode 100755
index 00000000000..8504330d188
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Gzip/Constants.pm
@@ -0,0 +1,148 @@
+package IO::Compress::Gzip::Constants;
+
+use strict ;
+use warnings;
+use bytes;
+
+require Exporter;
+
+our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names);
+our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE);
+
+$VERSION = '2.024';
+
+@ISA = qw(Exporter);
+
+@EXPORT= qw(
+
+ GZIP_ID_SIZE
+ GZIP_ID1
+ GZIP_ID2
+
+ GZIP_FLG_DEFAULT
+ GZIP_FLG_FTEXT
+ GZIP_FLG_FHCRC
+ GZIP_FLG_FEXTRA
+ GZIP_FLG_FNAME
+ GZIP_FLG_FCOMMENT
+ GZIP_FLG_RESERVED
+
+ GZIP_CM_DEFLATED
+
+ GZIP_MIN_HEADER_SIZE
+ GZIP_TRAILER_SIZE
+
+ GZIP_MTIME_DEFAULT
+ GZIP_XFL_DEFAULT
+ GZIP_FEXTRA_HEADER_SIZE
+ GZIP_FEXTRA_MAX_SIZE
+ GZIP_FEXTRA_SUBFIELD_HEADER_SIZE
+ GZIP_FEXTRA_SUBFIELD_ID_SIZE
+ GZIP_FEXTRA_SUBFIELD_LEN_SIZE
+ GZIP_FEXTRA_SUBFIELD_MAX_SIZE
+
+ $GZIP_FNAME_INVALID_CHAR_RE
+ $GZIP_FCOMMENT_INVALID_CHAR_RE
+
+ GZIP_FHCRC_SIZE
+
+ GZIP_ISIZE_MAX
+ GZIP_ISIZE_MOD_VALUE
+
+
+ GZIP_NULL_BYTE
+
+ GZIP_OS_DEFAULT
+
+ %GZIP_OS_Names
+
+ GZIP_MINIMUM_HEADER
+
+ );
+
+# Constant names derived from RFC 1952
+
+use constant GZIP_ID_SIZE => 2 ;
+use constant GZIP_ID1 => 0x1F;
+use constant GZIP_ID2 => 0x8B;
+
+use constant GZIP_MIN_HEADER_SIZE => 10 ;# minimum gzip header size
+use constant GZIP_TRAILER_SIZE => 8 ;
+
+
+use constant GZIP_FLG_DEFAULT => 0x00 ;
+use constant GZIP_FLG_FTEXT => 0x01 ;
+use constant GZIP_FLG_FHCRC => 0x02 ; # called CONTINUATION in gzip
+use constant GZIP_FLG_FEXTRA => 0x04 ;
+use constant GZIP_FLG_FNAME => 0x08 ;
+use constant GZIP_FLG_FCOMMENT => 0x10 ;
+#use constant GZIP_FLG_ENCRYPTED => 0x20 ; # documented in gzip sources
+use constant GZIP_FLG_RESERVED => (0x20 | 0x40 | 0x80) ;
+
+use constant GZIP_XFL_DEFAULT => 0x00 ;
+
+use constant GZIP_MTIME_DEFAULT => 0x00 ;
+
+use constant GZIP_FEXTRA_HEADER_SIZE => 2 ;
+use constant GZIP_FEXTRA_MAX_SIZE => 0xFFFF ;
+use constant GZIP_FEXTRA_SUBFIELD_ID_SIZE => 2 ;
+use constant GZIP_FEXTRA_SUBFIELD_LEN_SIZE => 2 ;
+use constant GZIP_FEXTRA_SUBFIELD_HEADER_SIZE => GZIP_FEXTRA_SUBFIELD_ID_SIZE +
+ GZIP_FEXTRA_SUBFIELD_LEN_SIZE;
+use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => GZIP_FEXTRA_MAX_SIZE -
+ GZIP_FEXTRA_SUBFIELD_HEADER_SIZE ;
+
+
+if (ord('A') == 193)
+{
+ # EBCDIC
+ $GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x3f\xff]';
+ $GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x0a\x11-\x14\x16-\x3f\xff]';
+
+}
+else
+{
+ $GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x1F\x7F-\x9F]';
+ $GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x09\x11-\x1F\x7F-\x9F]';
+}
+
+use constant GZIP_FHCRC_SIZE => 2 ; # aka CONTINUATION in gzip
+
+use constant GZIP_CM_DEFLATED => 8 ;
+
+use constant GZIP_NULL_BYTE => "\x00";
+use constant GZIP_ISIZE_MAX => 0xFFFFFFFF ;
+use constant GZIP_ISIZE_MOD_VALUE => GZIP_ISIZE_MAX + 1 ;
+
+# OS Names sourced from http://www.gzip.org/format.txt
+
+use constant GZIP_OS_DEFAULT=> 0xFF ;
+%GZIP_OS_Names = (
+ 0 => 'MS-DOS',
+ 1 => 'Amiga',
+ 2 => 'VMS',
+ 3 => 'Unix',
+ 4 => 'VM/CMS',
+ 5 => 'Atari TOS',
+ 6 => 'HPFS (OS/2, NT)',
+ 7 => 'Macintosh',
+ 8 => 'Z-System',
+ 9 => 'CP/M',
+ 10 => 'TOPS-20',
+ 11 => 'NTFS (NT)',
+ 12 => 'SMS QDOS',
+ 13 => 'Acorn RISCOS',
+ 14 => 'VFAT file system (Win95, NT)',
+ 15 => 'MVS',
+ 16 => 'BeOS',
+ 17 => 'Tandem/NSK',
+ 18 => 'THEOS',
+ GZIP_OS_DEFAULT() => 'Unknown',
+ ) ;
+
+use constant GZIP_MINIMUM_HEADER => pack("C4 V C C",
+ GZIP_ID1, GZIP_ID2, GZIP_CM_DEFLATED, GZIP_FLG_DEFAULT,
+ GZIP_MTIME_DEFAULT, GZIP_XFL_DEFAULT, GZIP_OS_DEFAULT) ;
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm b/Master/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm
new file mode 100755
index 00000000000..b97b51c0509
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/RawDeflate.pm
@@ -0,0 +1,1017 @@
+package IO::Compress::RawDeflate ;
+
+# create RFC1951
+#
+use strict ;
+use warnings;
+use bytes;
+
+
+use IO::Compress::Base 2.024 ;
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+use IO::Compress::Adapter::Deflate 2.024 ;
+
+require Exporter ;
+
+
+our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError);
+
+$VERSION = '2.024';
+$RawDeflateError = '';
+
+@ISA = qw(Exporter IO::Compress::Base);
+@EXPORT_OK = qw( $RawDeflateError rawdeflate ) ;
+
+%EXPORT_TAGS = ( flush => [qw{
+ Z_NO_FLUSH
+ Z_PARTIAL_FLUSH
+ Z_SYNC_FLUSH
+ Z_FULL_FLUSH
+ Z_FINISH
+ Z_BLOCK
+ }],
+ level => [qw{
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+ }],
+ strategy => [qw{
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+ }],
+
+ );
+
+{
+ my %seen;
+ foreach (keys %EXPORT_TAGS )
+ {
+ push @{$EXPORT_TAGS{constants}},
+ grep { !$seen{$_}++ }
+ @{ $EXPORT_TAGS{$_} }
+ }
+ $EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ;
+}
+
+
+%DEFLATE_CONSTANTS = %EXPORT_TAGS;
+
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+
+Exporter::export_ok_tags('all');
+
+
+
+sub new
+{
+ my $class = shift ;
+
+ my $obj = createSelfTiedObject($class, \$RawDeflateError);
+
+ return $obj->_create(undef, @_);
+}
+
+sub rawdeflate
+{
+ my $obj = createSelfTiedObject(undef, \$RawDeflateError);
+ return $obj->_def(@_);
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift;
+
+ return 1 ;
+}
+
+sub mkComp
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ my ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject(
+ $got->value('CRC32'),
+ $got->value('Adler32'),
+ $got->value('Level'),
+ $got->value('Strategy')
+ );
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ return $obj;
+}
+
+
+sub mkHeader
+{
+ my $self = shift ;
+ return '';
+}
+
+sub mkTrailer
+{
+ my $self = shift ;
+ return '';
+}
+
+sub mkFinalTrailer
+{
+ return '';
+}
+
+
+#sub newHeader
+#{
+# my $self = shift ;
+# return '';
+#}
+
+sub getExtraParams
+{
+ my $self = shift ;
+ return $self->getZlibParams();
+}
+
+sub getZlibParams
+{
+ my $self = shift ;
+
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+ use Compress::Raw::Zlib 2.024 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY);
+
+
+ return (
+
+ # zlib behaviour
+ #'Method' => [0, 1, Parse_unsigned, Z_DEFLATED],
+ 'Level' => [0, 1, Parse_signed, Z_DEFAULT_COMPRESSION],
+ 'Strategy' => [0, 1, Parse_signed, Z_DEFAULT_STRATEGY],
+
+ 'CRC32' => [0, 1, Parse_boolean, 0],
+ 'ADLER32' => [0, 1, Parse_boolean, 0],
+ 'Merge' => [1, 1, Parse_boolean, 0],
+ );
+
+
+}
+
+sub getInverseClass
+{
+ return ('IO::Uncompress::RawInflate',
+ \$IO::Uncompress::RawInflate::RawInflateError);
+}
+
+sub getFileInfo
+{
+ my $self = shift ;
+ my $params = shift;
+ my $file = shift ;
+
+}
+
+use IO::Seekable qw(SEEK_SET);
+
+sub createMerge
+{
+ my $self = shift ;
+ my $outValue = shift ;
+ my $outType = shift ;
+
+ my ($invClass, $error_ref) = $self->getInverseClass();
+ eval "require $invClass"
+ or die "aaaahhhh" ;
+
+ my $inf = $invClass->new( $outValue,
+ Transparent => 0,
+ #Strict => 1,
+ AutoClose => 0,
+ Scan => 1)
+ or return $self->saveErrorString(undef, "Cannot create InflateScan object: $$error_ref" ) ;
+
+ my $end_offset = 0;
+ $inf->scan()
+ or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $inf->errorNo) ;
+ $inf->zap($end_offset)
+ or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $inf->errorNo) ;
+
+ my $def = *$self->{Compress} = $inf->createDeflate();
+
+ *$self->{Header} = *$inf->{Info}{Header};
+ *$self->{UnCompSize} = *$inf->{UnCompSize}->clone();
+ *$self->{CompSize} = *$inf->{CompSize}->clone();
+ # TODO -- fix this
+ #*$self->{CompSize} = new U64(0, *$self->{UnCompSize_32bit});
+
+
+ if ( $outType eq 'buffer')
+ { substr( ${ *$self->{Buffer} }, $end_offset) = '' }
+ elsif ($outType eq 'handle' || $outType eq 'filename') {
+ *$self->{FH} = *$inf->{FH} ;
+ delete *$inf->{FH};
+ *$self->{FH}->flush() ;
+ *$self->{Handle} = 1 if $outType eq 'handle';
+
+ #seek(*$self->{FH}, $end_offset, SEEK_SET)
+ *$self->{FH}->seek($end_offset, SEEK_SET)
+ or return $self->saveErrorString(undef, $!, $!) ;
+ }
+
+ return $def ;
+}
+
+#### zlib specific methods
+
+sub deflateParams
+{
+ my $self = shift ;
+
+ my $level = shift ;
+ my $strategy = shift ;
+
+ my $status = *$self->{Compress}->deflateParams(Level => $level, Strategy => $strategy) ;
+ return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo})
+ if $status == STATUS_ERROR;
+
+ return 1;
+}
+
+
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Compress::RawDeflate - Write RFC 1951 files/buffers
+
+
+
+=head1 SYNOPSIS
+
+ use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ;
+
+ my $status = rawdeflate $input => $output [,OPTS]
+ or die "rawdeflate failed: $RawDeflateError\n";
+
+ my $z = new IO::Compress::RawDeflate $output [,OPTS]
+ or die "rawdeflate failed: $RawDeflateError\n";
+
+ $z->print($string);
+ $z->printf($format, $string);
+ $z->write($string);
+ $z->syswrite($string [, $length, $offset]);
+ $z->flush();
+ $z->tell();
+ $z->eof();
+ $z->seek($position, $whence);
+ $z->binmode();
+ $z->fileno();
+ $z->opened();
+ $z->autoflush();
+ $z->input_line_number();
+ $z->newStream( [OPTS] );
+
+ $z->deflateParams();
+
+ $z->close() ;
+
+ $RawDeflateError ;
+
+ # IO::File mode
+
+ print $z $string;
+ printf $z $format, $string;
+ tell $z
+ eof $z
+ seek $z, $position, $whence
+ binmode $z
+ fileno $z
+ close $z ;
+
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows writing compressed
+data to files or buffer as defined in RFC 1951.
+
+Note that RFC 1951 data is not a good choice of compression format
+to use in isolation, especially if you want to auto-detect it.
+
+For reading RFC 1951 files/buffers, see the companion module
+L<IO::Uncompress::RawInflate|IO::Uncompress::RawInflate>.
+
+=head1 Functional Interface
+
+A top-level function, C<rawdeflate>, is provided to carry out
+"one-shot" compression between buffers and/or files. For finer
+control over the compression process, see the L</"OO Interface">
+section.
+
+ use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ;
+
+ rawdeflate $input => $output [,OPTS]
+ or die "rawdeflate failed: $RawDeflateError\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 rawdeflate $input => $output [, OPTS]
+
+C<rawdeflate> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the uncompressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is compressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<rawdeflate> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+compressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<rawdeflate> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple files/buffers and C<$output> is a single
+file/buffer the input files/buffers will be stored
+in C<$output> as a concatenated series of compressed data streams.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<rawdeflate>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<rawdeflate> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<rawdeflate> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeIn => 0|1 >>
+
+When reading from a file or filehandle, set C<binmode> before reading.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+The behaviour of this option is dependent on the type of output data
+stream.
+
+=over 5
+
+=item * A Buffer
+
+If C<Append> is enabled, all compressed data will be append to the end of
+the output buffer. Otherwise the output buffer will be cleared before any
+compressed data is written to it.
+
+=item * A Filename
+
+If C<Append> is enabled, the file will be opened in append mode. Otherwise
+the contents of the file, if any, will be truncated before any compressed
+data is written to it.
+
+=item * A Filehandle
+
+If C<Append> is enabled, the filehandle will be positioned to the end of
+the file via a call to C<seek> before any compressed data is
+written to it. Otherwise the file pointer will not be moved.
+
+=back
+
+When C<Append> is specified, and set to true, it will I<append> all compressed
+data to the output data stream.
+
+So when the output is a filehandle it will carry out a seek to the eof
+before writing any compressed data. If the output is a filename, it will be opened for
+appending. If the output is a buffer, all compressed data will be appened to
+the existing buffer.
+
+Conversely when C<Append> is not specified, or it is present and is set to
+false, it will operate as follows.
+
+When the output is a filename, it will truncate the contents of the file
+before writing any compressed data. If the output is a filehandle
+its position will not be changed. If the output is a buffer, it will be
+wiped before any compressed data is output.
+
+Defaults to 0.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt> and write the compressed
+data to the file C<file1.txt.1951>.
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ;
+
+ my $input = "file1.txt";
+ rawdeflate $input => "$input.1951"
+ or die "rawdeflate failed: $RawDeflateError\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+compressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt"
+ or die "Cannot open 'file1.txt': $!\n" ;
+ my $buffer ;
+ rawdeflate $input => \$buffer
+ or die "rawdeflate failed: $RawDeflateError\n";
+
+To compress all files in the directory "/my/home" that match "*.txt"
+and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ;
+
+ rawdeflate '</my/home/*.txt>' => '<*.1951>'
+ or die "rawdeflate failed: $RawDeflateError\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ;
+
+ for my $input ( glob "/my/home/*.txt" )
+ {
+ my $output = "$input.1951" ;
+ rawdeflate $input => $output
+ or die "Error compressing '$input': $RawDeflateError\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for C<IO::Compress::RawDeflate> is shown below
+
+ my $z = new IO::Compress::RawDeflate $output [,OPTS]
+ or die "IO::Compress::RawDeflate failed: $RawDeflateError\n";
+
+It returns an C<IO::Compress::RawDeflate> object on success and undef on failure.
+The variable C<$RawDeflateError> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Compress::RawDeflate can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal output file operations can be carried out
+with C<$z>.
+For example, to write to a compressed file/buffer you can use either of
+these forms
+
+ $z->print("hello world\n");
+ print $z "hello world\n";
+
+The mandatory parameter C<$output> is used to control the destination
+of the compressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed data
+will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the compressed data will be
+written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the compressed data will be stored
+in C<$$output>.
+
+=back
+
+If the C<$output> parameter is any other type, C<IO::Compress::RawDeflate>::new will
+return undef.
+
+=head2 Constructor Options
+
+C<OPTS> is any combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$output> parameter is a filehandle. If
+specified, and the value is true, it will result in the C<$output> being
+closed once either the C<close> method is called or the C<IO::Compress::RawDeflate>
+object is destroyed.
+
+This parameter defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+Opens C<$output> in append mode.
+
+The behaviour of this option is dependent on the type of C<$output>.
+
+=over 5
+
+=item * A Buffer
+
+If C<$output> is a buffer and C<Append> is enabled, all compressed data
+will be append to the end of C<$output>. Otherwise C<$output> will be
+cleared before any data is written to it.
+
+=item * A Filename
+
+If C<$output> is a filename and C<Append> is enabled, the file will be
+opened in append mode. Otherwise the contents of the file, if any, will be
+truncated before any compressed data is written to it.
+
+=item * A Filehandle
+
+If C<$output> is a filehandle, the file pointer will be positioned to the
+end of the file via a call to C<seek> before any compressed data is written
+to it. Otherwise the file pointer will not be moved.
+
+=back
+
+This parameter defaults to 0.
+
+=item C<< Merge => 0|1 >>
+
+This option is used to compress input data and append it to an existing
+compressed data stream in C<$output>. The end result is a single compressed
+data stream stored in C<$output>.
+
+It is a fatal error to attempt to use this option when C<$output> is not an
+RFC 1951 data stream.
+
+There are a number of other limitations with the C<Merge> option:
+
+=over 5
+
+=item 1
+
+This module needs to have been built with zlib 1.2.1 or better to work. A
+fatal error will be thrown if C<Merge> is used with an older version of
+zlib.
+
+=item 2
+
+If C<$output> is a file or a filehandle, it must be seekable.
+
+=back
+
+This parameter defaults to 0.
+
+=item -Level
+
+Defines the compression level used by zlib. The value should either be
+a number between 0 and 9 (0 means no compression and 9 is maximum
+compression), or one of the symbolic constants defined below.
+
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+
+The default is Z_DEFAULT_COMPRESSION.
+
+Note, these constants are not imported by C<IO::Compress::RawDeflate> by default.
+
+ use IO::Compress::RawDeflate qw(:strategy);
+ use IO::Compress::RawDeflate qw(:constants);
+ use IO::Compress::RawDeflate qw(:all);
+
+=item -Strategy
+
+Defines the strategy used to tune the compression. Use one of the symbolic
+constants defined below.
+
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+
+The default is Z_DEFAULT_STRATEGY.
+
+=item C<< Strict => 0|1 >>
+
+This is a placeholder option.
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 print
+
+Usage is
+
+ $z->print($data)
+ print $z $data
+
+Compresses and outputs the contents of the C<$data> parameter. This
+has the same behaviour as the C<print> built-in.
+
+Returns true if successful.
+
+=head2 printf
+
+Usage is
+
+ $z->printf($format, $data)
+ printf $z $format, $data
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns true if successful.
+
+=head2 syswrite
+
+Usage is
+
+ $z->syswrite $data
+ $z->syswrite $data, $length
+ $z->syswrite $data, $length, $offset
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns the number of uncompressed bytes written, or C<undef> if
+unsuccessful.
+
+=head2 write
+
+Usage is
+
+ $z->write $data
+ $z->write $data, $length
+ $z->write $data, $length, $offset
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns the number of uncompressed bytes written, or C<undef> if
+unsuccessful.
+
+=head2 flush
+
+Usage is
+
+ $z->flush;
+ $z->flush($flush_type);
+
+Flushes any pending compressed data to the output file/buffer.
+
+This method takes an optional parameter, C<$flush_type>, that controls
+how the flushing will be carried out. By default the C<$flush_type>
+used is C<Z_FINISH>. Other valid values for C<$flush_type> are
+C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is
+strongly recommended that you only set the C<flush_type> parameter if
+you fully understand the implications of what it does - overuse of C<flush>
+can seriously degrade the level of compression achieved. See the C<zlib>
+documentation for details.
+
+Returns true on success.
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the C<close> method has been called.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the output file/buffer.
+It is a fatal error to attempt to seek backward.
+
+Empty parts of the file/buffer will have NULL (0x00) bytes written to them.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+This method always returns C<undef> when compressing.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Flushes any pending compressed data and then closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Compress::RawDeflate object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Compress::RawDeflate
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 newStream([OPTS])
+
+Usage is
+
+ $z->newStream( [OPTS] )
+
+Closes the current compressed data stream and starts a new one.
+
+OPTS consists of any of the the options that are available when creating
+the C<$z> object.
+
+See the L</"Constructor Options"> section for more details.
+
+=head2 deflateParams
+
+Usage is
+
+ $z->deflateParams
+
+TODO
+
+=head1 Importing
+
+A number of symbolic constants are required by some methods in
+C<IO::Compress::RawDeflate>. None are imported by default.
+
+=over 5
+
+=item :all
+
+Imports C<rawdeflate>, C<$RawDeflateError> and all symbolic
+constants that can be used by C<IO::Compress::RawDeflate>. Same as doing this
+
+ use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError :constants) ;
+
+=item :constants
+
+Import all symbolic constants. Same as doing this
+
+ use IO::Compress::RawDeflate qw(:flush :level :strategy) ;
+
+=item :flush
+
+These symbolic constants are used by the C<flush> method.
+
+ Z_NO_FLUSH
+ Z_PARTIAL_FLUSH
+ Z_SYNC_FLUSH
+ Z_FULL_FLUSH
+ Z_FINISH
+ Z_BLOCK
+
+=item :level
+
+These symbolic constants are used by the C<Level> option in the constructor.
+
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+
+=item :strategy
+
+These symbolic constants are used by the C<Strategy> option in the constructor.
+
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+
+
+
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Apache::GZip Revisited
+
+See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
+
+
+
+=head2 Working with Net::FTP
+
+See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Zip.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Zip.pm
new file mode 100755
index 00000000000..5e37d78f97d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Zip.pm
@@ -0,0 +1,1612 @@
+package IO::Compress::Zip ;
+
+use strict ;
+use warnings;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+use IO::Compress::RawDeflate 2.024 ;
+use IO::Compress::Adapter::Deflate 2.024 ;
+use IO::Compress::Adapter::Identity 2.024 ;
+use IO::Compress::Zlib::Extra 2.024 ;
+use IO::Compress::Zip::Constants 2.024 ;
+
+
+use Compress::Raw::Zlib 2.024 qw(crc32) ;
+BEGIN
+{
+ eval { require IO::Compress::Adapter::Bzip2 ;
+ import IO::Compress::Adapter::Bzip2 2.024 ;
+ require IO::Compress::Bzip2 ;
+ import IO::Compress::Bzip2 2.024 ;
+ } ;
+# eval { require IO::Compress::Adapter::Lzma ;
+# import IO::Compress::Adapter::Lzma 2.020 ;
+# require IO::Compress::Lzma ;
+# import IO::Compress::Lzma 2.024 ;
+# } ;
+}
+
+
+require Exporter ;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $ZipError);
+
+$VERSION = '2.024';
+$ZipError = '';
+
+@ISA = qw(Exporter IO::Compress::RawDeflate);
+@EXPORT_OK = qw( $ZipError zip ) ;
+%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+
+$EXPORT_TAGS{zip_method} = [qw( ZIP_CM_STORE ZIP_CM_DEFLATE ZIP_CM_BZIP2 ZIP_CM_LZMA)];
+push @{ $EXPORT_TAGS{all} }, @{ $EXPORT_TAGS{zip_method} };
+
+Exporter::export_ok_tags('all');
+
+sub new
+{
+ my $class = shift ;
+
+ my $obj = createSelfTiedObject($class, \$ZipError);
+ $obj->_create(undef, @_);
+}
+
+sub zip
+{
+ my $obj = createSelfTiedObject(undef, \$ZipError);
+ return $obj->_def(@_);
+}
+
+sub mkComp
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ my ($obj, $errstr, $errno) ;
+
+ if (*$self->{ZipData}{Method} == ZIP_CM_STORE) {
+ ($obj, $errstr, $errno) = IO::Compress::Adapter::Identity::mkCompObject(
+ $got->value('Level'),
+ $got->value('Strategy')
+ );
+ *$self->{ZipData}{CRC32} = crc32(undef);
+ }
+ elsif (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) {
+ ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject(
+ $got->value('CRC32'),
+ $got->value('Adler32'),
+ $got->value('Level'),
+ $got->value('Strategy')
+ );
+ }
+ elsif (*$self->{ZipData}{Method} == ZIP_CM_BZIP2) {
+ ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject(
+ $got->value('BlockSize100K'),
+ $got->value('WorkFactor'),
+ $got->value('Verbosity')
+ );
+ *$self->{ZipData}{CRC32} = crc32(undef);
+ }
+# elsif (*$self->{ZipData}{Method} == ZIP_CM_LZMA) {
+# ($obj, $errstr, $errno) = IO::Compress::Adapter::Lzma::mkCompObject();
+# *$self->{ZipData}{CRC32} = crc32(undef);
+# }
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ if (! defined *$self->{ZipData}{SizesOffset}) {
+ *$self->{ZipData}{SizesOffset} = 0;
+ *$self->{ZipData}{Offset} = new U64 ;
+ }
+
+ *$self->{ZipData}{AnyZip64} = 0
+ if ! defined *$self->{ZipData}{AnyZip64} ;
+
+ return $obj;
+}
+
+sub reset
+{
+ my $self = shift ;
+
+ *$self->{Compress}->reset();
+ *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32('');
+
+ return STATUS_OK;
+}
+
+sub filterUncompressed
+{
+ my $self = shift ;
+
+ if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) {
+ *$self->{ZipData}{CRC32} = *$self->{Compress}->crc32();
+ }
+ else {
+ *$self->{ZipData}{CRC32} = crc32(${$_[0]}, *$self->{ZipData}{CRC32});
+
+ }
+}
+
+sub mkHeader
+{
+ my $self = shift;
+ my $param = shift ;
+
+
+ *$self->{ZipData}{LocalHdrOffset} = U64::clone(*$self->{ZipData}{Offset});
+
+ my $filename = '';
+ $filename = $param->value('Name') || '';
+
+ my $comment = '';
+ $comment = $param->value('Comment') || '';
+
+ my $hdr = '';
+
+ my $time = _unixToDosTime($param->value('Time'));
+
+ my $extra = '';
+ my $ctlExtra = '';
+ my $empty = 0;
+ my $osCode = $param->value('OS_Code') ;
+ my $extFileAttr = 0 ;
+
+ # This code assumes Unix.
+ $extFileAttr = 0666 << 16
+ if $osCode == ZIP_OS_CODE_UNIX ;
+
+ if (*$self->{ZipData}{Zip64}) {
+ $empty = 0xFFFFFFFF;
+
+ my $x = '';
+ $x .= pack "V V", 0, 0 ; # uncompressedLength
+ $x .= pack "V V", 0, 0 ; # compressedLength
+ $extra .= IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x);
+ }
+
+ if (! $param->value('Minimal')) {
+ if (defined $param->value('exTime'))
+ {
+ $extra .= mkExtendedTime($param->value('MTime'),
+ $param->value('ATime'),
+ $param->value('CTime'));
+
+ $ctlExtra .= mkExtendedTime($param->value('MTime'));
+ }
+
+ if ( $param->value('UID') && $osCode == ZIP_OS_CODE_UNIX)
+ {
+ $extra .= mkUnix2Extra( $param->value('UID'), $param->value('GID'));
+ $ctlExtra .= mkUnix2Extra();
+ }
+
+ $extFileAttr = $param->value('ExtAttr')
+ if defined $param->value('ExtAttr') ;
+
+ $extra .= $param->value('ExtraFieldLocal')
+ if defined $param->value('ExtraFieldLocal');
+
+ $ctlExtra .= $param->value('ExtraFieldCentral')
+ if defined $param->value('ExtraFieldCentral');
+ }
+
+ my $gpFlag = 0 ;
+ $gpFlag |= ZIP_GP_FLAG_STREAMING_MASK
+ if *$self->{ZipData}{Stream} ;
+
+ my $method = *$self->{ZipData}{Method} ;
+
+ my $version = $ZIP_CM_MIN_VERSIONS{$method};
+ $version = ZIP64_MIN_VERSION
+ if ZIP64_MIN_VERSION > $version && *$self->{ZipData}{Zip64};
+ my $madeBy = ($param->value('OS_Code') << 8) + $version;
+ my $extract = $version;
+
+ *$self->{ZipData}{Version} = $version;
+ *$self->{ZipData}{MadeBy} = $madeBy;
+
+ my $ifa = 0;
+ $ifa |= ZIP_IFA_TEXT_MASK
+ if $param->value('TextFlag');
+
+ $hdr .= pack "V", ZIP_LOCAL_HDR_SIG ; # signature
+ $hdr .= pack 'v', $extract ; # extract Version & OS
+ $hdr .= pack 'v', $gpFlag ; # general purpose flag (set streaming mode)
+ $hdr .= pack 'v', $method ; # compression method (deflate)
+ $hdr .= pack 'V', $time ; # last mod date/time
+ $hdr .= pack 'V', 0 ; # crc32 - 0 when streaming
+ $hdr .= pack 'V', $empty ; # compressed length - 0 when streaming
+ $hdr .= pack 'V', $empty ; # uncompressed length - 0 when streaming
+ $hdr .= pack 'v', length $filename ; # filename length
+ $hdr .= pack 'v', length $extra ; # extra length
+
+ $hdr .= $filename ;
+
+ # Remember the offset for the compressed & uncompressed lengths in the
+ # local header.
+ if (*$self->{ZipData}{Zip64}) {
+ *$self->{ZipData}{SizesOffset} = *$self->{ZipData}{Offset}->get64bit()
+ + length($hdr) + 4 ;
+ }
+ else {
+ *$self->{ZipData}{SizesOffset} = *$self->{ZipData}{Offset}->get64bit()
+ + 18;
+ }
+
+ $hdr .= $extra ;
+
+
+ my $ctl = '';
+
+ $ctl .= pack "V", ZIP_CENTRAL_HDR_SIG ; # signature
+ $ctl .= pack 'v', $madeBy ; # version made by
+ $ctl .= pack 'v', $extract ; # extract Version
+ $ctl .= pack 'v', $gpFlag ; # general purpose flag (streaming mode)
+ $ctl .= pack 'v', $method ; # compression method (deflate)
+ $ctl .= pack 'V', $time ; # last mod date/time
+ $ctl .= pack 'V', 0 ; # crc32
+ $ctl .= pack 'V', $empty ; # compressed length
+ $ctl .= pack 'V', $empty ; # uncompressed length
+ $ctl .= pack 'v', length $filename ; # filename length
+
+ *$self->{ZipData}{ExtraOffset} = length $ctl;
+ *$self->{ZipData}{ExtraSize} = length $ctlExtra ;
+
+ $ctl .= pack 'v', length $ctlExtra ; # extra length
+ $ctl .= pack 'v', length $comment ; # file comment length
+ $ctl .= pack 'v', 0 ; # disk number start
+ $ctl .= pack 'v', $ifa ; # internal file attributes
+ $ctl .= pack 'V', $extFileAttr ; # external file attributes
+
+ # offset to local hdr
+ if (*$self->{ZipData}{LocalHdrOffset}->is64bit() ) {
+ $ctl .= pack 'V', 0xFFFFFFFF ;
+ }
+ else {
+ $ctl .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V32() ;
+ }
+
+ $ctl .= $filename ;
+ $ctl .= $ctlExtra ;
+ $ctl .= $comment ;
+
+ *$self->{ZipData}{Offset}->add(length $hdr) ;
+
+ *$self->{ZipData}{CentralHeader} = $ctl;
+
+ return $hdr;
+}
+
+sub mkTrailer
+{
+ my $self = shift ;
+
+ my $crc32 ;
+ if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) {
+ $crc32 = pack "V", *$self->{Compress}->crc32();
+ }
+ else {
+ $crc32 = pack "V", *$self->{ZipData}{CRC32};
+ }
+
+ my $ctl = *$self->{ZipData}{CentralHeader} ;
+
+ my $sizes ;
+ if (! *$self->{ZipData}{Zip64}) {
+ $sizes .= *$self->{CompSize}->getPacked_V32() ; # Compressed size
+ $sizes .= *$self->{UnCompSize}->getPacked_V32() ; # Uncompressed size
+ }
+ else {
+ $sizes .= *$self->{CompSize}->getPacked_V64() ; # Compressed size
+ $sizes .= *$self->{UnCompSize}->getPacked_V64() ; # Uncompressed size
+ }
+
+ my $data = $crc32 . $sizes ;
+
+ my $xtrasize = *$self->{UnCompSize}->getPacked_V64() ; # Uncompressed size
+ $xtrasize .= *$self->{CompSize}->getPacked_V64() ; # Compressed size
+
+ my $hdr = '';
+
+ if (*$self->{ZipData}{Stream}) {
+ $hdr = pack "V", ZIP_DATA_HDR_SIG ; # signature
+ $hdr .= $data ;
+ }
+ else {
+ $self->writeAt(*$self->{ZipData}{LocalHdrOffset}->get64bit() + 14, $crc32)
+ or return undef;
+ $self->writeAt(*$self->{ZipData}{SizesOffset},
+ *$self->{ZipData}{Zip64} ? $xtrasize : $sizes)
+ or return undef;
+ }
+
+ # Central Header Record/Zip64 extended field
+
+ substr($ctl, 16, length $crc32) = $crc32 ;
+
+ my $x = '';
+
+ # uncompressed length
+ if (*$self->{UnCompSize}->is64bit() ) {
+ $x .= *$self->{UnCompSize}->getPacked_V64() ;
+ } else {
+ substr($ctl, 24, 4) = *$self->{UnCompSize}->getPacked_V32() ;
+ }
+
+ # compressed length
+ if (*$self->{CompSize}->is64bit() ) {
+ $x .= *$self->{CompSize}->getPacked_V64() ;
+ } else {
+ substr($ctl, 20, 4) = *$self->{CompSize}->getPacked_V32() ;
+ }
+
+ # Local Header offset
+ $x .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V64()
+ if *$self->{ZipData}{LocalHdrOffset}->is64bit() ;
+
+ # disk no - always zero, so don't need it
+ #$x .= pack "V", 0 ;
+
+ if (length $x) {
+ my $xtra = IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x);
+ $ctl .= $xtra ;
+ substr($ctl, *$self->{ZipData}{ExtraOffset}, 2) =
+ pack 'v', *$self->{ZipData}{ExtraSize} + length $xtra;
+
+ *$self->{ZipData}{AnyZip64} = 1;
+ }
+
+ *$self->{ZipData}{Offset}->add(length($hdr));
+ *$self->{ZipData}{Offset}->add( *$self->{CompSize} );
+ push @{ *$self->{ZipData}{CentralDir} }, $ctl ;
+
+ return $hdr;
+}
+
+sub mkFinalTrailer
+{
+ my $self = shift ;
+
+ my $comment = '';
+ $comment = *$self->{ZipData}{ZipComment} ;
+
+ my $cd_offset = *$self->{ZipData}{Offset}->get32bit() ; # offset to start central dir
+
+ my $entries = @{ *$self->{ZipData}{CentralDir} };
+ my $cd = join '', @{ *$self->{ZipData}{CentralDir} };
+ my $cd_len = length $cd ;
+
+ my $z64e = '';
+
+ if ( *$self->{ZipData}{AnyZip64} ) {
+
+ my $v = *$self->{ZipData}{Version} ;
+ my $mb = *$self->{ZipData}{MadeBy} ;
+ $z64e .= pack 'v', $mb ; # Version made by
+ $z64e .= pack 'v', $v ; # Version to extract
+ $z64e .= pack 'V', 0 ; # number of disk
+ $z64e .= pack 'V', 0 ; # number of disk with central dir
+ $z64e .= U64::pack_V64 $entries ; # entries in central dir on this disk
+ $z64e .= U64::pack_V64 $entries ; # entries in central dir
+ $z64e .= U64::pack_V64 $cd_len ; # size of central dir
+ $z64e .= *$self->{ZipData}{Offset}->getPacked_V64() ; # offset to start central dir
+
+ $z64e = pack("V", ZIP64_END_CENTRAL_REC_HDR_SIG) # signature
+ . U64::pack_V64(length $z64e)
+ . $z64e ;
+
+ *$self->{ZipData}{Offset}->add(length $cd) ;
+
+ $z64e .= pack "V", ZIP64_END_CENTRAL_LOC_HDR_SIG; # signature
+ $z64e .= pack 'V', 0 ; # number of disk with central dir
+ $z64e .= *$self->{ZipData}{Offset}->getPacked_V64() ; # offset to end zip64 central dir
+ $z64e .= pack 'V', 1 ; # Total number of disks
+
+ $cd_offset = 0xFFFFFFFF ;
+ $cd_len = 0xFFFFFFFF if $cd_len >= 0xFFFFFFFF ;
+ $entries = 0xFFFF if $entries >= 0xFFFF ;
+ }
+
+ my $ecd = '';
+ $ecd .= pack "V", ZIP_END_CENTRAL_HDR_SIG ; # signature
+ $ecd .= pack 'v', 0 ; # number of disk
+ $ecd .= pack 'v', 0 ; # number of disk with central dir
+ $ecd .= pack 'v', $entries ; # entries in central dir on this disk
+ $ecd .= pack 'v', $entries ; # entries in central dir
+ $ecd .= pack 'V', $cd_len ; # size of central dir
+ $ecd .= pack 'V', $cd_offset ; # offset to start central dir
+ $ecd .= pack 'v', length $comment ; # zipfile comment length
+ $ecd .= $comment;
+
+ return $cd . $z64e . $ecd ;
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift;
+
+ $got->value('CRC32' => 1);
+
+ if (! $got->parsed('Time') ) {
+ # Modification time defaults to now.
+ $got->value('Time' => time) ;
+ }
+
+ if ($got->parsed('exTime') ) {
+ my $timeRef = $got->value('exTime');
+ if ( defined $timeRef) {
+ return $self->saveErrorString(undef, "exTime not a 3-element array ref")
+ if ref $timeRef ne 'ARRAY' || @$timeRef != 3;
+ }
+
+ $got->value("MTime", $timeRef->[1]);
+ $got->value("ATime", $timeRef->[0]);
+ $got->value("CTime", $timeRef->[2]);
+ }
+
+ # Unix2 Extended Attribute
+ if ($got->parsed('exUnix2') ) {
+ my $timeRef = $got->value('exUnix2');
+ if ( defined $timeRef) {
+ return $self->saveErrorString(undef, "exUnix2 not a 2-element array ref")
+ if ref $timeRef ne 'ARRAY' || @$timeRef != 2;
+ }
+
+ $got->value("UID", $timeRef->[0]);
+ $got->value("GID", $timeRef->[1]);
+ }
+
+ *$self->{ZipData}{AnyZip64} = 1
+ if $got->value('Zip64');
+ *$self->{ZipData}{Zip64} = $got->value('Zip64');
+ *$self->{ZipData}{Stream} = $got->value('Stream');
+
+ my $method = $got->value('Method');
+ return $self->saveErrorString(undef, "Unknown Method '$method'")
+ if ! defined $ZIP_CM_MIN_VERSIONS{$method};
+
+ return $self->saveErrorString(undef, "Bzip2 not available")
+ if $method == ZIP_CM_BZIP2 and
+ ! defined $IO::Compress::Adapter::Bzip2::VERSION;
+
+ return $self->saveErrorString(undef, "Lzma not available")
+ if $method == ZIP_CM_LZMA ;
+ #and
+ #! defined $IO::Compress::Adapter::Lzma::VERSION;
+
+ *$self->{ZipData}{Method} = $method;
+
+ *$self->{ZipData}{ZipComment} = $got->value('ZipComment') ;
+
+ for my $name (qw( ExtraFieldLocal ExtraFieldCentral ))
+ {
+ my $data = $got->value($name) ;
+ if (defined $data) {
+ my $bad = IO::Compress::Zlib::Extra::parseExtraField($data, 1, 0) ;
+ return $self->saveErrorString(undef, "Error with $name Parameter: $bad")
+ if $bad ;
+
+ $got->value($name, $data) ;
+ }
+ }
+
+ return undef
+ if defined $IO::Compress::Bzip2::VERSION
+ and ! IO::Compress::Bzip2::ckParams($self, $got);
+
+ return 1 ;
+}
+
+#sub newHeader
+#{
+# my $self = shift ;
+#
+# return $self->mkHeader(*$self->{Got});
+#}
+
+sub getExtraParams
+{
+ my $self = shift ;
+
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+ use Compress::Raw::Zlib 2.024 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY);
+
+ my @Bzip2 = ();
+
+ @Bzip2 = IO::Compress::Bzip2::getExtraParams($self)
+ if defined $IO::Compress::Bzip2::VERSION;
+
+ return (
+ # zlib behaviour
+ $self->getZlibParams(),
+
+ 'Stream' => [1, 1, Parse_boolean, 1],
+ #'Store' => [0, 1, Parse_boolean, 0],
+ 'Method' => [0, 1, Parse_unsigned, ZIP_CM_DEFLATE],
+
+# # Zip header fields
+ 'Minimal' => [0, 1, Parse_boolean, 0],
+ 'Zip64' => [0, 1, Parse_boolean, 0],
+ 'Comment' => [0, 1, Parse_any, ''],
+ 'ZipComment'=> [0, 1, Parse_any, ''],
+ 'Name' => [0, 1, Parse_any, ''],
+ 'Time' => [0, 1, Parse_any, undef],
+ 'exTime' => [0, 1, Parse_any, undef],
+ 'exUnix2' => [0, 1, Parse_any, undef],
+ 'ExtAttr' => [0, 1, Parse_any, 0],
+ 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code],
+
+ 'TextFlag' => [0, 1, Parse_boolean, 0],
+ 'ExtraFieldLocal' => [0, 1, Parse_any, undef],
+ 'ExtraFieldCentral'=> [0, 1, Parse_any, undef],
+
+ @Bzip2,
+ );
+}
+
+sub getInverseClass
+{
+ return ('IO::Uncompress::Unzip',
+ \$IO::Uncompress::Unzip::UnzipError);
+}
+
+sub getFileInfo
+{
+ my $self = shift ;
+ my $params = shift;
+ my $filename = shift ;
+
+ my ($mode, $uid, $gid, $atime, $mtime, $ctime)
+ = (stat($filename))[2, 4,5, 8,9,10] ;
+
+ $params->value('Name' => $filename)
+ if ! $params->parsed('Name') ;
+
+ $params->value('Time' => $mtime)
+ if ! $params->parsed('Time') ;
+
+ if ( ! $params->parsed('exTime'))
+ {
+ $params->value('MTime' => $mtime) ;
+ $params->value('ATime' => $atime) ;
+ $params->value('CTime' => undef) ; # No Creation time
+ $params->value("exTime", [$mtime, $atime, undef]);
+ }
+
+ # NOTE - Unix specific code alert
+ $params->value('ExtAttr' => $mode << 16)
+ if ! $params->parsed('ExtAttr');
+
+ $params->value('UID' => $uid) ;
+ $params->value('GID' => $gid) ;
+
+}
+
+sub mkExtendedTime
+{
+ # order expected is m, a, c
+
+ my $times = '';
+ my $bit = 1 ;
+ my $flags = 0;
+
+ for my $time (@_)
+ {
+ if (defined $time)
+ {
+ $flags |= $bit;
+ $times .= pack("V", $time);
+ }
+
+ $bit <<= 1 ;
+ }
+
+ return IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_EXT_TIMESTAMP,
+ pack("C", $flags) . $times);
+}
+
+sub mkUnix2Extra
+{
+ my $ids = '';
+ for my $id (@_)
+ {
+ $ids .= pack("v", $id);
+ }
+
+ return IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_INFO_ZIP_UNIX2,
+ $ids);
+}
+
+
+# from Archive::Zip
+sub _unixToDosTime # Archive::Zip::Member
+{
+ my $time_t = shift;
+ # TODO - add something to cope with unix time < 1980
+ my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t);
+ my $dt = 0;
+ $dt += ( $sec >> 1 );
+ $dt += ( $min << 5 );
+ $dt += ( $hour << 11 );
+ $dt += ( $mday << 16 );
+ $dt += ( ( $mon + 1 ) << 21 );
+ $dt += ( ( $year - 80 ) << 25 );
+ return $dt;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Compress::Zip - Write zip files/buffers
+
+
+
+=head1 SYNOPSIS
+
+ use IO::Compress::Zip qw(zip $ZipError) ;
+
+ my $status = zip $input => $output [,OPTS]
+ or die "zip failed: $ZipError\n";
+
+ my $z = new IO::Compress::Zip $output [,OPTS]
+ or die "zip failed: $ZipError\n";
+
+ $z->print($string);
+ $z->printf($format, $string);
+ $z->write($string);
+ $z->syswrite($string [, $length, $offset]);
+ $z->flush();
+ $z->tell();
+ $z->eof();
+ $z->seek($position, $whence);
+ $z->binmode();
+ $z->fileno();
+ $z->opened();
+ $z->autoflush();
+ $z->input_line_number();
+ $z->newStream( [OPTS] );
+
+ $z->deflateParams();
+
+ $z->close() ;
+
+ $ZipError ;
+
+ # IO::File mode
+
+ print $z $string;
+ printf $z $format, $string;
+ tell $z
+ eof $z
+ seek $z, $position, $whence
+ binmode $z
+ fileno $z
+ close $z ;
+
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows writing zip
+compressed data to files or buffer.
+
+The primary purpose of this module is to provide streaming write access to
+zip files and buffers. It is not a general-purpose file archiver. If that
+is what you want, check out C<Archive::Zip>.
+
+At present three compression methods are supported by IO::Compress::Zip,
+namely Store (no compression at all), Deflate and Bzip2.
+
+Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must
+be installed.
+
+For reading zip files/buffers, see the companion module
+L<IO::Uncompress::Unzip|IO::Uncompress::Unzip>.
+
+=head1 Functional Interface
+
+A top-level function, C<zip>, is provided to carry out
+"one-shot" compression between buffers and/or files. For finer
+control over the compression process, see the L</"OO Interface">
+section.
+
+ use IO::Compress::Zip qw(zip $ZipError) ;
+
+ zip $input => $output [,OPTS]
+ or die "zip failed: $ZipError\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 zip $input => $output [, OPTS]
+
+C<zip> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the uncompressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is compressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<zip> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+In addition, if C<$input> is a simple filename, the default values for
+the C<Name>, C<Time>, C<ExtAttr> and C<exTime> options will be sourced from that file.
+
+If you do not want to use these defaults they can be overridden by
+explicitly setting the C<Name>, C<Time>, C<ExtAttr> and C<exTime> options or by setting the
+C<Minimal> parameter.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+compressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<zip> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple files/buffers and C<$output> is a single
+file/buffer the input files/buffers will each be stored
+in C<$output> as a distinct entry.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<zip>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<zip> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<zip> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeIn => 0|1 >>
+
+When reading from a file or filehandle, set C<binmode> before reading.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+The behaviour of this option is dependent on the type of output data
+stream.
+
+=over 5
+
+=item * A Buffer
+
+If C<Append> is enabled, all compressed data will be append to the end of
+the output buffer. Otherwise the output buffer will be cleared before any
+compressed data is written to it.
+
+=item * A Filename
+
+If C<Append> is enabled, the file will be opened in append mode. Otherwise
+the contents of the file, if any, will be truncated before any compressed
+data is written to it.
+
+=item * A Filehandle
+
+If C<Append> is enabled, the filehandle will be positioned to the end of
+the file via a call to C<seek> before any compressed data is
+written to it. Otherwise the file pointer will not be moved.
+
+=back
+
+When C<Append> is specified, and set to true, it will I<append> all compressed
+data to the output data stream.
+
+So when the output is a filehandle it will carry out a seek to the eof
+before writing any compressed data. If the output is a filename, it will be opened for
+appending. If the output is a buffer, all compressed data will be appened to
+the existing buffer.
+
+Conversely when C<Append> is not specified, or it is present and is set to
+false, it will operate as follows.
+
+When the output is a filename, it will truncate the contents of the file
+before writing any compressed data. If the output is a filehandle
+its position will not be changed. If the output is a buffer, it will be
+wiped before any compressed data is output.
+
+Defaults to 0.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt> and write the compressed
+data to the file C<file1.txt.zip>.
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Zip qw(zip $ZipError) ;
+
+ my $input = "file1.txt";
+ zip $input => "$input.zip"
+ or die "zip failed: $ZipError\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+compressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Zip qw(zip $ZipError) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt"
+ or die "Cannot open 'file1.txt': $!\n" ;
+ my $buffer ;
+ zip $input => \$buffer
+ or die "zip failed: $ZipError\n";
+
+To compress all files in the directory "/my/home" that match "*.txt"
+and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Zip qw(zip $ZipError) ;
+
+ zip '</my/home/*.txt>' => '<*.zip>'
+ or die "zip failed: $ZipError\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Compress::Zip qw(zip $ZipError) ;
+
+ for my $input ( glob "/my/home/*.txt" )
+ {
+ my $output = "$input.zip" ;
+ zip $input => $output
+ or die "Error compressing '$input': $ZipError\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for C<IO::Compress::Zip> is shown below
+
+ my $z = new IO::Compress::Zip $output [,OPTS]
+ or die "IO::Compress::Zip failed: $ZipError\n";
+
+It returns an C<IO::Compress::Zip> object on success and undef on failure.
+The variable C<$ZipError> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Compress::Zip can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal output file operations can be carried out
+with C<$z>.
+For example, to write to a compressed file/buffer you can use either of
+these forms
+
+ $z->print("hello world\n");
+ print $z "hello world\n";
+
+The mandatory parameter C<$output> is used to control the destination
+of the compressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed data
+will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the compressed data will be
+written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the compressed data will be stored
+in C<$$output>.
+
+=back
+
+If the C<$output> parameter is any other type, C<IO::Compress::Zip>::new will
+return undef.
+
+=head2 Constructor Options
+
+C<OPTS> is any combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$output> parameter is a filehandle. If
+specified, and the value is true, it will result in the C<$output> being
+closed once either the C<close> method is called or the C<IO::Compress::Zip>
+object is destroyed.
+
+This parameter defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+Opens C<$output> in append mode.
+
+The behaviour of this option is dependent on the type of C<$output>.
+
+=over 5
+
+=item * A Buffer
+
+If C<$output> is a buffer and C<Append> is enabled, all compressed data
+will be append to the end of C<$output>. Otherwise C<$output> will be
+cleared before any data is written to it.
+
+=item * A Filename
+
+If C<$output> is a filename and C<Append> is enabled, the file will be
+opened in append mode. Otherwise the contents of the file, if any, will be
+truncated before any compressed data is written to it.
+
+=item * A Filehandle
+
+If C<$output> is a filehandle, the file pointer will be positioned to the
+end of the file via a call to C<seek> before any compressed data is written
+to it. Otherwise the file pointer will not be moved.
+
+=back
+
+This parameter defaults to 0.
+
+=item C<< Name => $string >>
+
+Stores the contents of C<$string> in the zip filename header field. If
+C<Name> is not specified, no zip filename field will be created.
+
+=item C<< Time => $number >>
+
+Sets the last modified time field in the zip header to $number.
+
+This field defaults to the time the C<IO::Compress::Zip> object was created
+if this option is not specified.
+
+=item C<< ExtAttr => $attr >>
+
+This option controls the "external file attributes" field in the central
+header of the zip file. This is a 4 byte field.
+
+If you are running a Unix derivative this value defaults to
+
+ 0666 << 16
+
+This should allow read/write access to any files that are extracted from
+the zip file/buffer.
+
+For all other systems it defaults to 0.
+
+=item C<< exTime => [$atime, $mtime, $ctime] >>
+
+This option expects an array reference with exactly three elements:
+C<$atime>, C<mtime> and C<$ctime>. These correspond to the last access
+time, last modification time and creation time respectively.
+
+It uses these values to set the extended timestamp field (ID is "UT") in
+the local zip header using the three values, $atime, $mtime, $ctime. In
+addition it sets the extended timestamp field in the central zip header
+using C<$mtime>.
+
+If any of the three values is C<undef> that time value will not be used.
+So, for example, to set only the C<$mtime> you would use this
+
+ exTime => [undef, $mtime, undef]
+
+If the C<Minimal> option is set to true, this option will be ignored.
+
+By default no extended time field is created.
+
+=item C<< exUnix2 => [$uid, $gid] >>
+
+This option expects an array reference with exactly two elements: C<$uid>
+and C<$gid>. These values correspond to the numeric user ID and group ID
+of the owner of the files respectively.
+
+When the C<exUnix2> option is present it will trigger the creation of a
+Unix2 extra field (ID is "Ux") in the local zip. This will be populated
+with C<$uid> and C<$gid>. In addition an empty Unix2 extra field will also
+be created in the central zip header
+
+If the C<Minimal> option is set to true, this option will be ignored.
+
+By default no Unix2 extra field is created.
+
+=item C<< Comment => $comment >>
+
+Stores the contents of C<$comment> in the Central File Header of
+the zip file.
+
+By default, no comment field is written to the zip file.
+
+=item C<< ZipComment => $comment >>
+
+Stores the contents of C<$comment> in the End of Central Directory record
+of the zip file.
+
+By default, no comment field is written to the zip file.
+
+=item C<< Method => $method >>
+
+Controls which compression method is used. At present three compression
+methods are supported, namely Store (no compression at all), Deflate and
+Bzip2.
+
+The symbols, ZIP_CM_STORE, ZIP_CM_DEFLATE and ZIP_CM_BZIP2 are used to
+select the compression method.
+
+These constants are not imported by C<IO::Compress::Zip> by default.
+
+ use IO::Compress::Zip qw(:zip_method);
+ use IO::Compress::Zip qw(:constants);
+ use IO::Compress::Zip qw(:all);
+
+Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must
+be installed. A fatal error will be thrown if you attempt to create Bzip2
+content when C<IO::Compress::Bzip2> is not available.
+
+The default method is ZIP_CM_DEFLATE.
+
+=item C<< Stream => 0|1 >>
+
+This option controls whether the zip file/buffer output is created in
+streaming mode.
+
+Note that when outputting to a file with streaming mode disabled (C<Stream>
+is 0), the output file must be seekable.
+
+The default is 1.
+
+=item C<< Zip64 => 0|1 >>
+
+Create a Zip64 zip file/buffer. This option should only be used if you want
+to store files larger than 4 Gig.
+
+If you intend to manipulate the Zip64 zip files created with this module
+using an external zip/unzip make sure that it supports Zip64.
+
+In particular, if you are using Info-Zip you need to have zip version 3.x
+or better to update a Zip64 archive and unzip version 6.x to read a zip64
+archive.
+
+The default is 0.
+
+=item C<< TextFlag => 0|1 >>
+
+This parameter controls the setting of a bit in the zip central header. It
+is used to signal that the data stored in the zip file/buffer is probably
+text.
+
+The default is 0.
+
+=item C<< ExtraFieldLocal => $data >>
+=item C<< ExtraFieldCentral => $data >>
+
+The C<ExtraFieldLocal> option is used to store additional metadata in the
+local header for the zip file/buffer. The C<ExtraFieldCentral> does the
+same for the matching central header.
+
+An extra field consists of zero or more subfields. Each subfield consists
+of a two byte header followed by the subfield data.
+
+The list of subfields can be supplied in any of the following formats
+
+ ExtraFieldLocal => [$id1, $data1,
+ $id2, $data2,
+ ...
+ ]
+
+ ExtraFieldLocal => [ [$id1 => $data1],
+ [$id2 => $data2],
+ ...
+ ]
+
+ ExtraFieldLocal => { $id1 => $data1,
+ $id2 => $data2,
+ ...
+ }
+
+Where C<$id1>, C<$id2> are two byte subfield ID's.
+
+If you use the hash syntax, you have no control over the order in which
+the ExtraSubFields are stored, plus you cannot have SubFields with
+duplicate ID.
+
+Alternatively the list of subfields can by supplied as a scalar, thus
+
+ ExtraField => $rawdata
+
+The Extended Time field (ID "UT"), set using the C<exTime> option, and the
+Unix2 extra field (ID "Ux), set using the C<exUnix2> option, are examples
+of extra fields.
+
+If the C<Minimal> option is set to true, this option will be ignored.
+
+The maximum size of an extra field 65535 bytes.
+
+=item C<< Minimal => 1|0 >>
+
+If specified, this option will disable the creation of all extra fields
+in the zip local and central headers. So the C<exTime>, C<exUnix2>,
+C<ExtraFieldLocal> and C<ExtraFieldCentral> options will be ignored.
+
+This parameter defaults to 0.
+
+=item C<< BlockSize100K => number >>
+
+Specify the number of 100K blocks bzip2 uses during compression.
+
+Valid values are from 1 to 9, where 9 is best compression.
+
+This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored
+otherwise.
+
+The default is 1.
+
+=item C<< WorkFactor => number >>
+
+Specifies how much effort bzip2 should take before resorting to a slower
+fallback compression algorithm.
+
+Valid values range from 0 to 250, where 0 means use the default value 30.
+
+This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored
+otherwise.
+
+The default is 0.
+
+=item -Level
+
+Defines the compression level used by zlib. The value should either be
+a number between 0 and 9 (0 means no compression and 9 is maximum
+compression), or one of the symbolic constants defined below.
+
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+
+The default is Z_DEFAULT_COMPRESSION.
+
+Note, these constants are not imported by C<IO::Compress::Zip> by default.
+
+ use IO::Compress::Zip qw(:strategy);
+ use IO::Compress::Zip qw(:constants);
+ use IO::Compress::Zip qw(:all);
+
+=item -Strategy
+
+Defines the strategy used to tune the compression. Use one of the symbolic
+constants defined below.
+
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+
+The default is Z_DEFAULT_STRATEGY.
+
+=item C<< Strict => 0|1 >>
+
+This is a placeholder option.
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 print
+
+Usage is
+
+ $z->print($data)
+ print $z $data
+
+Compresses and outputs the contents of the C<$data> parameter. This
+has the same behaviour as the C<print> built-in.
+
+Returns true if successful.
+
+=head2 printf
+
+Usage is
+
+ $z->printf($format, $data)
+ printf $z $format, $data
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns true if successful.
+
+=head2 syswrite
+
+Usage is
+
+ $z->syswrite $data
+ $z->syswrite $data, $length
+ $z->syswrite $data, $length, $offset
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns the number of uncompressed bytes written, or C<undef> if
+unsuccessful.
+
+=head2 write
+
+Usage is
+
+ $z->write $data
+ $z->write $data, $length
+ $z->write $data, $length, $offset
+
+Compresses and outputs the contents of the C<$data> parameter.
+
+Returns the number of uncompressed bytes written, or C<undef> if
+unsuccessful.
+
+=head2 flush
+
+Usage is
+
+ $z->flush;
+ $z->flush($flush_type);
+
+Flushes any pending compressed data to the output file/buffer.
+
+This method takes an optional parameter, C<$flush_type>, that controls
+how the flushing will be carried out. By default the C<$flush_type>
+used is C<Z_FINISH>. Other valid values for C<$flush_type> are
+C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is
+strongly recommended that you only set the C<flush_type> parameter if
+you fully understand the implications of what it does - overuse of C<flush>
+can seriously degrade the level of compression achieved. See the C<zlib>
+documentation for details.
+
+Returns true on success.
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the C<close> method has been called.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the output file/buffer.
+It is a fatal error to attempt to seek backward.
+
+Empty parts of the file/buffer will have NULL (0x00) bytes written to them.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+This method always returns C<undef> when compressing.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Flushes any pending compressed data and then closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Compress::Zip object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Compress::Zip
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 newStream([OPTS])
+
+Usage is
+
+ $z->newStream( [OPTS] )
+
+Closes the current compressed data stream and starts a new one.
+
+OPTS consists of any of the the options that are available when creating
+the C<$z> object.
+
+See the L</"Constructor Options"> section for more details.
+
+=head2 deflateParams
+
+Usage is
+
+ $z->deflateParams
+
+TODO
+
+=head1 Importing
+
+A number of symbolic constants are required by some methods in
+C<IO::Compress::Zip>. None are imported by default.
+
+=over 5
+
+=item :all
+
+Imports C<zip>, C<$ZipError> and all symbolic
+constants that can be used by C<IO::Compress::Zip>. Same as doing this
+
+ use IO::Compress::Zip qw(zip $ZipError :constants) ;
+
+=item :constants
+
+Import all symbolic constants. Same as doing this
+
+ use IO::Compress::Zip qw(:flush :level :strategy :zip_method) ;
+
+=item :flush
+
+These symbolic constants are used by the C<flush> method.
+
+ Z_NO_FLUSH
+ Z_PARTIAL_FLUSH
+ Z_SYNC_FLUSH
+ Z_FULL_FLUSH
+ Z_FINISH
+ Z_BLOCK
+
+=item :level
+
+These symbolic constants are used by the C<Level> option in the constructor.
+
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+
+=item :strategy
+
+These symbolic constants are used by the C<Strategy> option in the constructor.
+
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+
+=item :zip_method
+
+These symbolic constants are used by the C<Method> option in the
+constructor.
+
+ ZIP_CM_STORE
+ ZIP_CM_DEFLATE
+ ZIP_CM_BZIP2
+
+
+
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Apache::GZip Revisited
+
+See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
+
+
+
+=head2 Working with Net::FTP
+
+See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm
new file mode 100755
index 00000000000..c8cb95342a2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Zip/Constants.pm
@@ -0,0 +1,105 @@
+package IO::Compress::Zip::Constants;
+
+use strict ;
+use warnings;
+
+require Exporter;
+
+our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS);
+
+$VERSION = '2.024';
+
+@ISA = qw(Exporter);
+
+@EXPORT= qw(
+
+ ZIP_CM_STORE
+ ZIP_CM_DEFLATE
+ ZIP_CM_BZIP2
+ ZIP_CM_LZMA
+ ZIP_CM_PPMD
+
+ ZIP_LOCAL_HDR_SIG
+ ZIP_DATA_HDR_SIG
+ ZIP_CENTRAL_HDR_SIG
+ ZIP_END_CENTRAL_HDR_SIG
+ ZIP64_END_CENTRAL_REC_HDR_SIG
+ ZIP64_END_CENTRAL_LOC_HDR_SIG
+ ZIP64_ARCHIVE_EXTRA_SIG
+ ZIP64_DIGITAL_SIGNATURE_SIG
+
+ ZIP_GP_FLAG_ENCRYPTED_MASK
+ ZIP_GP_FLAG_STREAMING_MASK
+ ZIP_GP_FLAG_PATCHED_MASK
+ ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK
+ ZIP_GP_FLAG_LZMA_EOS_PRESENT
+ ZIP_GP_FLAG_LANGUAGE_ENCODING
+
+ ZIP_EXTRA_ID_ZIP64
+ ZIP_EXTRA_ID_EXT_TIMESTAMP
+ ZIP_EXTRA_ID_INFO_ZIP_UNIX2
+ ZIP_EXTRA_ID_INFO_ZIP_UNIXn
+ ZIP_EXTRA_ID_JAVA_EXE
+
+ ZIP_OS_CODE_UNIX
+ ZIP_OS_CODE_DEFAULT
+
+ ZIP_IFA_TEXT_MASK
+
+ %ZIP_CM_MIN_VERSIONS
+ ZIP64_MIN_VERSION
+
+ );
+
+# Compression types supported
+use constant ZIP_CM_STORE => 0 ;
+use constant ZIP_CM_DEFLATE => 8 ;
+use constant ZIP_CM_BZIP2 => 12 ;
+use constant ZIP_CM_LZMA => 14 ; # Not Supported yet
+use constant ZIP_CM_PPMD => 98 ; # Not Supported yet
+
+# General Purpose Flag
+use constant ZIP_GP_FLAG_ENCRYPTED_MASK => (1 << 0) ;
+use constant ZIP_GP_FLAG_STREAMING_MASK => (1 << 3) ;
+use constant ZIP_GP_FLAG_PATCHED_MASK => (1 << 5) ;
+use constant ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK => (1 << 6) ;
+use constant ZIP_GP_FLAG_LZMA_EOS_PRESENT => (1 << 1) ;
+use constant ZIP_GP_FLAG_LANGUAGE_ENCODING => (1 << 11) ;
+
+# Internal File Attributes
+use constant ZIP_IFA_TEXT_MASK => 1;
+
+# Signatures for each of the headers
+use constant ZIP_LOCAL_HDR_SIG => 0x04034b50;
+use constant ZIP_DATA_HDR_SIG => 0x08074b50;
+use constant ZIP_CENTRAL_HDR_SIG => 0x02014b50;
+use constant ZIP_END_CENTRAL_HDR_SIG => 0x06054b50;
+use constant ZIP64_END_CENTRAL_REC_HDR_SIG => 0x06064b50;
+use constant ZIP64_END_CENTRAL_LOC_HDR_SIG => 0x07064b50;
+use constant ZIP64_ARCHIVE_EXTRA_SIG => 0x08064b50;
+use constant ZIP64_DIGITAL_SIGNATURE_SIG => 0x05054b50;
+
+use constant ZIP_OS_CODE_UNIX => 3;
+use constant ZIP_OS_CODE_DEFAULT => 3;
+
+# Extra Field ID's
+use constant ZIP_EXTRA_ID_ZIP64 => pack "v", 1;
+use constant ZIP_EXTRA_ID_EXT_TIMESTAMP => "UT";
+use constant ZIP_EXTRA_ID_INFO_ZIP_UNIX2 => "Ux";
+use constant ZIP_EXTRA_ID_INFO_ZIP_UNIXn => "ux";
+use constant ZIP_EXTRA_ID_JAVA_EXE => pack "v", 0xCAFE;
+
+use constant ZIP64_MIN_VERSION => 45;
+
+%ZIP_CM_MIN_VERSIONS = (
+ ZIP_CM_STORE() => 20,
+ ZIP_CM_DEFLATE() => 20,
+ ZIP_CM_BZIP2() => 46,
+ ZIP_CM_LZMA() => 63,
+ );
+
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Constants.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Constants.pm
new file mode 100755
index 00000000000..10fcf345f63
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Constants.pm
@@ -0,0 +1,77 @@
+
+package IO::Compress::Zlib::Constants ;
+
+use strict ;
+use warnings;
+use bytes;
+
+require Exporter;
+
+our ($VERSION, @ISA, @EXPORT);
+
+$VERSION = '2.024';
+
+@ISA = qw(Exporter);
+
+@EXPORT= qw(
+
+ ZLIB_HEADER_SIZE
+ ZLIB_TRAILER_SIZE
+
+ ZLIB_CMF_CM_OFFSET
+ ZLIB_CMF_CM_BITS
+ ZLIB_CMF_CM_DEFLATED
+
+ ZLIB_CMF_CINFO_OFFSET
+ ZLIB_CMF_CINFO_BITS
+ ZLIB_CMF_CINFO_MAX
+
+ ZLIB_FLG_FCHECK_OFFSET
+ ZLIB_FLG_FCHECK_BITS
+
+ ZLIB_FLG_FDICT_OFFSET
+ ZLIB_FLG_FDICT_BITS
+
+ ZLIB_FLG_LEVEL_OFFSET
+ ZLIB_FLG_LEVEL_BITS
+
+ ZLIB_FLG_LEVEL_FASTEST
+ ZLIB_FLG_LEVEL_FAST
+ ZLIB_FLG_LEVEL_DEFAULT
+ ZLIB_FLG_LEVEL_SLOWEST
+
+ ZLIB_FDICT_SIZE
+
+ );
+
+# Constant names derived from RFC1950
+
+use constant ZLIB_HEADER_SIZE => 2;
+use constant ZLIB_TRAILER_SIZE => 4;
+
+use constant ZLIB_CMF_CM_OFFSET => 0;
+use constant ZLIB_CMF_CM_BITS => 0xF ; # 0b1111
+use constant ZLIB_CMF_CM_DEFLATED => 8;
+
+use constant ZLIB_CMF_CINFO_OFFSET => 4;
+use constant ZLIB_CMF_CINFO_BITS => 0xF ; # 0b1111;
+use constant ZLIB_CMF_CINFO_MAX => 7;
+
+use constant ZLIB_FLG_FCHECK_OFFSET => 0;
+use constant ZLIB_FLG_FCHECK_BITS => 0x1F ; # 0b11111;
+
+use constant ZLIB_FLG_FDICT_OFFSET => 5;
+use constant ZLIB_FLG_FDICT_BITS => 0x1 ; # 0b1;
+
+use constant ZLIB_FLG_LEVEL_OFFSET => 6;
+use constant ZLIB_FLG_LEVEL_BITS => 0x3 ; # 0b11;
+
+use constant ZLIB_FLG_LEVEL_FASTEST => 0;
+use constant ZLIB_FLG_LEVEL_FAST => 1;
+use constant ZLIB_FLG_LEVEL_DEFAULT => 2;
+use constant ZLIB_FLG_LEVEL_SLOWEST => 3;
+
+use constant ZLIB_FDICT_SIZE => 4;
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm b/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm
new file mode 100755
index 00000000000..6812bb409dc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm
@@ -0,0 +1,198 @@
+package IO::Compress::Zlib::Extra;
+
+require 5.004 ;
+
+use strict ;
+use warnings;
+use bytes;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS);
+
+$VERSION = '2.024';
+
+use IO::Compress::Gzip::Constants 2.024 ;
+
+sub ExtraFieldError
+{
+ return $_[0];
+ return "Error with ExtraField Parameter: $_[0]" ;
+}
+
+sub validateExtraFieldPair
+{
+ my $pair = shift ;
+ my $strict = shift;
+ my $gzipMode = shift ;
+
+ return ExtraFieldError("Not an array ref")
+ unless ref $pair && ref $pair eq 'ARRAY';
+
+ return ExtraFieldError("SubField must have two parts")
+ unless @$pair == 2 ;
+
+ return ExtraFieldError("SubField ID is a reference")
+ if ref $pair->[0] ;
+
+ return ExtraFieldError("SubField Data is a reference")
+ if ref $pair->[1] ;
+
+ # ID is exactly two chars
+ return ExtraFieldError("SubField ID not two chars long")
+ unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ;
+
+ # Check that the 2nd byte of the ID isn't 0
+ return ExtraFieldError("SubField ID 2nd byte is 0x00")
+ if $strict && $gzipMode && substr($pair->[0], 1, 1) eq "\x00" ;
+
+ return ExtraFieldError("SubField Data too long")
+ if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ;
+
+
+ return undef ;
+}
+
+sub parseRawExtra
+{
+ my $data = shift ;
+ my $extraRef = shift;
+ my $strict = shift;
+ my $gzipMode = shift ;
+
+ #my $lax = shift ;
+
+ #return undef
+ # if $lax ;
+
+ my $XLEN = length $data ;
+
+ return ExtraFieldError("Too Large")
+ if $XLEN > GZIP_FEXTRA_MAX_SIZE;
+
+ my $offset = 0 ;
+ while ($offset < $XLEN) {
+
+ return ExtraFieldError("Truncated in FEXTRA Body Section")
+ if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ;
+
+ my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
+ $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE;
+
+ my $subLen = unpack("v", substr($data, $offset,
+ GZIP_FEXTRA_SUBFIELD_LEN_SIZE));
+ $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ;
+
+ return ExtraFieldError("Truncated in FEXTRA Body Section")
+ if $offset + $subLen > $XLEN ;
+
+ my $bad = validateExtraFieldPair( [$id,
+ substr($data, $offset, $subLen)],
+ $strict, $gzipMode );
+ return $bad if $bad ;
+ push @$extraRef, [$id => substr($data, $offset, $subLen)]
+ if defined $extraRef;;
+
+ $offset += $subLen ;
+ }
+
+
+ return undef ;
+}
+
+
+sub mkSubField
+{
+ my $id = shift ;
+ my $data = shift ;
+
+ return $id . pack("v", length $data) . $data ;
+}
+
+sub parseExtraField
+{
+ my $dataRef = $_[0];
+ my $strict = $_[1];
+ my $gzipMode = $_[2];
+ #my $lax = @_ == 2 ? $_[1] : 1;
+
+
+ # ExtraField can be any of
+ #
+ # -ExtraField => $data
+ #
+ # -ExtraField => [$id1, $data1,
+ # $id2, $data2]
+ # ...
+ # ]
+ #
+ # -ExtraField => [ [$id1 => $data1],
+ # [$id2 => $data2],
+ # ...
+ # ]
+ #
+ # -ExtraField => { $id1 => $data1,
+ # $id2 => $data2,
+ # ...
+ # }
+
+ if ( ! ref $dataRef ) {
+
+ return undef
+ if ! $strict;
+
+ return parseRawExtra($dataRef, undef, 1, $gzipMode);
+ }
+
+ #my $data = $$dataRef;
+ my $data = $dataRef;
+ my $out = '' ;
+
+ if (ref $data eq 'ARRAY') {
+ if (ref $data->[0]) {
+
+ foreach my $pair (@$data) {
+ return ExtraFieldError("Not list of lists")
+ unless ref $pair eq 'ARRAY' ;
+
+ my $bad = validateExtraFieldPair($pair, $strict, $gzipMode) ;
+ return $bad if $bad ;
+
+ $out .= mkSubField(@$pair);
+ }
+ }
+ else {
+ return ExtraFieldError("Not even number of elements")
+ unless @$data % 2 == 0;
+
+ for (my $ix = 0; $ix <= length(@$data) -1 ; $ix += 2) {
+ my $bad = validateExtraFieldPair([$data->[$ix],
+ $data->[$ix+1]],
+ $strict, $gzipMode) ;
+ return $bad if $bad ;
+
+ $out .= mkSubField($data->[$ix], $data->[$ix+1]);
+ }
+ }
+ }
+ elsif (ref $data eq 'HASH') {
+ while (my ($id, $info) = each %$data) {
+ my $bad = validateExtraFieldPair([$id, $info], $strict, $gzipMode);
+ return $bad if $bad ;
+
+ $out .= mkSubField($id, $info);
+ }
+ }
+ else {
+ return ExtraFieldError("Not a scalar, array ref or hash ref") ;
+ }
+
+ return ExtraFieldError("Too Large")
+ if length $out > GZIP_FEXTRA_MAX_SIZE;
+
+ $_[0] = $out ;
+
+ return undef;
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl/lib/IO/Dir.pm b/Master/tlpkg/tlperl/lib/IO/Dir.pm
new file mode 100755
index 00000000000..cce392c2ce3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Dir.pm
@@ -0,0 +1,248 @@
+# IO::Dir.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Dir;
+
+use 5.006;
+
+use strict;
+use Carp;
+use Symbol;
+use Exporter;
+use IO::File;
+our(@ISA, $VERSION, @EXPORT_OK);
+use Tie::Hash;
+use File::stat;
+use File::Spec;
+
+@ISA = qw(Tie::Hash Exporter);
+$VERSION = "1.07";
+$VERSION = eval $VERSION;
+@EXPORT_OK = qw(DIR_UNLINK);
+
+sub DIR_UNLINK () { 1 }
+
+sub new {
+ @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]';
+ my $class = shift;
+ my $dh = gensym;
+ if (@_) {
+ IO::Dir::open($dh, $_[0])
+ or return undef;
+ }
+ bless $dh, $class;
+}
+
+sub DESTROY {
+ my ($dh) = @_;
+ local($., $@, $!, $^E, $?);
+ no warnings 'io';
+ closedir($dh);
+}
+
+sub open {
+ @_ == 2 or croak 'usage: $dh->open(DIRNAME)';
+ my ($dh, $dirname) = @_;
+ return undef
+ unless opendir($dh, $dirname);
+ # a dir name should always have a ":" in it; assume dirname is
+ # in current directory
+ $dirname = ':' . $dirname if ( ($^O eq 'MacOS') && ($dirname !~ /:/) );
+ ${*$dh}{io_dir_path} = $dirname;
+ 1;
+}
+
+sub close {
+ @_ == 1 or croak 'usage: $dh->close()';
+ my ($dh) = @_;
+ closedir($dh);
+}
+
+sub read {
+ @_ == 1 or croak 'usage: $dh->read()';
+ my ($dh) = @_;
+ readdir($dh);
+}
+
+sub seek {
+ @_ == 2 or croak 'usage: $dh->seek(POS)';
+ my ($dh,$pos) = @_;
+ seekdir($dh,$pos);
+}
+
+sub tell {
+ @_ == 1 or croak 'usage: $dh->tell()';
+ my ($dh) = @_;
+ telldir($dh);
+}
+
+sub rewind {
+ @_ == 1 or croak 'usage: $dh->rewind()';
+ my ($dh) = @_;
+ rewinddir($dh);
+}
+
+sub TIEHASH {
+ my($class,$dir,$options) = @_;
+
+ my $dh = $class->new($dir)
+ or return undef;
+
+ $options ||= 0;
+
+ ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK;
+ $dh;
+}
+
+sub FIRSTKEY {
+ my($dh) = @_;
+ $dh->rewind;
+ scalar $dh->read;
+}
+
+sub NEXTKEY {
+ my($dh) = @_;
+ scalar $dh->read;
+}
+
+sub EXISTS {
+ my($dh,$key) = @_;
+ -e File::Spec->catfile(${*$dh}{io_dir_path}, $key);
+}
+
+sub FETCH {
+ my($dh,$key) = @_;
+ &lstat(File::Spec->catfile(${*$dh}{io_dir_path}, $key));
+}
+
+sub STORE {
+ my($dh,$key,$data) = @_;
+ my($atime,$mtime) = ref($data) ? @$data : ($data,$data);
+ my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
+ unless(-e $file) {
+ my $io = IO::File->new($file,O_CREAT | O_RDWR);
+ $io->close if $io;
+ }
+ utime($atime,$mtime, $file);
+}
+
+sub DELETE {
+ my($dh,$key) = @_;
+
+ # Only unlink if unlink-ing is enabled
+ return 0
+ unless ${*$dh}{io_dir_unlink};
+
+ my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
+
+ -d $file
+ ? rmdir($file)
+ : unlink($file);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Dir - supply object methods for directory handles
+
+=head1 SYNOPSIS
+
+ use IO::Dir;
+ $d = IO::Dir->new(".");
+ if (defined $d) {
+ while (defined($_ = $d->read)) { something($_); }
+ $d->rewind;
+ while (defined($_ = $d->read)) { something_else($_); }
+ undef $d;
+ }
+
+ tie %dir, 'IO::Dir', ".";
+ foreach (keys %dir) {
+ print $_, " " , $dir{$_}->size,"\n";
+ }
+
+=head1 DESCRIPTION
+
+The C<IO::Dir> package provides two interfaces to perl's directory reading
+routines.
+
+The first interface is an object approach. C<IO::Dir> provides an object
+constructor and methods, which are just wrappers around perl's built in
+directory reading routines.
+
+=over 4
+
+=item new ( [ DIRNAME ] )
+
+C<new> is the constructor for C<IO::Dir> objects. It accepts one optional
+argument which, if given, C<new> will pass to C<open>
+
+=back
+
+The following methods are wrappers for the directory related functions built
+into perl (the trailing `dir' has been removed from the names). See L<perlfunc>
+for details of these functions.
+
+=over 4
+
+=item open ( DIRNAME )
+
+=item read ()
+
+=item seek ( POS )
+
+=item tell ()
+
+=item rewind ()
+
+=item close ()
+
+=back
+
+C<IO::Dir> also provides an interface to reading directories via a tied
+hash. The tied hash extends the interface beyond just the directory
+reading routines by the use of C<lstat>, from the C<File::stat> package,
+C<unlink>, C<rmdir> and C<utime>.
+
+=over 4
+
+=item tie %hash, 'IO::Dir', DIRNAME [, OPTIONS ]
+
+=back
+
+The keys of the hash will be the names of the entries in the directory.
+Reading a value from the hash will be the result of calling
+C<File::stat::lstat>. Deleting an element from the hash will
+delete the corresponding file or subdirectory,
+provided that C<DIR_UNLINK> is included in the C<OPTIONS>.
+
+Assigning to an entry in the hash will cause the time stamps of the file
+to be modified. If the file does not exist then it will be created. Assigning
+a single integer to a hash element will cause both the access and
+modification times to be changed to that value. Alternatively a reference to
+an array of two values can be passed. The first array element will be used to
+set the access time and the second element will be used to set the modification
+time.
+
+=head1 SEE ALSO
+
+L<File::stat>
+
+=head1 AUTHOR
+
+Graham Barr. Currently maintained by the Perl Porters. Please report all
+bugs to <perl5-porters@perl.org>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2003 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/IO/File.pm b/Master/tlpkg/tlperl/lib/IO/File.pm
new file mode 100755
index 00000000000..d33d090d0b2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/File.pm
@@ -0,0 +1,204 @@
+#
+
+package IO::File;
+
+=head1 NAME
+
+IO::File - supply object methods for filehandles
+
+=head1 SYNOPSIS
+
+ use IO::File;
+
+ $fh = new IO::File;
+ if ($fh->open("< file")) {
+ print <$fh>;
+ $fh->close;
+ }
+
+ $fh = new IO::File "> file";
+ if (defined $fh) {
+ print $fh "bar\n";
+ $fh->close;
+ }
+
+ $fh = new IO::File "file", "r";
+ if (defined $fh) {
+ print <$fh>;
+ undef $fh; # automatically closes the file
+ }
+
+ $fh = new IO::File "file", O_WRONLY|O_APPEND;
+ if (defined $fh) {
+ print $fh "corge\n";
+
+ $pos = $fh->getpos;
+ $fh->setpos($pos);
+
+ undef $fh; # automatically closes the file
+ }
+
+ autoflush STDOUT 1;
+
+=head1 DESCRIPTION
+
+C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends
+these classes with methods that are specific to file handles.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( FILENAME [,MODE [,PERMS]] )
+
+Creates an C<IO::File>. If it receives any parameters, they are passed to
+the method C<open>; if the open fails, the object is destroyed. Otherwise,
+it is returned to the caller.
+
+=item new_tmpfile
+
+Creates an C<IO::File> opened for read/write on a newly created temporary
+file. On systems where this is possible, the temporary file is anonymous
+(i.e. it is unlinked after creation, but held open). If the temporary
+file cannot be created or opened, the C<IO::File> object is destroyed.
+Otherwise, it is returned to the caller.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item open( FILENAME [,MODE [,PERMS]] )
+
+=item open( FILENAME, IOLAYERS )
+
+C<open> accepts one, two or three parameters. With one parameter,
+it is just a front end for the built-in C<open> function. With two or three
+parameters, the first parameter is a filename that may include
+whitespace or other special characters, and the second parameter is
+the open mode, optionally followed by a file permission value.
+
+If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.)
+or an ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic
+Perl C<open> operator (but protects any special characters).
+
+If C<IO::File::open> is given a numeric mode, it passes that mode
+and the optional permissions value to the Perl C<sysopen> operator.
+The permissions default to 0666.
+
+If C<IO::File::open> is given a mode that includes the C<:> character,
+it passes all the three arguments to the three-argument C<open> operator.
+
+For convenience, C<IO::File> exports the O_XXX constants from the
+Fcntl module, if this module is available.
+
+=item binmode( [LAYER] )
+
+C<binmode> sets C<binmode> on the underlying C<IO> object, as documented
+in C<perldoc -f binmode>.
+
+C<binmode> accepts one optional parameter, which is the layer to be
+passed on to the C<binmode> call.
+
+=back
+
+=head1 NOTE
+
+Some operating systems may perform C<IO::File::new()> or C<IO::File::open()>
+on a directory without errors. This behavior is not portable and not
+suggested for use. Using C<opendir()> and C<readdir()> or C<IO::Dir> are
+suggested instead.
+
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<IO::Handle>,
+L<IO::Seekable>,
+L<IO::Dir>
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
+
+=cut
+
+use 5.006_001;
+use strict;
+our($VERSION, @EXPORT, @EXPORT_OK, @ISA);
+use Carp;
+use Symbol;
+use SelectSaver;
+use IO::Seekable;
+use File::Spec;
+
+require Exporter;
+
+@ISA = qw(IO::Handle IO::Seekable Exporter);
+
+$VERSION = "1.14";
+
+@EXPORT = @IO::Seekable::EXPORT;
+
+eval {
+ # Make all Fcntl O_XXX constants available for importing
+ require Fcntl;
+ my @O = grep /^O_/, @Fcntl::EXPORT;
+ Fcntl->import(@O); # first we import what we want to export
+ push(@EXPORT, @O);
+};
+
+################################################
+## Constructor
+##
+
+sub new {
+ my $type = shift;
+ my $class = ref($type) || $type || "IO::File";
+ @_ >= 0 && @_ <= 3
+ or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]";
+ my $fh = $class->SUPER::new();
+ if (@_) {
+ $fh->open(@_)
+ or return undef;
+ }
+ $fh;
+}
+
+################################################
+## Open
+##
+
+sub open {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
+ my ($fh, $file) = @_;
+ if (@_ > 2) {
+ my ($mode, $perms) = @_[2, 3];
+ if ($mode =~ /^\d+$/) {
+ defined $perms or $perms = 0666;
+ return sysopen($fh, $file, $mode, $perms);
+ } elsif ($mode =~ /:/) {
+ return open($fh, $mode, $file) if @_ == 3;
+ croak 'usage: $fh->open(FILENAME, IOLAYERS)';
+ } else {
+ return open($fh, IO::Handle::_open_mode_string($mode), $file);
+ }
+ }
+ open($fh, $file);
+}
+
+################################################
+## Binmode
+##
+
+sub binmode {
+ ( @_ == 1 or @_ == 2 ) or croak 'usage $fh->binmode([LAYER])';
+
+ my($fh, $layer) = @_;
+
+ return binmode $$fh unless $layer;
+ return binmode $$fh, $layer;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/IO/Handle.pm b/Master/tlpkg/tlperl/lib/IO/Handle.pm
new file mode 100755
index 00000000000..2f1f1b423bc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Handle.pm
@@ -0,0 +1,635 @@
+package IO::Handle;
+
+=head1 NAME
+
+IO::Handle - supply object methods for I/O handles
+
+=head1 SYNOPSIS
+
+ use IO::Handle;
+
+ $io = new IO::Handle;
+ if ($io->fdopen(fileno(STDIN),"r")) {
+ print $io->getline;
+ $io->close;
+ }
+
+ $io = new IO::Handle;
+ if ($io->fdopen(fileno(STDOUT),"w")) {
+ $io->print("Some text\n");
+ }
+
+ # setvbuf is not available by default on Perls 5.8.0 and later.
+ use IO::Handle '_IOLBF';
+ $io->setvbuf($buffer_var, _IOLBF, 1024);
+
+ undef $io; # automatically closes the file if it's open
+
+ autoflush STDOUT 1;
+
+=head1 DESCRIPTION
+
+C<IO::Handle> is the base class for all other IO handle classes. It is
+not intended that objects of C<IO::Handle> would be created directly,
+but instead C<IO::Handle> is inherited from by several other classes
+in the IO hierarchy.
+
+If you are reading this documentation, looking for a replacement for
+the C<FileHandle> package, then I suggest you read the documentation
+for C<IO::File> too.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ()
+
+Creates a new C<IO::Handle> object.
+
+=item new_from_fd ( FD, MODE )
+
+Creates an C<IO::Handle> like C<new> does.
+It requires two parameters, which are passed to the method C<fdopen>;
+if the fdopen fails, the object is destroyed. Otherwise, it is returned
+to the caller.
+
+=back
+
+=head1 METHODS
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Handle> methods, which are just front ends for the
+corresponding built-in functions:
+
+ $io->close
+ $io->eof
+ $io->fcntl( FUNCTION, SCALAR )
+ $io->fileno
+ $io->format_write( [FORMAT_NAME] )
+ $io->getc
+ $io->ioctl( FUNCTION, SCALAR )
+ $io->read ( BUF, LEN, [OFFSET] )
+ $io->print ( ARGS )
+ $io->printf ( FMT, [ARGS] )
+ $io->say ( ARGS )
+ $io->stat
+ $io->sysread ( BUF, LEN, [OFFSET] )
+ $io->syswrite ( BUF, [LEN, [OFFSET]] )
+ $io->truncate ( LEN )
+
+See L<perlvar> for complete descriptions of each of the following
+supported C<IO::Handle> methods. All of them return the previous
+value of the attribute and takes an optional single argument that when
+given will set the value. If no argument is given the previous value
+is unchanged (except for $io->autoflush will actually turn ON
+autoflush by default).
+
+ $io->autoflush ( [BOOL] ) $|
+ $io->format_page_number( [NUM] ) $%
+ $io->format_lines_per_page( [NUM] ) $=
+ $io->format_lines_left( [NUM] ) $-
+ $io->format_name( [STR] ) $~
+ $io->format_top_name( [STR] ) $^
+ $io->input_line_number( [NUM]) $.
+
+The following methods are not supported on a per-filehandle basis.
+
+ IO::Handle->format_line_break_characters( [STR] ) $:
+ IO::Handle->format_formfeed( [STR]) $^L
+ IO::Handle->output_field_separator( [STR] ) $,
+ IO::Handle->output_record_separator( [STR] ) $\
+
+ IO::Handle->input_record_separator( [STR] ) $/
+
+Furthermore, for doing normal I/O you might need these:
+
+=over 4
+
+=item $io->fdopen ( FD, MODE )
+
+C<fdopen> is like an ordinary C<open> except that its first parameter
+is not a filename but rather a file handle name, an IO::Handle object,
+or a file descriptor number. (For the documentation of the C<open>
+method, see L<IO::File>.)
+
+=item $io->opened
+
+Returns true if the object is currently a valid file descriptor, false
+otherwise.
+
+=item $io->getline
+
+This works like <$io> described in L<perlop/"I/O Operators">
+except that it's more readable and can be safely called in a
+list context but still returns just one line. If used as the conditional
++within a C<while> or C-style C<for> loop, however, you will need to
++emulate the functionality of <$io> with C<< defined($_ = $io->getline) >>.
+
+=item $io->getlines
+
+This works like <$io> when called in a list context to read all
+the remaining lines in a file, except that it's more readable.
+It will also croak() if accidentally called in a scalar context.
+
+=item $io->ungetc ( ORD )
+
+Pushes a character with the given ordinal value back onto the given
+handle's input stream. Only one character of pushback per handle is
+guaranteed.
+
+=item $io->write ( BUF, LEN [, OFFSET ] )
+
+This C<write> is like C<write> found in C, that is it is the
+opposite of read. The wrapper for the perl C<write> function is
+called C<format_write>.
+
+=item $io->error
+
+Returns a true value if the given handle has experienced any errors
+since it was opened or since the last call to C<clearerr>, or if the
+handle is invalid. It only returns false for a valid handle with no
+outstanding errors.
+
+=item $io->clearerr
+
+Clear the given handle's error indicator. Returns -1 if the handle is
+invalid, 0 otherwise.
+
+=item $io->sync
+
+C<sync> synchronizes a file's in-memory state with that on the
+physical medium. C<sync> does not operate at the perlio api level, but
+operates on the file descriptor (similar to sysread, sysseek and
+systell). This means that any data held at the perlio api level will not
+be synchronized. To synchronize data that is buffered at the perlio api
+level you must use the flush method. C<sync> is not implemented on all
+platforms. Returns "0 but true" on success, C<undef> on error, C<undef>
+for an invalid handle. See L<fsync(3c)>.
+
+=item $io->flush
+
+C<flush> causes perl to flush any buffered data at the perlio api level.
+Any unread data in the buffer will be discarded, and any unwritten data
+will be written to the underlying file descriptor. Returns "0 but true"
+on success, C<undef> on error.
+
+=item $io->printflush ( ARGS )
+
+Turns on autoflush, print ARGS and then restores the autoflush status of the
+C<IO::Handle> object. Returns the return value from print.
+
+=item $io->blocking ( [ BOOL ] )
+
+If called with an argument C<blocking> will turn on non-blocking IO if
+C<BOOL> is false, and turn it off if C<BOOL> is true.
+
+C<blocking> will return the value of the previous setting, or the
+current setting if C<BOOL> is not given.
+
+If an error occurs C<blocking> will return undef and C<$!> will be set.
+
+=back
+
+
+If the C functions setbuf() and/or setvbuf() are available, then
+C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
+policy for an IO::Handle. The calling sequences for the Perl functions
+are the same as their C counterparts--including the constants C<_IOFBF>,
+C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
+specifies a scalar variable to use as a buffer. You should only
+change the buffer before any I/O, or immediately after calling flush.
+
+WARNING: The IO::Handle::setvbuf() is not available by default on
+Perls 5.8.0 and later because setvbuf() is rather specific to using
+the stdio library, while Perl prefers the new perlio subsystem instead.
+
+WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not
+be modified> in any way until the IO::Handle is closed or C<setbuf> or
+C<setvbuf> is called again, or memory corruption may result! Remember that
+the order of global destruction is undefined, so even if your buffer
+variable remains in scope until program termination, it may be undefined
+before the file IO::Handle is closed. Note that you need to import the
+constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf
+returns nothing. setvbuf returns "0 but true", on success, C<undef> on
+failure.
+
+Lastly, there is a special method for working under B<-T> and setuid/gid
+scripts:
+
+=over 4
+
+=item $io->untaint
+
+Marks the object as taint-clean, and as such data read from it will also
+be considered taint-clean. Note that this is a very trusting action to
+take, and appropriate consideration for the data source and potential
+vulnerability should be kept in mind. Returns 0 on success, -1 if setting
+the taint-clean flag failed. (eg invalid handle)
+
+=back
+
+=head1 NOTE
+
+An C<IO::Handle> object is a reference to a symbol/GLOB reference (see
+the C<Symbol> package). Some modules that
+inherit from C<IO::Handle> may want to keep object related variables
+in the hash table part of the GLOB. In an attempt to prevent modules
+trampling on each other I propose the that any such module should prefix
+its variables with its own name separated by _'s. For example the IO::Socket
+module keeps a C<timeout> variable in 'io_socket_timeout'.
+
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<IO::File>
+
+=head1 BUGS
+
+Due to backwards compatibility, all filehandles resemble objects
+of class C<IO::Handle>, or actually classes derived from that class.
+They actually aren't. Which means you can't derive your own
+class from C<IO::Handle> and inherit those methods.
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+=cut
+
+use 5.006_001;
+use strict;
+our($VERSION, @EXPORT_OK, @ISA);
+use Carp;
+use Symbol;
+use SelectSaver;
+use IO (); # Load the XS module
+
+require Exporter;
+@ISA = qw(Exporter);
+
+$VERSION = "1.28";
+$VERSION = eval $VERSION;
+
+@EXPORT_OK = qw(
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+ format_write
+
+ print
+ printf
+ say
+ getline
+ getlines
+
+ printflush
+ flush
+
+ SEEK_SET
+ SEEK_CUR
+ SEEK_END
+ _IOFBF
+ _IOLBF
+ _IONBF
+);
+
+################################################
+## Constructors, destructors.
+##
+
+sub new {
+ my $class = ref($_[0]) || $_[0] || "IO::Handle";
+ @_ == 1 or croak "usage: new $class";
+ my $io = gensym;
+ bless $io, $class;
+}
+
+sub new_from_fd {
+ my $class = ref($_[0]) || $_[0] || "IO::Handle";
+ @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
+ my $io = gensym;
+ shift;
+ IO::Handle::fdopen($io, @_)
+ or return undef;
+ bless $io, $class;
+}
+
+#
+# There is no need for DESTROY to do anything, because when the
+# last reference to an IO object is gone, Perl automatically
+# closes its associated files (if any). However, to avoid any
+# attempts to autoload DESTROY, we here define it to do nothing.
+#
+sub DESTROY {}
+
+
+################################################
+## Open and close.
+##
+
+sub _open_mode_string {
+ my ($mode) = @_;
+ $mode =~ /^\+?(<|>>?)$/
+ or $mode =~ s/^r(\+?)$/$1</
+ or $mode =~ s/^w(\+?)$/$1>/
+ or $mode =~ s/^a(\+?)$/$1>>/
+ or croak "IO::Handle: bad open mode: $mode";
+ $mode;
+}
+
+sub fdopen {
+ @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
+ my ($io, $fd, $mode) = @_;
+ local(*GLOB);
+
+ if (ref($fd) && "".$fd =~ /GLOB\(/o) {
+ # It's a glob reference; Alias it as we cannot get name of anon GLOBs
+ my $n = qualify(*GLOB);
+ *GLOB = *{*$fd};
+ $fd = $n;
+ } elsif ($fd =~ m#^\d+$#) {
+ # It's an FD number; prefix with "=".
+ $fd = "=$fd";
+ }
+
+ open($io, _open_mode_string($mode) . '&' . $fd)
+ ? $io : undef;
+}
+
+sub close {
+ @_ == 1 or croak 'usage: $io->close()';
+ my($io) = @_;
+
+ close($io);
+}
+
+################################################
+## Normal I/O functions.
+##
+
+# flock
+# select
+
+sub opened {
+ @_ == 1 or croak 'usage: $io->opened()';
+ defined fileno($_[0]);
+}
+
+sub fileno {
+ @_ == 1 or croak 'usage: $io->fileno()';
+ fileno($_[0]);
+}
+
+sub getc {
+ @_ == 1 or croak 'usage: $io->getc()';
+ getc($_[0]);
+}
+
+sub eof {
+ @_ == 1 or croak 'usage: $io->eof()';
+ eof($_[0]);
+}
+
+sub print {
+ @_ or croak 'usage: $io->print(ARGS)';
+ my $this = shift;
+ print $this @_;
+}
+
+sub printf {
+ @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
+ my $this = shift;
+ printf $this @_;
+}
+
+sub say {
+ @_ or croak 'usage: $io->say(ARGS)';
+ my $this = shift;
+ local $\ = "\n";
+ print $this @_;
+}
+
+sub getline {
+ @_ == 1 or croak 'usage: $io->getline()';
+ my $this = shift;
+ return scalar <$this>;
+}
+
+*gets = \&getline; # deprecated
+
+sub getlines {
+ @_ == 1 or croak 'usage: $io->getlines()';
+ wantarray or
+ croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
+ my $this = shift;
+ return <$this>;
+}
+
+sub truncate {
+ @_ == 2 or croak 'usage: $io->truncate(LEN)';
+ truncate($_[0], $_[1]);
+}
+
+sub read {
+ @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
+ read($_[0], $_[1], $_[2], $_[3] || 0);
+}
+
+sub sysread {
+ @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
+ sysread($_[0], $_[1], $_[2], $_[3] || 0);
+}
+
+sub write {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
+ local($\) = "";
+ $_[2] = length($_[1]) unless defined $_[2];
+ print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
+}
+
+sub syswrite {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
+ if (defined($_[2])) {
+ syswrite($_[0], $_[1], $_[2], $_[3] || 0);
+ } else {
+ syswrite($_[0], $_[1]);
+ }
+}
+
+sub stat {
+ @_ == 1 or croak 'usage: $io->stat()';
+ stat($_[0]);
+}
+
+################################################
+## State modification functions.
+##
+
+sub autoflush {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $|;
+ $| = @_ > 1 ? $_[1] : 1;
+ $prev;
+}
+
+sub output_field_separator {
+ carp "output_field_separator is not supported on a per-handle basis"
+ if ref($_[0]);
+ my $prev = $,;
+ $, = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub output_record_separator {
+ carp "output_record_separator is not supported on a per-handle basis"
+ if ref($_[0]);
+ my $prev = $\;
+ $\ = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub input_record_separator {
+ carp "input_record_separator is not supported on a per-handle basis"
+ if ref($_[0]);
+ my $prev = $/;
+ $/ = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub input_line_number {
+ local $.;
+ () = tell qualify($_[0], caller) if ref($_[0]);
+ my $prev = $.;
+ $. = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_page_number {
+ my $old;
+ $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $%;
+ $% = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_lines_per_page {
+ my $old;
+ $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $=;
+ $= = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_lines_left {
+ my $old;
+ $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $-;
+ $- = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_name {
+ my $old;
+ $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $~;
+ $~ = qualify($_[1], caller) if @_ > 1;
+ $prev;
+}
+
+sub format_top_name {
+ my $old;
+ $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $^;
+ $^ = qualify($_[1], caller) if @_ > 1;
+ $prev;
+}
+
+sub format_line_break_characters {
+ carp "format_line_break_characters is not supported on a per-handle basis"
+ if ref($_[0]);
+ my $prev = $:;
+ $: = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_formfeed {
+ carp "format_formfeed is not supported on a per-handle basis"
+ if ref($_[0]);
+ my $prev = $^L;
+ $^L = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub formline {
+ my $io = shift;
+ my $picture = shift;
+ local($^A) = $^A;
+ local($\) = "";
+ formline($picture, @_);
+ print $io $^A;
+}
+
+sub format_write {
+ @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
+ if (@_ == 2) {
+ my ($io, $fmt) = @_;
+ my $oldfmt = $io->format_name(qualify($fmt,caller));
+ CORE::write($io);
+ $io->format_name($oldfmt);
+ } else {
+ CORE::write($_[0]);
+ }
+}
+
+sub fcntl {
+ @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
+ my ($io, $op) = @_;
+ return fcntl($io, $op, $_[2]);
+}
+
+sub ioctl {
+ @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
+ my ($io, $op) = @_;
+ return ioctl($io, $op, $_[2]);
+}
+
+# this sub is for compatability with older releases of IO that used
+# a sub called constant to detemine if a constant existed -- GMB
+#
+# The SEEK_* and _IO?BF constants were the only constants at that time
+# any new code should just chech defined(&CONSTANT_NAME)
+
+sub constant {
+ no strict 'refs';
+ my $name = shift;
+ (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
+ ? &{$name}() : undef;
+}
+
+
+# so that flush.pl can be deprecated
+
+sub printflush {
+ my $io = shift;
+ my $old;
+ $old = new SelectSaver qualify($io, caller) if ref($io);
+ local $| = 1;
+ if(ref($io)) {
+ print $io @_;
+ }
+ else {
+ print @_;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/IO/InnerFile.pm b/Master/tlpkg/tlperl/lib/IO/InnerFile.pm
new file mode 100755
index 00000000000..2023e42b8aa
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/InnerFile.pm
@@ -0,0 +1,282 @@
+package IO::InnerFile;
+
+=head1 NAME
+
+IO::InnerFile - define a file inside another file
+
+
+=head1 SYNOPSIS
+
+
+ ### Read a subset of a file:
+ $inner = IO::InnerFile->new($fh, $start, $length);
+ while (<$inner>) {
+ ...
+ }
+
+
+=head1 DESCRIPTION
+
+If you have a filehandle that can seek() and tell(), then you
+can open an IO::InnerFile on a range of the underlying file.
+
+
+=head1 PUBLIC INTERFACE
+
+=over
+
+=cut
+
+use Symbol;
+
+# The package version, both in 1.23 style *and* usable by MakeMaker:
+$VERSION = "2.110";
+
+#------------------------------
+
+=item new FILEHANDLE, [START, [LENGTH]]
+
+I<Class method, constructor.>
+Create a new inner-file opened on the given FILEHANDLE,
+from bytes START to START+LENGTH. Both START and LENGTH
+default to 0; negative values are silently coerced to zero.
+
+Note that FILEHANDLE must be able to seek() and tell(), in addition
+to whatever other methods you may desire for reading it.
+
+=cut
+
+sub new {
+ my ($class, $fh, $start, $lg) = @_;
+ $start = 0 if (!$start or ($start < 0));
+ $lg = 0 if (!$lg or ($lg < 0));
+
+ ### Create the underlying "object":
+ my $a = {
+ FH => $fh,
+ CRPOS => 0,
+ START => $start,
+ LG => $lg,
+ };
+
+ ### Create a new filehandle tied to this object:
+ $fh = gensym;
+ tie(*$fh, $class, $a);
+ return bless($fh, $class);
+}
+
+sub TIEHANDLE {
+ my ($class, $data) = @_;
+ return bless($data, $class);
+}
+
+sub DESTROY {
+ my ($self) = @_;
+ $self->close() if (ref($self) eq 'SCALAR');
+}
+
+#------------------------------
+
+=item set_length LENGTH
+
+=item get_length
+
+=item add_length NBYTES
+
+I<Instance methods.>
+Get/set the virtual length of the inner file.
+
+=cut
+
+sub set_length { tied(${$_[0]})->{LG} = $_[1]; }
+sub get_length { tied(${$_[0]})->{LG}; }
+sub add_length { tied(${$_[0]})->{LG} += $_[1]; }
+
+#------------------------------
+
+=item set_start START
+
+=item get_start
+
+=item add_start NBYTES
+
+I<Instance methods.>
+Get/set the virtual start position of the inner file.
+
+=cut
+
+sub set_start { tied(${$_[0]})->{START} = $_[1]; }
+sub get_start { tied(${$_[0]})->{START}; }
+sub set_end { tied(${$_[0]})->{LG} = $_[1] - tied(${$_[0]})->{START}; }
+sub get_end { tied(${$_[0]})->{LG} + tied(${$_[0]})->{START}; }
+
+
+#------------------------------
+
+=item binmode
+
+=item close
+
+=item flush
+
+=item getc
+
+=item getline
+
+=item print LIST
+
+=item printf LIST
+
+=item read BUF, NBYTES
+
+=item readline
+
+=item seek OFFFSET, WHENCE
+
+=item tell
+
+=item write ARGS...
+
+I<Instance methods.>
+Standard filehandle methods.
+
+=cut
+
+sub write { shift->WRITE(@_) }
+sub print { shift->PRINT(@_) }
+sub printf { shift->PRINTF(@_) }
+sub flush { "0 but true"; }
+sub binmode { 1; }
+sub getc { return GETC(tied(${$_[0]}) ); }
+sub read { return READ( tied(${$_[0]}), @_[1,2,3] ); }
+sub readline { return READLINE( tied(${$_[0]}) ); }
+sub getline { return READLINE( tied(${$_[0]}) ); }
+sub close { return CLOSE(tied(${$_[0]}) ); }
+
+sub seek {
+ my ($self, $ofs, $whence) = @_;
+ $self = tied( $$self );
+
+ $self->{CRPOS} = $ofs if ($whence == 0);
+ $self->{CRPOS}+= $ofs if ($whence == 1);
+ $self->{CRPOS} = $self->{LG} + $ofs if ($whence == 2);
+
+ $self->{CRPOS} = 0 if ($self->{CRPOS} < 0);
+ $self->{CRPOS} = $self->{LG} if ($self->{CRPOS} > $self->{LG});
+ return 1;
+}
+
+sub tell {
+ return tied(${$_[0]})->{CRPOS};
+}
+
+sub WRITE {
+ die "inner files can only open for reading\n";
+}
+
+sub PRINT {
+ die "inner files can only open for reading\n";
+}
+
+sub PRINTF {
+ die "inner files can only open for reading\n";
+}
+
+sub GETC {
+ my ($self) = @_;
+ return 0 if ($self->{CRPOS} >= $self->{LG});
+
+ my $data;
+
+ ### Save and seek...
+ my $old_pos = $self->{FH}->tell;
+ $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
+
+ ### ...read...
+ my $lg = $self->{FH}->read($data, 1);
+ $self->{CRPOS} += $lg;
+
+ ### ...and restore:
+ $self->{FH}->seek($old_pos, 0);
+
+ $self->{LG} = $self->{CRPOS} unless ($lg);
+ return ($lg ? $data : undef);
+}
+
+sub READ {
+ my ($self, $undefined, $lg, $ofs) = @_;
+ $undefined = undef;
+
+ return 0 if ($self->{CRPOS} >= $self->{LG});
+ $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
+ return 0 unless ($lg);
+
+ ### Save and seek...
+ my $old_pos = $self->{FH}->tell;
+ $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
+
+ ### ...read...
+ $lg = $self->{FH}->read($_[1], $lg, $_[3] );
+ $self->{CRPOS} += $lg;
+
+ ### ...and restore:
+ $self->{FH}->seek($old_pos, 0);
+
+ $self->{LG} = $self->{CRPOS} unless ($lg);
+ return $lg;
+}
+
+sub READLINE {
+ my ($self) = @_;
+ return undef if ($self->{CRPOS} >= $self->{LG});
+
+ ### Save and seek...
+ my $old_pos = $self->{FH}->tell;
+ $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
+
+ ### ...read...
+ my $text = $self->{FH}->getline;
+
+ ### ...and restore:
+ $self->{FH}->seek($old_pos, 0);
+
+ #### If we detected a new EOF ...
+ unless (defined $text) {
+ $self->{LG} = $self->{CRPOS};
+ return undef;
+ }
+
+ my $lg=length($text);
+
+ $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
+ $self->{CRPOS} += $lg;
+
+ return substr($text, 0,$lg);
+}
+
+sub CLOSE { %{$_[0]}=(); }
+
+
+
+1;
+__END__
+
+=back
+
+
+=head1 VERSION
+
+$Id: InnerFile.pm,v 1.4 2005/02/10 21:21:53 dfs Exp $
+
+
+=head1 AUTHOR
+
+Original version by Doru Petrescu (pdoru@kappa.ro).
+
+Documentation and by Eryq (eryq@zeegee.com).
+
+Currently maintained by David F. Skoll (dfs@roaringpenguin.com).
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Lines.pm b/Master/tlpkg/tlperl/lib/IO/Lines.pm
new file mode 100755
index 00000000000..46c40a5492b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Lines.pm
@@ -0,0 +1,184 @@
+package IO::Lines;
+
+
+=head1 NAME
+
+IO::Lines - IO:: interface for reading/writing an array of lines
+
+
+=head1 SYNOPSIS
+
+ use IO::Lines;
+
+ ### See IO::ScalarArray for details
+
+
+=head1 DESCRIPTION
+
+This class implements objects which behave just like FileHandle
+(or IO::Handle) objects, except that you may use them to write to
+(or read from) an array of lines. They can be tiehandle'd as well.
+
+This is a subclass of L<IO::ScalarArray|IO::ScalarArray>
+in which the underlying
+array has its data stored in a line-oriented-format: that is,
+every element ends in a C<"\n">, with the possible exception of the
+final element. This makes C<getline()> I<much> more efficient;
+if you plan to do line-oriented reading/printing, you want this class.
+
+The C<print()> method will enforce this rule, so you can print
+arbitrary data to the line-array: it will break the data at
+newlines appropriately.
+
+See L<IO::ScalarArray> for full usage and warnings.
+
+=cut
+
+use Carp;
+use strict;
+use IO::ScalarArray;
+use vars qw($VERSION @ISA);
+
+# The package version, both in 1.23 style *and* usable by MakeMaker:
+$VERSION = "2.110";
+
+# Inheritance:
+@ISA = qw(IO::ScalarArray); ### also gets us new_tie :-)
+
+
+#------------------------------
+#
+# getline
+#
+# Instance method, override.
+# Return the next line, or undef on end of data.
+# Can safely be called in an array context.
+# Currently, lines are delimited by "\n".
+#
+sub getline {
+ my $self = shift;
+
+ if (!defined $/) {
+ return join( '', $self->_getlines_for_newlines );
+ }
+ elsif ($/ eq "\n") {
+ if (!*$self->{Pos}) { ### full line...
+ return *$self->{AR}[*$self->{Str}++];
+ }
+ else { ### partial line...
+ my $partial = substr(*$self->{AR}[*$self->{Str}++], *$self->{Pos});
+ *$self->{Pos} = 0;
+ return $partial;
+ }
+ }
+ else {
+ croak 'unsupported $/: must be "\n" or undef';
+ }
+}
+
+#------------------------------
+#
+# getlines
+#
+# Instance method, override.
+# Return an array comprised of the remaining lines, or () on end of data.
+# Must be called in an array context.
+# Currently, lines are delimited by "\n".
+#
+sub getlines {
+ my $self = shift;
+ wantarray or croak("can't call getlines in scalar context!");
+
+ if ((defined $/) and ($/ eq "\n")) {
+ return $self->_getlines_for_newlines(@_);
+ }
+ else { ### slow but steady
+ return $self->SUPER::getlines(@_);
+ }
+}
+
+#------------------------------
+#
+# _getlines_for_newlines
+#
+# Instance method, private.
+# If $/ is newline, do fast getlines.
+# This CAN NOT invoke getline!
+#
+sub _getlines_for_newlines {
+ my $self = shift;
+ my ($rArray, $Str, $Pos) = @{*$self}{ qw( AR Str Pos ) };
+ my @partial = ();
+
+ if ($Pos) { ### partial line...
+ @partial = (substr( $rArray->[ $Str++ ], $Pos ));
+ *$self->{Pos} = 0;
+ }
+ *$self->{Str} = scalar @$rArray; ### about to exhaust @$rArray
+ return (@partial,
+ @$rArray[ $Str .. $#$rArray ]); ### remaining full lines...
+}
+
+#------------------------------
+#
+# print ARGS...
+#
+# Instance method, override.
+# Print ARGS to the underlying line array.
+#
+sub print {
+ if (defined $\ && $\ ne "\n") {
+ croak 'unsupported $\: must be "\n" or undef';
+ }
+
+ my $self = shift;
+ ### print STDERR "\n[[ARRAY WAS...\n", @{*$self->{AR}}, "<<EOF>>\n";
+ my @lines = split /^/, join('', @_); @lines or return 1;
+
+ ### Did the previous print not end with a newline?
+ ### If so, append first line:
+ if (@{*$self->{AR}} and (*$self->{AR}[-1] !~ /\n\Z/)) {
+ *$self->{AR}[-1] .= shift @lines;
+ }
+ push @{*$self->{AR}}, @lines; ### add the remainder
+ ### print STDERR "\n[[ARRAY IS NOW...\n", @{*$self->{AR}}, "<<EOF>>\n";
+ 1;
+}
+
+#------------------------------
+1;
+
+__END__
+
+
+=head1 VERSION
+
+$Id: Lines.pm,v 1.3 2005/02/10 21:21:53 dfs Exp $
+
+
+=head1 AUTHORS
+
+
+=head2 Primary Maintainer
+
+David F. Skoll (F<dfs@roaringpenguin.com>).
+
+=head2 Principal author
+
+Eryq (F<eryq@zeegee.com>).
+President, ZeeGee Software Inc (F<http://www.zeegee.com>).
+
+
+=head2 Other contributors
+
+Thanks to the following individuals for their invaluable contributions
+(if I've forgotten or misspelled your name, please email me!):
+
+I<Morris M. Siegel,>
+for his $/ patch and the new C<getlines()>.
+
+I<Doug Wilson,>
+for the IO::Handle inheritance and automatic tie-ing.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Pipe.pm b/Master/tlpkg/tlperl/lib/IO/Pipe.pm
new file mode 100755
index 00000000000..827cc48bfcd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Pipe.pm
@@ -0,0 +1,257 @@
+# IO::Pipe.pm
+#
+# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Pipe;
+
+use 5.006_001;
+
+use IO::Handle;
+use strict;
+our($VERSION);
+use Carp;
+use Symbol;
+
+$VERSION = "1.13";
+
+sub new {
+ my $type = shift;
+ my $class = ref($type) || $type || "IO::Pipe";
+ @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]";
+
+ my $me = bless gensym(), $class;
+
+ my($readfh,$writefh) = @_ ? @_ : $me->handles;
+
+ pipe($readfh, $writefh)
+ or return undef;
+
+ @{*$me} = ($readfh, $writefh);
+
+ $me;
+}
+
+sub handles {
+ @_ == 1 or croak 'usage: $pipe->handles()';
+ (IO::Pipe::End->new(), IO::Pipe::End->new());
+}
+
+my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
+
+sub _doit {
+ my $me = shift;
+ my $rw = shift;
+
+ my $pid = $do_spawn ? 0 : fork();
+
+ if($pid) { # Parent
+ return $pid;
+ }
+ elsif(defined $pid) { # Child or spawn
+ my $fh;
+ my $io = $rw ? \*STDIN : \*STDOUT;
+ my ($mode, $save) = $rw ? "r" : "w";
+ if ($do_spawn) {
+ require Fcntl;
+ $save = IO::Handle->new_from_fd($io, $mode);
+ my $handle = shift;
+ # Close in child:
+ unless ($^O eq 'MSWin32') {
+ fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
+ }
+ $fh = $rw ? ${*$me}[0] : ${*$me}[1];
+ } else {
+ shift;
+ $fh = $rw ? $me->reader() : $me->writer(); # close the other end
+ }
+ bless $io, "IO::Handle";
+ $io->fdopen($fh, $mode);
+ $fh->close;
+
+ if ($do_spawn) {
+ $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
+ my $err = $!;
+
+ $io->fdopen($save, $mode);
+ $save->close or croak "Cannot close $!";
+ croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
+ return $pid;
+ } else {
+ exec @_ or
+ croak "IO::Pipe: Cannot exec: $!";
+ }
+ }
+ else {
+ croak "IO::Pipe: Cannot fork: $!";
+ }
+
+ # NOT Reached
+}
+
+sub reader {
+ @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
+ my $me = shift;
+
+ return undef
+ unless(ref($me) || ref($me = $me->new));
+
+ my $fh = ${*$me}[0];
+ my $pid;
+ $pid = $me->_doit(0, $fh, @_)
+ if(@_);
+
+ close ${*$me}[1];
+ bless $me, ref($fh);
+ *$me = *$fh; # Alias self to handle
+ $me->fdopen($fh->fileno,"r")
+ unless defined($me->fileno);
+ bless $fh; # Really wan't un-bless here
+ ${*$me}{'io_pipe_pid'} = $pid
+ if defined $pid;
+
+ $me;
+}
+
+sub writer {
+ @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
+ my $me = shift;
+
+ return undef
+ unless(ref($me) || ref($me = $me->new));
+
+ my $fh = ${*$me}[1];
+ my $pid;
+ $pid = $me->_doit(1, $fh, @_)
+ if(@_);
+
+ close ${*$me}[0];
+ bless $me, ref($fh);
+ *$me = *$fh; # Alias self to handle
+ $me->fdopen($fh->fileno,"w")
+ unless defined($me->fileno);
+ bless $fh; # Really wan't un-bless here
+ ${*$me}{'io_pipe_pid'} = $pid
+ if defined $pid;
+
+ $me;
+}
+
+package IO::Pipe::End;
+
+our(@ISA);
+
+@ISA = qw(IO::Handle);
+
+sub close {
+ my $fh = shift;
+ my $r = $fh->SUPER::close(@_);
+
+ waitpid(${*$fh}{'io_pipe_pid'},0)
+ if(defined ${*$fh}{'io_pipe_pid'});
+
+ $r;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Pipe - supply object methods for pipes
+
+=head1 SYNOPSIS
+
+ use IO::Pipe;
+
+ $pipe = new IO::Pipe;
+
+ if($pid = fork()) { # Parent
+ $pipe->reader();
+
+ while(<$pipe>) {
+ ...
+ }
+
+ }
+ elsif(defined $pid) { # Child
+ $pipe->writer();
+
+ print $pipe ...
+ }
+
+ or
+
+ $pipe = new IO::Pipe;
+
+ $pipe->reader(qw(ls -l));
+
+ while(<$pipe>) {
+ ...
+ }
+
+=head1 DESCRIPTION
+
+C<IO::Pipe> provides an interface to creating pipes between
+processes.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [READER, WRITER] )
+
+Creates an C<IO::Pipe>, which is a reference to a newly created symbol
+(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two
+arguments, which should be objects blessed into C<IO::Handle>, or a
+subclass thereof. These two objects will be used for the system call
+to C<pipe>. If no arguments are given then method C<handles> is called
+on the new C<IO::Pipe> object.
+
+These two handles are held in the array part of the GLOB until either
+C<reader> or C<writer> is called.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item reader ([ARGS])
+
+The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
+handle at the reading end of the pipe. If C<ARGS> are given then C<fork>
+is called and C<ARGS> are passed to exec.
+
+=item writer ([ARGS])
+
+The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
+handle at the writing end of the pipe. If C<ARGS> are given then C<fork>
+is called and C<ARGS> are passed to exec.
+
+=item handles ()
+
+This method is called during construction by C<IO::Pipe::new>
+on the newly created C<IO::Pipe> object. It returns an array of two objects
+blessed into C<IO::Pipe::End>, or a subclass thereof.
+
+=back
+
+=head1 SEE ALSO
+
+L<IO::Handle>
+
+=head1 AUTHOR
+
+Graham Barr. Currently maintained by the Perl Porters. Please report all
+bugs to <perl5-porters@perl.org>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/IO/Poll.pm b/Master/tlpkg/tlperl/lib/IO/Poll.pm
new file mode 100755
index 00000000000..e7fb0135069
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Poll.pm
@@ -0,0 +1,209 @@
+
+# IO::Poll.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Poll;
+
+use strict;
+use IO::Handle;
+use Exporter ();
+our(@ISA, @EXPORT_OK, @EXPORT, $VERSION);
+
+@ISA = qw(Exporter);
+$VERSION = "0.07";
+
+@EXPORT = qw( POLLIN
+ POLLOUT
+ POLLERR
+ POLLHUP
+ POLLNVAL
+ );
+
+@EXPORT_OK = qw(
+ POLLPRI
+ POLLRDNORM
+ POLLWRNORM
+ POLLRDBAND
+ POLLWRBAND
+ POLLNORM
+ );
+
+# [0] maps fd's to requested masks
+# [1] maps fd's to returned masks
+# [2] maps fd's to handles
+sub new {
+ my $class = shift;
+
+ my $self = bless [{},{},{}], $class;
+
+ $self;
+}
+
+sub mask {
+ my $self = shift;
+ my $io = shift;
+ my $fd = fileno($io);
+ return unless defined $fd;
+ if (@_) {
+ my $mask = shift;
+ if($mask) {
+ $self->[0]{$fd}{$io} = $mask; # the error events are always returned
+ $self->[1]{$fd} = 0; # output mask
+ $self->[2]{$io} = $io; # remember handle
+ } else {
+ delete $self->[0]{$fd}{$io};
+ unless(%{$self->[0]{$fd}}) {
+ # We no longer have any handles for this FD
+ delete $self->[1]{$fd};
+ delete $self->[0]{$fd};
+ }
+ delete $self->[2]{$io};
+ }
+ }
+
+ return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io};
+ return $self->[0]{$fd}{$io};
+}
+
+
+sub poll {
+ my($self,$timeout) = @_;
+
+ $self->[1] = {};
+
+ my($fd,$mask,$iom);
+ my @poll = ();
+
+ while(($fd,$iom) = each %{$self->[0]}) {
+ $mask = 0;
+ $mask |= $_ for values(%$iom);
+ push(@poll,$fd => $mask);
+ }
+
+ my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0;
+
+ return $ret
+ unless $ret > 0;
+
+ while(@poll) {
+ my($fd,$got) = splice(@poll,0,2);
+ $self->[1]{$fd} = $got if $got;
+ }
+
+ return $ret;
+}
+
+sub events {
+ my $self = shift;
+ my $io = shift;
+ my $fd = fileno($io);
+ exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io}
+ ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL)
+ : 0;
+}
+
+sub remove {
+ my $self = shift;
+ my $io = shift;
+ $self->mask($io,0);
+}
+
+sub handles {
+ my $self = shift;
+ return values %{$self->[2]} unless @_;
+
+ my $events = shift || 0;
+ my($fd,$ev,$io,$mask);
+ my @handles = ();
+
+ while(($fd,$ev) = each %{$self->[1]}) {
+ while (($io,$mask) = each %{$self->[0]{$fd}}) {
+ $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these
+ push @handles,$self->[2]{$io} if ($ev & $mask) & $events;
+ }
+ }
+ return @handles;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Poll - Object interface to system poll call
+
+=head1 SYNOPSIS
+
+ use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP);
+
+ $poll = new IO::Poll;
+
+ $poll->mask($input_handle => POLLIN);
+ $poll->mask($output_handle => POLLOUT);
+
+ $poll->poll($timeout);
+
+ $ev = $poll->events($input);
+
+=head1 DESCRIPTION
+
+C<IO::Poll> is a simple interface to the system level poll routine.
+
+=head1 METHODS
+
+=over 4
+
+=item mask ( IO [, EVENT_MASK ] )
+
+If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the
+list of file descriptors and the next call to poll will check for
+any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be
+removed from the list of file descriptors.
+
+If EVENT_MASK is not given then the return value will be the current
+event mask value for IO.
+
+=item poll ( [ TIMEOUT ] )
+
+Call the system level poll routine. If TIMEOUT is not specified then the
+call will block. Returns the number of handles which had events
+happen, or -1 on error.
+
+=item events ( IO )
+
+Returns the event mask which represents the events that happened on IO
+during the last call to C<poll>.
+
+=item remove ( IO )
+
+Remove IO from the list of file descriptors for the next poll.
+
+=item handles( [ EVENT_MASK ] )
+
+Returns a list of handles. If EVENT_MASK is not given then a list of all
+handles known will be returned. If EVENT_MASK is given then a list
+of handles will be returned which had one of the events specified by
+EVENT_MASK happen during the last call ti C<poll>
+
+=back
+
+=head1 SEE ALSO
+
+L<poll(2)>, L<IO::Handle>, L<IO::Select>
+
+=head1 AUTHOR
+
+Graham Barr. Currently maintained by the Perl Porters. Please report all
+bugs to <perl5-porters@perl.org>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/IO/Scalar.pm b/Master/tlpkg/tlperl/lib/IO/Scalar.pm
new file mode 100755
index 00000000000..7a522821343
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Scalar.pm
@@ -0,0 +1,778 @@
+package IO::Scalar;
+
+
+=head1 NAME
+
+IO::Scalar - IO:: interface for reading/writing a scalar
+
+
+=head1 SYNOPSIS
+
+Perform I/O on strings, using the basic OO interface...
+
+ use 5.005;
+ use IO::Scalar;
+ $data = "My message:\n";
+
+ ### Open a handle on a string, and append to it:
+ $SH = new IO::Scalar \$data;
+ $SH->print("Hello");
+ $SH->print(", world!\nBye now!\n");
+ print "The string is now: ", $data, "\n";
+
+ ### Open a handle on a string, read it line-by-line, then close it:
+ $SH = new IO::Scalar \$data;
+ while (defined($_ = $SH->getline)) {
+ print "Got line: $_";
+ }
+ $SH->close;
+
+ ### Open a handle on a string, and slurp in all the lines:
+ $SH = new IO::Scalar \$data;
+ print "All lines:\n", $SH->getlines;
+
+ ### Get the current position (either of two ways):
+ $pos = $SH->getpos;
+ $offset = $SH->tell;
+
+ ### Set the current position (either of two ways):
+ $SH->setpos($pos);
+ $SH->seek($offset, 0);
+
+ ### Open an anonymous temporary scalar:
+ $SH = new IO::Scalar;
+ $SH->print("Hi there!");
+ print "I printed: ", ${$SH->sref}, "\n"; ### get at value
+
+
+Don't like OO for your I/O? No problem.
+Thanks to the magic of an invisible tie(), the following now
+works out of the box, just as it does with IO::Handle:
+
+ use 5.005;
+ use IO::Scalar;
+ $data = "My message:\n";
+
+ ### Open a handle on a string, and append to it:
+ $SH = new IO::Scalar \$data;
+ print $SH "Hello";
+ print $SH ", world!\nBye now!\n";
+ print "The string is now: ", $data, "\n";
+
+ ### Open a handle on a string, read it line-by-line, then close it:
+ $SH = new IO::Scalar \$data;
+ while (<$SH>) {
+ print "Got line: $_";
+ }
+ close $SH;
+
+ ### Open a handle on a string, and slurp in all the lines:
+ $SH = new IO::Scalar \$data;
+ print "All lines:\n", <$SH>;
+
+ ### Get the current position (WARNING: requires 5.6):
+ $offset = tell $SH;
+
+ ### Set the current position (WARNING: requires 5.6):
+ seek $SH, $offset, 0;
+
+ ### Open an anonymous temporary scalar:
+ $SH = new IO::Scalar;
+ print $SH "Hi there!";
+ print "I printed: ", ${$SH->sref}, "\n"; ### get at value
+
+
+And for you folks with 1.x code out there: the old tie() style still works,
+though this is I<unnecessary and deprecated>:
+
+ use IO::Scalar;
+
+ ### Writing to a scalar...
+ my $s;
+ tie *OUT, 'IO::Scalar', \$s;
+ print OUT "line 1\nline 2\n", "line 3\n";
+ print "String is now: $s\n"
+
+ ### Reading and writing an anonymous scalar...
+ tie *OUT, 'IO::Scalar';
+ print OUT "line 1\nline 2\n", "line 3\n";
+ tied(OUT)->seek(0,0);
+ while (<OUT>) {
+ print "Got line: ", $_;
+ }
+
+
+Stringification works, too!
+
+ my $SH = new IO::Scalar \$data;
+ print $SH "Hello, ";
+ print $SH "world!";
+ print "I printed: $SH\n";
+
+
+
+=head1 DESCRIPTION
+
+This class is part of the IO::Stringy distribution;
+see L<IO::Stringy> for change log and general information.
+
+The IO::Scalar class implements objects which behave just like
+IO::Handle (or FileHandle) objects, except that you may use them
+to write to (or read from) scalars. These handles are
+automatically tiehandle'd (though please see L<"WARNINGS">
+for information relevant to your Perl version).
+
+
+Basically, this:
+
+ my $s;
+ $SH = new IO::Scalar \$s;
+ $SH->print("Hel", "lo, "); ### OO style
+ $SH->print("world!\n"); ### ditto
+
+Or this:
+
+ my $s;
+ $SH = tie *OUT, 'IO::Scalar', \$s;
+ print OUT "Hel", "lo, "; ### non-OO style
+ print OUT "world!\n"; ### ditto
+
+Causes $s to be set to:
+
+ "Hello, world!\n"
+
+
+=head1 PUBLIC INTERFACE
+
+=cut
+
+use Carp;
+use strict;
+use vars qw($VERSION @ISA);
+use IO::Handle;
+
+use 5.005;
+
+### Stringification, courtesy of B. K. Oxley (binkley): :-)
+use overload '""' => sub { ${*{$_[0]}->{SR}} };
+use overload 'bool' => sub { 1 }; ### have to do this, so object is true!
+
+### The package version, both in 1.23 style *and* usable by MakeMaker:
+$VERSION = "2.110";
+
+### Inheritance:
+@ISA = qw(IO::Handle);
+
+### This stuff should be got rid of ASAP.
+require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
+
+#==============================
+
+=head2 Construction
+
+=over 4
+
+=cut
+
+#------------------------------
+
+=item new [ARGS...]
+
+I<Class method.>
+Return a new, unattached scalar handle.
+If any arguments are given, they're sent to open().
+
+=cut
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = bless \do { local *FH }, $class;
+ tie *$self, $class, $self;
+ $self->open(@_); ### open on anonymous by default
+ $self;
+}
+sub DESTROY {
+ shift->close;
+}
+
+#------------------------------
+
+=item open [SCALARREF]
+
+I<Instance method.>
+Open the scalar handle on a new scalar, pointed to by SCALARREF.
+If no SCALARREF is given, a "private" scalar is created to hold
+the file data.
+
+Returns the self object on success, undefined on error.
+
+=cut
+
+sub open {
+ my ($self, $sref) = @_;
+
+ ### Sanity:
+ defined($sref) or do {my $s = ''; $sref = \$s};
+ (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";
+
+ ### Setup:
+ *$self->{Pos} = 0; ### seek position
+ *$self->{SR} = $sref; ### scalar reference
+ $self;
+}
+
+#------------------------------
+
+=item opened
+
+I<Instance method.>
+Is the scalar handle opened on something?
+
+=cut
+
+sub opened {
+ *{shift()}->{SR};
+}
+
+#------------------------------
+
+=item close
+
+I<Instance method.>
+Disassociate the scalar handle from its underlying scalar.
+Done automatically on destroy.
+
+=cut
+
+sub close {
+ my $self = shift;
+ %{*$self} = ();
+ 1;
+}
+
+=back
+
+=cut
+
+
+
+#==============================
+
+=head2 Input and output
+
+=over 4
+
+=cut
+
+
+#------------------------------
+
+=item flush
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub flush { "0 but true" }
+
+#------------------------------
+
+=item getc
+
+I<Instance method.>
+Return the next character, or undef if none remain.
+
+=cut
+
+sub getc {
+ my $self = shift;
+
+ ### Return undef right away if at EOF; else, move pos forward:
+ return undef if $self->eof;
+ substr(${*$self->{SR}}, *$self->{Pos}++, 1);
+}
+
+#------------------------------
+
+=item getline
+
+I<Instance method.>
+Return the next line, or undef on end of string.
+Can safely be called in an array context.
+Currently, lines are delimited by "\n".
+
+=cut
+
+sub getline {
+ my $self = shift;
+
+ ### Return undef right away if at EOF:
+ return undef if $self->eof;
+
+ ### Get next line:
+ my $sr = *$self->{SR};
+ my $i = *$self->{Pos}; ### Start matching at this point.
+
+ ### Minimal impact implementation!
+ ### We do the fast fast thing (no regexps) if using the
+ ### classic input record separator.
+
+ ### Case 1: $/ is undef: slurp all...
+ if (!defined($/)) {
+ *$self->{Pos} = length $$sr;
+ return substr($$sr, $i);
+ }
+
+ ### Case 2: $/ is "\n": zoom zoom zoom...
+ elsif ($/ eq "\012") {
+
+ ### Seek ahead for "\n"... yes, this really is faster than regexps.
+ my $len = length($$sr);
+ for (; $i < $len; ++$i) {
+ last if ord (substr ($$sr, $i, 1)) == 10;
+ }
+
+ ### Extract the line:
+ my $line;
+ if ($i < $len) { ### We found a "\n":
+ $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
+ *$self->{Pos} = $i+1; ### Remember where we finished up.
+ }
+ else { ### No "\n"; slurp the remainder:
+ $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
+ *$self->{Pos} = $len;
+ }
+ return $line;
+ }
+
+ ### Case 3: $/ is ref to int. Do fixed-size records.
+ ### (Thanks to Dominique Quatravaux.)
+ elsif (ref($/)) {
+ my $len = length($$sr);
+ my $i = ${$/} + 0;
+ my $line = substr ($$sr, *$self->{Pos}, $i);
+ *$self->{Pos} += $i;
+ *$self->{Pos} = $len if (*$self->{Pos} > $len);
+ return $line;
+ }
+
+ ### Case 4: $/ is either "" (paragraphs) or something weird...
+ ### This is Graham's general-purpose stuff, which might be
+ ### a tad slower than Case 2 for typical data, because
+ ### of the regexps.
+ else {
+ pos($$sr) = $i;
+
+ ### If in paragraph mode, skip leading lines (and update i!):
+ length($/) or
+ (($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));
+
+ ### If we see the separator in the buffer ahead...
+ if (length($/)
+ ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp!
+ : $$sr =~ m,\n\n,g ### (a paragraph)
+ ) {
+ *$self->{Pos} = pos $$sr;
+ return substr($$sr, $i, *$self->{Pos}-$i);
+ }
+ ### Else if no separator remains, just slurp the rest:
+ else {
+ *$self->{Pos} = length $$sr;
+ return substr($$sr, $i);
+ }
+ }
+}
+
+#------------------------------
+
+=item getlines
+
+I<Instance method.>
+Get all remaining lines.
+It will croak() if accidentally called in a scalar context.
+
+=cut
+
+sub getlines {
+ my $self = shift;
+ wantarray or croak("can't call getlines in scalar context!");
+ my ($line, @lines);
+ push @lines, $line while (defined($line = $self->getline));
+ @lines;
+}
+
+#------------------------------
+
+=item print ARGS...
+
+I<Instance method.>
+Print ARGS to the underlying scalar.
+
+B<Warning:> this continues to always cause a seek to the end
+of the string, but if you perform seek()s and tell()s, it is
+still safer to explicitly seek-to-end before subsequent print()s.
+
+=cut
+
+sub print {
+ my $self = shift;
+ *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
+ 1;
+}
+sub _unsafe_print {
+ my $self = shift;
+ my $append = join('', @_) . $\;
+ ${*$self->{SR}} .= $append;
+ *$self->{Pos} += length($append);
+ 1;
+}
+sub _old_print {
+ my $self = shift;
+ ${*$self->{SR}} .= join('', @_) . $\;
+ *$self->{Pos} = length(${*$self->{SR}});
+ 1;
+}
+
+
+#------------------------------
+
+=item read BUF, NBYTES, [OFFSET]
+
+I<Instance method.>
+Read some bytes from the scalar.
+Returns the number of bytes actually read, 0 on end-of-file, undef on error.
+
+=cut
+
+sub read {
+ my $self = $_[0];
+ my $n = $_[2];
+ my $off = $_[3] || 0;
+
+ my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
+ $n = length($read);
+ *$self->{Pos} += $n;
+ ($off ? substr($_[1], $off) : $_[1]) = $read;
+ return $n;
+}
+
+#------------------------------
+
+=item write BUF, NBYTES, [OFFSET]
+
+I<Instance method.>
+Write some bytes to the scalar.
+
+=cut
+
+sub write {
+ my $self = $_[0];
+ my $n = $_[2];
+ my $off = $_[3] || 0;
+
+ my $data = substr($_[1], $off, $n);
+ $n = length($data);
+ $self->print($data);
+ return $n;
+}
+
+#------------------------------
+
+=item sysread BUF, LEN, [OFFSET]
+
+I<Instance method.>
+Read some bytes from the scalar.
+Returns the number of bytes actually read, 0 on end-of-file, undef on error.
+
+=cut
+
+sub sysread {
+ my $self = shift;
+ $self->read(@_);
+}
+
+#------------------------------
+
+=item syswrite BUF, NBYTES, [OFFSET]
+
+I<Instance method.>
+Write some bytes to the scalar.
+
+=cut
+
+sub syswrite {
+ my $self = shift;
+ $self->write(@_);
+}
+
+=back
+
+=cut
+
+
+#==============================
+
+=head2 Seeking/telling and other attributes
+
+=over 4
+
+=cut
+
+
+#------------------------------
+
+=item autoflush
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub autoflush {}
+
+#------------------------------
+
+=item binmode
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub binmode {}
+
+#------------------------------
+
+=item clearerr
+
+I<Instance method.> Clear the error and EOF flags. A no-op.
+
+=cut
+
+sub clearerr { 1 }
+
+#------------------------------
+
+=item eof
+
+I<Instance method.> Are we at end of file?
+
+=cut
+
+sub eof {
+ my $self = shift;
+ (*$self->{Pos} >= length(${*$self->{SR}}));
+}
+
+#------------------------------
+
+=item seek OFFSET, WHENCE
+
+I<Instance method.> Seek to a given position in the stream.
+
+=cut
+
+sub seek {
+ my ($self, $pos, $whence) = @_;
+ my $eofpos = length(${*$self->{SR}});
+
+ ### Seek:
+ if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET
+ elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR
+ elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END
+ else { croak "bad seek whence ($whence)" }
+
+ ### Fixup:
+ if (*$self->{Pos} < 0) { *$self->{Pos} = 0 }
+ if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
+ return 1;
+}
+
+#------------------------------
+
+=item sysseek OFFSET, WHENCE
+
+I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.>
+
+=cut
+
+sub sysseek {
+ my $self = shift;
+ $self->seek (@_);
+}
+
+#------------------------------
+
+=item tell
+
+I<Instance method.>
+Return the current position in the stream, as a numeric offset.
+
+=cut
+
+sub tell { *{shift()}->{Pos} }
+
+#------------------------------
+#
+# use_RS [YESNO]
+#
+# I<Instance method.>
+# Obey the curent setting of $/, like IO::Handle does?
+# Default is false in 1.x, but cold-welded true in 2.x and later.
+#
+sub use_RS {
+ my ($self, $yesno) = @_;
+ carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
+ }
+
+#------------------------------
+
+=item setpos POS
+
+I<Instance method.>
+Set the current position, using the opaque value returned by C<getpos()>.
+
+=cut
+
+sub setpos { shift->seek($_[0],0) }
+
+#------------------------------
+
+=item getpos
+
+I<Instance method.>
+Return the current position in the string, as an opaque object.
+
+=cut
+
+*getpos = \&tell;
+
+
+#------------------------------
+
+=item sref
+
+I<Instance method.>
+Return a reference to the underlying scalar.
+
+=cut
+
+sub sref { *{shift()}->{SR} }
+
+
+#------------------------------
+# Tied handle methods...
+#------------------------------
+
+# Conventional tiehandle interface:
+sub TIEHANDLE {
+ ((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar"))
+ ? $_[1]
+ : shift->new(@_));
+}
+sub GETC { shift->getc(@_) }
+sub PRINT { shift->print(@_) }
+sub PRINTF { shift->print(sprintf(shift, @_)) }
+sub READ { shift->read(@_) }
+sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
+sub WRITE { shift->write(@_); }
+sub CLOSE { shift->close(@_); }
+sub SEEK { shift->seek(@_); }
+sub TELL { shift->tell(@_); }
+sub EOF { shift->eof(@_); }
+
+#------------------------------------------------------------
+
+1;
+
+__END__
+
+
+
+=back
+
+=cut
+
+
+=head1 WARNINGS
+
+Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
+it was missing support for C<seek()>, C<tell()>, and C<eof()>.
+Attempting to use these functions with an IO::Scalar will not work
+prior to 5.005_57. IO::Scalar will not have the relevant methods
+invoked; and even worse, this kind of bug can lie dormant for a while.
+If you turn warnings on (via C<$^W> or C<perl -w>),
+and you see something like this...
+
+ attempt to seek on unopened filehandle
+
+...then you are probably trying to use one of these functions
+on an IO::Scalar with an old Perl. The remedy is to simply
+use the OO version; e.g.:
+
+ $SH->seek(0,0); ### GOOD: will work on any 5.005
+ seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond
+
+
+=head1 VERSION
+
+$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $
+
+
+=head1 AUTHORS
+
+=head2 Primary Maintainer
+
+David F. Skoll (F<dfs@roaringpenguin.com>).
+
+=head2 Principal author
+
+Eryq (F<eryq@zeegee.com>).
+President, ZeeGee Software Inc (F<http://www.zeegee.com>).
+
+
+=head2 Other contributors
+
+The full set of contributors always includes the folks mentioned
+in L<IO::Stringy/"CHANGE LOG">. But just the same, special
+thanks to the following individuals for their invaluable contributions
+(if I've forgotten or misspelled your name, please email me!):
+
+I<Andy Glew,>
+for contributing C<getc()>.
+
+I<Brandon Browning,>
+for suggesting C<opened()>.
+
+I<David Richter,>
+for finding and fixing the bug in C<PRINTF()>.
+
+I<Eric L. Brine,>
+for his offset-using read() and write() implementations.
+
+I<Richard Jones,>
+for his patches to massively improve the performance of C<getline()>
+and add C<sysread> and C<syswrite>.
+
+I<B. K. Oxley (binkley),>
+for stringification and inheritance improvements,
+and sundry good ideas.
+
+I<Doug Wilson,>
+for the IO::Handle inheritance and automatic tie-ing.
+
+
+=head1 SEE ALSO
+
+L<IO::String>, which is quite similar but which was designed
+more-recently and with an IO::Handle-like interface in mind,
+so you could mix OO- and native-filehandle usage without using tied().
+
+I<Note:> as of version 2.x, these classes all work like
+their IO::Handle counterparts, so we have comparable
+functionality to IO::String.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/IO/ScalarArray.pm b/Master/tlpkg/tlperl/lib/IO/ScalarArray.pm
new file mode 100755
index 00000000000..8877ce60472
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/ScalarArray.pm
@@ -0,0 +1,791 @@
+package IO::ScalarArray;
+
+
+=head1 NAME
+
+IO::ScalarArray - IO:: interface for reading/writing an array of scalars
+
+
+=head1 SYNOPSIS
+
+Perform I/O on strings, using the basic OO interface...
+
+ use IO::ScalarArray;
+ @data = ("My mes", "sage:\n");
+
+ ### Open a handle on an array, and append to it:
+ $AH = new IO::ScalarArray \@data;
+ $AH->print("Hello");
+ $AH->print(", world!\nBye now!\n");
+ print "The array is now: ", @data, "\n";
+
+ ### Open a handle on an array, read it line-by-line, then close it:
+ $AH = new IO::ScalarArray \@data;
+ while (defined($_ = $AH->getline)) {
+ print "Got line: $_";
+ }
+ $AH->close;
+
+ ### Open a handle on an array, and slurp in all the lines:
+ $AH = new IO::ScalarArray \@data;
+ print "All lines:\n", $AH->getlines;
+
+ ### Get the current position (either of two ways):
+ $pos = $AH->getpos;
+ $offset = $AH->tell;
+
+ ### Set the current position (either of two ways):
+ $AH->setpos($pos);
+ $AH->seek($offset, 0);
+
+ ### Open an anonymous temporary array:
+ $AH = new IO::ScalarArray;
+ $AH->print("Hi there!");
+ print "I printed: ", @{$AH->aref}, "\n"; ### get at value
+
+
+Don't like OO for your I/O? No problem.
+Thanks to the magic of an invisible tie(), the following now
+works out of the box, just as it does with IO::Handle:
+
+ use IO::ScalarArray;
+ @data = ("My mes", "sage:\n");
+
+ ### Open a handle on an array, and append to it:
+ $AH = new IO::ScalarArray \@data;
+ print $AH "Hello";
+ print $AH ", world!\nBye now!\n";
+ print "The array is now: ", @data, "\n";
+
+ ### Open a handle on a string, read it line-by-line, then close it:
+ $AH = new IO::ScalarArray \@data;
+ while (<$AH>) {
+ print "Got line: $_";
+ }
+ close $AH;
+
+ ### Open a handle on a string, and slurp in all the lines:
+ $AH = new IO::ScalarArray \@data;
+ print "All lines:\n", <$AH>;
+
+ ### Get the current position (WARNING: requires 5.6):
+ $offset = tell $AH;
+
+ ### Set the current position (WARNING: requires 5.6):
+ seek $AH, $offset, 0;
+
+ ### Open an anonymous temporary scalar:
+ $AH = new IO::ScalarArray;
+ print $AH "Hi there!";
+ print "I printed: ", @{$AH->aref}, "\n"; ### get at value
+
+
+And for you folks with 1.x code out there: the old tie() style still works,
+though this is I<unnecessary and deprecated>:
+
+ use IO::ScalarArray;
+
+ ### Writing to a scalar...
+ my @a;
+ tie *OUT, 'IO::ScalarArray', \@a;
+ print OUT "line 1\nline 2\n", "line 3\n";
+ print "Array is now: ", @a, "\n"
+
+ ### Reading and writing an anonymous scalar...
+ tie *OUT, 'IO::ScalarArray';
+ print OUT "line 1\nline 2\n", "line 3\n";
+ tied(OUT)->seek(0,0);
+ while (<OUT>) {
+ print "Got line: ", $_;
+ }
+
+
+
+=head1 DESCRIPTION
+
+This class is part of the IO::Stringy distribution;
+see L<IO::Stringy> for change log and general information.
+
+The IO::ScalarArray class implements objects which behave just like
+IO::Handle (or FileHandle) objects, except that you may use them
+to write to (or read from) arrays of scalars. Logically, an
+array of scalars defines an in-core "file" whose contents are
+the concatenation of the scalars in the array. The handles created by
+this class are automatically tiehandle'd (though please see L<"WARNINGS">
+for information relevant to your Perl version).
+
+For writing large amounts of data with individual print() statements,
+this class is likely to be more efficient than IO::Scalar.
+
+Basically, this:
+
+ my @a;
+ $AH = new IO::ScalarArray \@a;
+ $AH->print("Hel", "lo, "); ### OO style
+ $AH->print("world!\n"); ### ditto
+
+Or this:
+
+ my @a;
+ $AH = new IO::ScalarArray \@a;
+ print $AH "Hel", "lo, "; ### non-OO style
+ print $AH "world!\n"; ### ditto
+
+Causes @a to be set to the following array of 3 strings:
+
+ ( "Hel" ,
+ "lo, " ,
+ "world!\n" )
+
+See L<IO::Scalar> and compare with this class.
+
+
+=head1 PUBLIC INTERFACE
+
+=cut
+
+use Carp;
+use strict;
+use vars qw($VERSION @ISA);
+use IO::Handle;
+
+# The package version, both in 1.23 style *and* usable by MakeMaker:
+$VERSION = "2.110";
+
+# Inheritance:
+@ISA = qw(IO::Handle);
+require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
+
+
+#==============================
+
+=head2 Construction
+
+=over 4
+
+=cut
+
+#------------------------------
+
+=item new [ARGS...]
+
+I<Class method.>
+Return a new, unattached array handle.
+If any arguments are given, they're sent to open().
+
+=cut
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = bless \do { local *FH }, $class;
+ tie *$self, $class, $self;
+ $self->open(@_); ### open on anonymous by default
+ $self;
+}
+sub DESTROY {
+ shift->close;
+}
+
+
+#------------------------------
+
+=item open [ARRAYREF]
+
+I<Instance method.>
+Open the array handle on a new array, pointed to by ARRAYREF.
+If no ARRAYREF is given, a "private" array is created to hold
+the file data.
+
+Returns the self object on success, undefined on error.
+
+=cut
+
+sub open {
+ my ($self, $aref) = @_;
+
+ ### Sanity:
+ defined($aref) or do {my @a; $aref = \@a};
+ (ref($aref) eq "ARRAY") or croak "open needs a ref to a array";
+
+ ### Setup:
+ $self->setpos([0,0]);
+ *$self->{AR} = $aref;
+ $self;
+}
+
+#------------------------------
+
+=item opened
+
+I<Instance method.>
+Is the array handle opened on something?
+
+=cut
+
+sub opened {
+ *{shift()}->{AR};
+}
+
+#------------------------------
+
+=item close
+
+I<Instance method.>
+Disassociate the array handle from its underlying array.
+Done automatically on destroy.
+
+=cut
+
+sub close {
+ my $self = shift;
+ %{*$self} = ();
+ 1;
+}
+
+=back
+
+=cut
+
+
+
+#==============================
+
+=head2 Input and output
+
+=over 4
+
+=cut
+
+#------------------------------
+
+=item flush
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub flush { "0 but true" }
+
+#------------------------------
+
+=item getc
+
+I<Instance method.>
+Return the next character, or undef if none remain.
+This does a read(1), which is somewhat costly.
+
+=cut
+
+sub getc {
+ my $buf = '';
+ ($_[0]->read($buf, 1) ? $buf : undef);
+}
+
+#------------------------------
+
+=item getline
+
+I<Instance method.>
+Return the next line, or undef on end of data.
+Can safely be called in an array context.
+Currently, lines are delimited by "\n".
+
+=cut
+
+sub getline {
+ my $self = shift;
+ my ($str, $line) = (undef, '');
+
+
+ ### Minimal impact implementation!
+ ### We do the fast fast thing (no regexps) if using the
+ ### classic input record separator.
+
+ ### Case 1: $/ is undef: slurp all...
+ if (!defined($/)) {
+
+ return undef if ($self->eof);
+
+ ### Get the rest of the current string, followed by remaining strings:
+ my $ar = *$self->{AR};
+ my @slurp = (
+ substr($ar->[*$self->{Str}], *$self->{Pos}),
+ @$ar[(1 + *$self->{Str}) .. $#$ar ]
+ );
+
+ ### Seek to end:
+ $self->_setpos_to_eof;
+ return join('', @slurp);
+ }
+
+ ### Case 2: $/ is "\n":
+ elsif ($/ eq "\012") {
+
+ ### Until we hit EOF (or exitted because of a found line):
+ until ($self->eof) {
+ ### If at end of current string, go fwd to next one (won't be EOF):
+ if ($self->_eos) {++*$self->{Str}, *$self->{Pos}=0};
+
+ ### Get ref to current string in array, and set internal pos mark:
+ $str = \(*$self->{AR}[*$self->{Str}]); ### get current string
+ pos($$str) = *$self->{Pos}; ### start matching from here
+
+ ### Get from here to either \n or end of string, and add to line:
+ $$str =~ m/\G(.*?)((\n)|\Z)/g; ### match to 1st \n or EOS
+ $line .= $1.$2; ### add it
+ *$self->{Pos} += length($1.$2); ### move fwd by len matched
+ return $line if $3; ### done, got line with "\n"
+ }
+ return ($line eq '') ? undef : $line; ### return undef if EOF
+ }
+
+ ### Case 3: $/ is ref to int. Bail out.
+ elsif (ref($/)) {
+ croak '$/ given as a ref to int; currently unsupported';
+ }
+
+ ### Case 4: $/ is either "" (paragraphs) or something weird...
+ ### Bail for now.
+ else {
+ croak '$/ as given is currently unsupported';
+ }
+}
+
+#------------------------------
+
+=item getlines
+
+I<Instance method.>
+Get all remaining lines.
+It will croak() if accidentally called in a scalar context.
+
+=cut
+
+sub getlines {
+ my $self = shift;
+ wantarray or croak("can't call getlines in scalar context!");
+ my ($line, @lines);
+ push @lines, $line while (defined($line = $self->getline));
+ @lines;
+}
+
+#------------------------------
+
+=item print ARGS...
+
+I<Instance method.>
+Print ARGS to the underlying array.
+
+Currently, this always causes a "seek to the end of the array"
+and generates a new array entry. This may change in the future.
+
+=cut
+
+sub print {
+ my $self = shift;
+ push @{*$self->{AR}}, join('', @_) . (defined($\) ? $\ : ""); ### add the data
+ $self->_setpos_to_eof;
+ 1;
+}
+
+#------------------------------
+
+=item read BUF, NBYTES, [OFFSET];
+
+I<Instance method.>
+Read some bytes from the array.
+Returns the number of bytes actually read, 0 on end-of-file, undef on error.
+
+=cut
+
+sub read {
+ my $self = $_[0];
+ ### we must use $_[1] as a ref
+ my $n = $_[2];
+ my $off = $_[3] || 0;
+
+ ### print "getline\n";
+ my $justread;
+ my $len;
+ ($off ? substr($_[1], $off) : $_[1]) = '';
+
+ ### Stop when we have zero bytes to go, or when we hit EOF:
+ my @got;
+ until (!$n or $self->eof) {
+ ### If at end of current string, go forward to next one (won't be EOF):
+ if ($self->_eos) {
+ ++*$self->{Str};
+ *$self->{Pos} = 0;
+ }
+
+ ### Get longest possible desired substring of current string:
+ $justread = substr(*$self->{AR}[*$self->{Str}], *$self->{Pos}, $n);
+ $len = length($justread);
+ push @got, $justread;
+ $n -= $len;
+ *$self->{Pos} += $len;
+ }
+ $_[1] .= join('', @got);
+ return length($_[1])-$off;
+}
+
+#------------------------------
+
+=item write BUF, NBYTES, [OFFSET];
+
+I<Instance method.>
+Write some bytes into the array.
+
+=cut
+
+sub write {
+ my $self = $_[0];
+ my $n = $_[2];
+ my $off = $_[3] || 0;
+
+ my $data = substr($_[1], $n, $off);
+ $n = length($data);
+ $self->print($data);
+ return $n;
+}
+
+
+=back
+
+=cut
+
+
+
+#==============================
+
+=head2 Seeking/telling and other attributes
+
+=over 4
+
+=cut
+
+#------------------------------
+
+=item autoflush
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub autoflush {}
+
+#------------------------------
+
+=item binmode
+
+I<Instance method.>
+No-op, provided for OO compatibility.
+
+=cut
+
+sub binmode {}
+
+#------------------------------
+
+=item clearerr
+
+I<Instance method.> Clear the error and EOF flags. A no-op.
+
+=cut
+
+sub clearerr { 1 }
+
+#------------------------------
+
+=item eof
+
+I<Instance method.> Are we at end of file?
+
+=cut
+
+sub eof {
+ ### print "checking EOF [*$self->{Str}, *$self->{Pos}]\n";
+ ### print "SR = ", $#{*$self->{AR}}, "\n";
+
+ return 0 if (*{$_[0]}->{Str} < $#{*{$_[0]}->{AR}}); ### before EOA
+ return 1 if (*{$_[0]}->{Str} > $#{*{$_[0]}->{AR}}); ### after EOA
+ ### ### at EOA, past EOS:
+ ((*{$_[0]}->{Str} == $#{*{$_[0]}->{AR}}) && ($_[0]->_eos));
+}
+
+#------------------------------
+#
+# _eos
+#
+# I<Instance method, private.> Are we at end of the CURRENT string?
+#
+sub _eos {
+ (*{$_[0]}->{Pos} >= length(*{$_[0]}->{AR}[*{$_[0]}->{Str}])); ### past last char
+}
+
+#------------------------------
+
+=item seek POS,WHENCE
+
+I<Instance method.>
+Seek to a given position in the stream.
+Only a WHENCE of 0 (SEEK_SET) is supported.
+
+=cut
+
+sub seek {
+ my ($self, $pos, $whence) = @_;
+
+ ### Seek:
+ if ($whence == 0) { $self->_seek_set($pos); }
+ elsif ($whence == 1) { $self->_seek_cur($pos); }
+ elsif ($whence == 2) { $self->_seek_end($pos); }
+ else { croak "bad seek whence ($whence)" }
+ return 1;
+}
+
+#------------------------------
+#
+# _seek_set POS
+#
+# Instance method, private.
+# Seek to $pos relative to start:
+#
+sub _seek_set {
+ my ($self, $pos) = @_;
+
+ ### Advance through array until done:
+ my $istr = 0;
+ while (($pos >= 0) && ($istr < scalar(@{*$self->{AR}}))) {
+ if (length(*$self->{AR}[$istr]) > $pos) { ### it's in this string!
+ return $self->setpos([$istr, $pos]);
+ }
+ else { ### it's in next string
+ $pos -= length(*$self->{AR}[$istr++]); ### move forward one string
+ }
+ }
+ ### If we reached this point, pos is at or past end; zoom to EOF:
+ return $self->_setpos_to_eof;
+}
+
+#------------------------------
+#
+# _seek_cur POS
+#
+# Instance method, private.
+# Seek to $pos relative to current position.
+#
+sub _seek_cur {
+ my ($self, $pos) = @_;
+ $self->_seek_set($self->tell + $pos);
+}
+
+#------------------------------
+#
+# _seek_end POS
+#
+# Instance method, private.
+# Seek to $pos relative to end.
+# We actually seek relative to beginning, which is simple.
+#
+sub _seek_end {
+ my ($self, $pos) = @_;
+ $self->_seek_set($self->_tell_eof + $pos);
+}
+
+#------------------------------
+
+=item tell
+
+I<Instance method.>
+Return the current position in the stream, as a numeric offset.
+
+=cut
+
+sub tell {
+ my $self = shift;
+ my $off = 0;
+ my ($s, $str_s);
+ for ($s = 0; $s < *$self->{Str}; $s++) { ### count all "whole" scalars
+ defined($str_s = *$self->{AR}[$s]) or $str_s = '';
+ ###print STDERR "COUNTING STRING $s (". length($str_s) . ")\n";
+ $off += length($str_s);
+ }
+ ###print STDERR "COUNTING POS ($self->{Pos})\n";
+ return ($off += *$self->{Pos}); ### plus the final, partial one
+}
+
+#------------------------------
+#
+# _tell_eof
+#
+# Instance method, private.
+# Get position of EOF, as a numeric offset.
+# This is identical to the size of the stream - 1.
+#
+sub _tell_eof {
+ my $self = shift;
+ my $len = 0;
+ foreach (@{*$self->{AR}}) { $len += length($_) }
+ $len;
+}
+
+#------------------------------
+
+=item setpos POS
+
+I<Instance method.>
+Seek to a given position in the array, using the opaque getpos() value.
+Don't expect this to be a number.
+
+=cut
+
+sub setpos {
+ my ($self, $pos) = @_;
+ (ref($pos) eq 'ARRAY') or
+ die "setpos: only use a value returned by getpos!\n";
+ (*$self->{Str}, *$self->{Pos}) = @$pos;
+}
+
+#------------------------------
+#
+# _setpos_to_eof
+#
+# Fast-forward to EOF.
+#
+sub _setpos_to_eof {
+ my $self = shift;
+ $self->setpos([scalar(@{*$self->{AR}}), 0]);
+}
+
+#------------------------------
+
+=item getpos
+
+I<Instance method.>
+Return the current position in the array, as an opaque value.
+Don't expect this to be a number.
+
+=cut
+
+sub getpos {
+ [*{$_[0]}->{Str}, *{$_[0]}->{Pos}];
+}
+
+#------------------------------
+
+=item aref
+
+I<Instance method.>
+Return a reference to the underlying array.
+
+=cut
+
+sub aref {
+ *{shift()}->{AR};
+}
+
+=back
+
+=cut
+
+#------------------------------
+# Tied handle methods...
+#------------------------------
+
+### Conventional tiehandle interface:
+sub TIEHANDLE { (defined($_[1]) && UNIVERSAL::isa($_[1],"IO::ScalarArray"))
+ ? $_[1]
+ : shift->new(@_) }
+sub GETC { shift->getc(@_) }
+sub PRINT { shift->print(@_) }
+sub PRINTF { shift->print(sprintf(shift, @_)) }
+sub READ { shift->read(@_) }
+sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
+sub WRITE { shift->write(@_); }
+sub CLOSE { shift->close(@_); }
+sub SEEK { shift->seek(@_); }
+sub TELL { shift->tell(@_); }
+sub EOF { shift->eof(@_); }
+
+#------------------------------------------------------------
+
+1;
+__END__
+
+# SOME PRIVATE NOTES:
+#
+# * The "current position" is the position before the next
+# character to be read/written.
+#
+# * Str gives the string index of the current position, 0-based
+#
+# * Pos gives the offset within AR[Str], 0-based.
+#
+# * Inital pos is [0,0]. After print("Hello"), it is [1,0].
+
+
+
+=head1 WARNINGS
+
+Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
+it was missing support for C<seek()>, C<tell()>, and C<eof()>.
+Attempting to use these functions with an IO::ScalarArray will not work
+prior to 5.005_57. IO::ScalarArray will not have the relevant methods
+invoked; and even worse, this kind of bug can lie dormant for a while.
+If you turn warnings on (via C<$^W> or C<perl -w>),
+and you see something like this...
+
+ attempt to seek on unopened filehandle
+
+...then you are probably trying to use one of these functions
+on an IO::ScalarArray with an old Perl. The remedy is to simply
+use the OO version; e.g.:
+
+ $AH->seek(0,0); ### GOOD: will work on any 5.005
+ seek($AH,0,0); ### WARNING: will only work on 5.005_57 and beyond
+
+
+
+=head1 VERSION
+
+$Id: ScalarArray.pm,v 1.7 2005/02/10 21:21:53 dfs Exp $
+
+
+=head1 AUTHOR
+
+=head2 Primary Maintainer
+
+David F. Skoll (F<dfs@roaringpenguin.com>).
+
+=head2 Principal author
+
+Eryq (F<eryq@zeegee.com>).
+President, ZeeGee Software Inc (F<http://www.zeegee.com>).
+
+
+=head2 Other contributors
+
+Thanks to the following individuals for their invaluable contributions
+(if I've forgotten or misspelled your name, please email me!):
+
+I<Andy Glew,>
+for suggesting C<getc()>.
+
+I<Brandon Browning,>
+for suggesting C<opened()>.
+
+I<Eric L. Brine,>
+for his offset-using read() and write() implementations.
+
+I<Doug Wilson,>
+for the IO::Handle inheritance and automatic tie-ing.
+
+=cut
+
+#------------------------------
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Seekable.pm b/Master/tlpkg/tlperl/lib/IO/Seekable.pm
new file mode 100755
index 00000000000..db1effda287
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Seekable.pm
@@ -0,0 +1,128 @@
+#
+
+package IO::Seekable;
+
+=head1 NAME
+
+IO::Seekable - supply seek based methods for I/O objects
+
+=head1 SYNOPSIS
+
+ use IO::Seekable;
+ package IO::Something;
+ @ISA = qw(IO::Seekable);
+
+=head1 DESCRIPTION
+
+C<IO::Seekable> does not have a constructor of its own as it is intended to
+be inherited by other C<IO::Handle> based objects. It provides methods
+which allow seeking of the file descriptors.
+
+=over 4
+
+=item $io->getpos
+
+Returns an opaque value that represents the current position of the
+IO::File, or C<undef> if this is not possible (eg an unseekable stream such
+as a terminal, pipe or socket). If the fgetpos() function is available in
+your C library it is used to implements getpos, else perl emulates getpos
+using C's ftell() function.
+
+=item $io->setpos
+
+Uses the value of a previous getpos call to return to a previously visited
+position. Returns "0 but true" on success, C<undef> on failure.
+
+=back
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Seekable> methods, which are just front ends for the
+corresponding built-in functions:
+
+=over 4
+
+=item $io->seek ( POS, WHENCE )
+
+Seek the IO::File to position POS, relative to WHENCE:
+
+=over 8
+
+=item WHENCE=0 (SEEK_SET)
+
+POS is absolute position. (Seek relative to the start of the file)
+
+=item WHENCE=1 (SEEK_CUR)
+
+POS is an offset from the current position. (Seek relative to current)
+
+=item WHENCE=2 (SEEK_END)
+
+POS is an offset from the end of the file. (Seek relative to end)
+
+=back
+
+The SEEK_* constants can be imported from the C<Fcntl> module if you
+don't wish to use the numbers C<0> C<1> or C<2> in your code.
+
+Returns C<1> upon success, C<0> otherwise.
+
+=item $io->sysseek( POS, WHENCE )
+
+Similar to $io->seek, but sets the IO::File's position using the system
+call lseek(2) directly, so will confuse most perl IO operators except
+sysread and syswrite (see L<perlfunc> for full details)
+
+Returns the new position, or C<undef> on failure. A position
+of zero is returned as the string C<"0 but true">
+
+=item $io->tell
+
+Returns the IO::File's current position, or -1 on error.
+
+=back
+
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<IO::Handle>
+L<IO::File>
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt>
+
+=cut
+
+use 5.006_001;
+use Carp;
+use strict;
+our($VERSION, @EXPORT, @ISA);
+use IO::Handle ();
+# XXX we can't get these from IO::Handle or we'll get prototype
+# mismatch warnings on C<use POSIX; use IO::File;> :-(
+use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END);
+require Exporter;
+
+@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
+@ISA = qw(Exporter);
+
+$VERSION = "1.10";
+$VERSION = eval $VERSION;
+
+sub seek {
+ @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)';
+ seek($_[0], $_[1], $_[2]);
+}
+
+sub sysseek {
+ @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)';
+ sysseek($_[0], $_[1], $_[2]);
+}
+
+sub tell {
+ @_ == 1 or croak 'usage: $io->tell()';
+ tell($_[0]);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/IO/Select.pm b/Master/tlpkg/tlperl/lib/IO/Select.pm
new file mode 100755
index 00000000000..fc05fe70e9c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Select.pm
@@ -0,0 +1,381 @@
+# IO::Select.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Select;
+
+use strict;
+use warnings::register;
+use vars qw($VERSION @ISA);
+require Exporter;
+
+$VERSION = "1.17";
+
+@ISA = qw(Exporter); # This is only so we can do version checking
+
+sub VEC_BITS () {0}
+sub FD_COUNT () {1}
+sub FIRST_FD () {2}
+
+sub new
+{
+ my $self = shift;
+ my $type = ref($self) || $self;
+
+ my $vec = bless [undef,0], $type;
+
+ $vec->add(@_)
+ if @_;
+
+ $vec;
+}
+
+sub add
+{
+ shift->_update('add', @_);
+}
+
+
+sub remove
+{
+ shift->_update('remove', @_);
+}
+
+
+sub exists
+{
+ my $vec = shift;
+ my $fno = $vec->_fileno(shift);
+ return undef unless defined $fno;
+ $vec->[$fno + FIRST_FD];
+}
+
+
+sub _fileno
+{
+ my($self, $f) = @_;
+ return unless defined $f;
+ $f = $f->[0] if ref($f) eq 'ARRAY';
+ ($f =~ /^\d+$/) ? $f : fileno($f);
+}
+
+sub _update
+{
+ my $vec = shift;
+ my $add = shift eq 'add';
+
+ my $bits = $vec->[VEC_BITS];
+ $bits = '' unless defined $bits;
+
+ my $count = 0;
+ my $f;
+ foreach $f (@_)
+ {
+ my $fn = $vec->_fileno($f);
+ next unless defined $fn;
+ my $i = $fn + FIRST_FD;
+ if ($add) {
+ if (defined $vec->[$i]) {
+ $vec->[$i] = $f; # if array rest might be different, so we update
+ next;
+ }
+ $vec->[FD_COUNT]++;
+ vec($bits, $fn, 1) = 1;
+ $vec->[$i] = $f;
+ } else { # remove
+ next unless defined $vec->[$i];
+ $vec->[FD_COUNT]--;
+ vec($bits, $fn, 1) = 0;
+ $vec->[$i] = undef;
+ }
+ $count++;
+ }
+ $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
+ $count;
+}
+
+sub can_read
+{
+ my $vec = shift;
+ my $timeout = shift;
+ my $r = $vec->[VEC_BITS];
+
+ defined($r) && (select($r,undef,undef,$timeout) > 0)
+ ? handles($vec, $r)
+ : ();
+}
+
+sub can_write
+{
+ my $vec = shift;
+ my $timeout = shift;
+ my $w = $vec->[VEC_BITS];
+
+ defined($w) && (select(undef,$w,undef,$timeout) > 0)
+ ? handles($vec, $w)
+ : ();
+}
+
+sub has_exception
+{
+ my $vec = shift;
+ my $timeout = shift;
+ my $e = $vec->[VEC_BITS];
+
+ defined($e) && (select(undef,undef,$e,$timeout) > 0)
+ ? handles($vec, $e)
+ : ();
+}
+
+sub has_error
+{
+ warnings::warn("Call to deprecated method 'has_error', use 'has_exception'")
+ if warnings::enabled();
+ goto &has_exception;
+}
+
+sub count
+{
+ my $vec = shift;
+ $vec->[FD_COUNT];
+}
+
+sub bits
+{
+ my $vec = shift;
+ $vec->[VEC_BITS];
+}
+
+sub as_string # for debugging
+{
+ my $vec = shift;
+ my $str = ref($vec) . ": ";
+ my $bits = $vec->bits;
+ my $count = $vec->count;
+ $str .= defined($bits) ? unpack("b*", $bits) : "undef";
+ $str .= " $count";
+ my @handles = @$vec;
+ splice(@handles, 0, FIRST_FD);
+ for (@handles) {
+ $str .= " " . (defined($_) ? "$_" : "-");
+ }
+ $str;
+}
+
+sub _max
+{
+ my($a,$b,$c) = @_;
+ $a > $b
+ ? $a > $c
+ ? $a
+ : $c
+ : $b > $c
+ ? $b
+ : $c;
+}
+
+sub select
+{
+ shift
+ if defined $_[0] && !ref($_[0]);
+
+ my($r,$w,$e,$t) = @_;
+ my @result = ();
+
+ my $rb = defined $r ? $r->[VEC_BITS] : undef;
+ my $wb = defined $w ? $w->[VEC_BITS] : undef;
+ my $eb = defined $e ? $e->[VEC_BITS] : undef;
+
+ if(select($rb,$wb,$eb,$t) > 0)
+ {
+ my @r = ();
+ my @w = ();
+ my @e = ();
+ my $i = _max(defined $r ? scalar(@$r)-1 : 0,
+ defined $w ? scalar(@$w)-1 : 0,
+ defined $e ? scalar(@$e)-1 : 0);
+
+ for( ; $i >= FIRST_FD ; $i--)
+ {
+ my $j = $i - FIRST_FD;
+ push(@r, $r->[$i])
+ if defined $rb && defined $r->[$i] && vec($rb, $j, 1);
+ push(@w, $w->[$i])
+ if defined $wb && defined $w->[$i] && vec($wb, $j, 1);
+ push(@e, $e->[$i])
+ if defined $eb && defined $e->[$i] && vec($eb, $j, 1);
+ }
+
+ @result = (\@r, \@w, \@e);
+ }
+ @result;
+}
+
+
+sub handles
+{
+ my $vec = shift;
+ my $bits = shift;
+ my @h = ();
+ my $i;
+ my $max = scalar(@$vec) - 1;
+
+ for ($i = FIRST_FD; $i <= $max; $i++)
+ {
+ next unless defined $vec->[$i];
+ push(@h, $vec->[$i])
+ if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
+ }
+
+ @h;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+IO::Select - OO interface to the select system call
+
+=head1 SYNOPSIS
+
+ use IO::Select;
+
+ $s = IO::Select->new();
+
+ $s->add(\*STDIN);
+ $s->add($some_handle);
+
+ @ready = $s->can_read($timeout);
+
+ @ready = IO::Select->new(@handles)->can_read(0);
+
+=head1 DESCRIPTION
+
+The C<IO::Select> package implements an object approach to the system C<select>
+function call. It allows the user to see what IO handles, see L<IO::Handle>,
+are ready for reading, writing or have an exception pending.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HANDLES ] )
+
+The constructor creates a new object and optionally initialises it with a set
+of handles.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item add ( HANDLES )
+
+Add the list of handles to the C<IO::Select> object. It is these values that
+will be returned when an event occurs. C<IO::Select> keeps these values in a
+cache which is indexed by the C<fileno> of the handle, so if more than one
+handle with the same C<fileno> is specified then only the last one is cached.
+
+Each handle can be an C<IO::Handle> object, an integer or an array
+reference where the first element is an C<IO::Handle> or an integer.
+
+=item remove ( HANDLES )
+
+Remove all the given handles from the object. This method also works
+by the C<fileno> of the handles. So the exact handles that were added
+need not be passed, just handles that have an equivalent C<fileno>
+
+=item exists ( HANDLE )
+
+Returns a true value (actually the handle itself) if it is present.
+Returns undef otherwise.
+
+=item handles
+
+Return an array of all registered handles.
+
+=item can_read ( [ TIMEOUT ] )
+
+Return an array of handles that are ready for reading. C<TIMEOUT> is
+the maximum amount of time to wait before returning an empty list, in
+seconds, possibly fractional. If C<TIMEOUT> is not given and any
+handles are registered then the call will block.
+
+=item can_write ( [ TIMEOUT ] )
+
+Same as C<can_read> except check for handles that can be written to.
+
+=item has_exception ( [ TIMEOUT ] )
+
+Same as C<can_read> except check for handles that have an exception
+condition, for example pending out-of-band data.
+
+=item count ()
+
+Returns the number of handles that the object will check for when
+one of the C<can_> methods is called or the object is passed to
+the C<select> static method.
+
+=item bits()
+
+Return the bit string suitable as argument to the core select() call.
+
+=item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] )
+
+C<select> is a static method, that is you call it with the package name
+like C<new>. C<READ>, C<WRITE> and C<EXCEPTION> are either C<undef> or
+C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as
+for the core select call.
+
+The result will be an array of 3 elements, each a reference to an array
+which will hold the handles that are ready for reading, writing and have
+exceptions respectively. Upon error an empty list is returned.
+
+=back
+
+=head1 EXAMPLE
+
+Here is a short example which shows how C<IO::Select> could be used
+to write a server which communicates with several sockets while also
+listening for more connections on a listen socket
+
+ use IO::Select;
+ use IO::Socket;
+
+ $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
+ $sel = new IO::Select( $lsn );
+
+ while(@ready = $sel->can_read) {
+ foreach $fh (@ready) {
+ if($fh == $lsn) {
+ # Create a new socket
+ $new = $lsn->accept;
+ $sel->add($new);
+ }
+ else {
+ # Process socket
+
+ # Maybe we have finished with the socket
+ $sel->remove($fh);
+ $fh->close;
+ }
+ }
+ }
+
+=head1 AUTHOR
+
+Graham Barr. Currently maintained by the Perl Porters. Please report all
+bugs to <perl5-porters@perl.org>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Socket.pm b/Master/tlpkg/tlperl/lib/IO/Socket.pm
new file mode 100755
index 00000000000..2ef05a72fa7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Socket.pm
@@ -0,0 +1,529 @@
+# IO::Socket.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Socket;
+
+require 5.006;
+
+use IO::Handle;
+use Socket 1.3;
+use Carp;
+use strict;
+our(@ISA, $VERSION, @EXPORT_OK);
+use Exporter;
+use Errno;
+
+# legacy
+
+require IO::Socket::INET;
+require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
+
+@ISA = qw(IO::Handle);
+
+$VERSION = "1.31";
+
+@EXPORT_OK = qw(sockatmark);
+
+sub import {
+ my $pkg = shift;
+ if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast
+ Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark');
+ } else {
+ my $callpkg = caller;
+ Exporter::export 'Socket', $callpkg, @_;
+ }
+}
+
+sub new {
+ my($class,%arg) = @_;
+ my $sock = $class->SUPER::new();
+
+ $sock->autoflush(1);
+
+ ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
+
+ return scalar(%arg) ? $sock->configure(\%arg)
+ : $sock;
+}
+
+my @domain2pkg;
+
+sub register_domain {
+ my($p,$d) = @_;
+ $domain2pkg[$d] = $p;
+}
+
+sub configure {
+ my($sock,$arg) = @_;
+ my $domain = delete $arg->{Domain};
+
+ croak 'IO::Socket: Cannot configure a generic socket'
+ unless defined $domain;
+
+ croak "IO::Socket: Unsupported socket domain"
+ unless defined $domain2pkg[$domain];
+
+ croak "IO::Socket: Cannot configure socket in domain '$domain'"
+ unless ref($sock) eq "IO::Socket";
+
+ bless($sock, $domain2pkg[$domain]);
+ $sock->configure($arg);
+}
+
+sub socket {
+ @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
+ my($sock,$domain,$type,$protocol) = @_;
+
+ socket($sock,$domain,$type,$protocol) or
+ return undef;
+
+ ${*$sock}{'io_socket_domain'} = $domain;
+ ${*$sock}{'io_socket_type'} = $type;
+ ${*$sock}{'io_socket_proto'} = $protocol;
+
+ $sock;
+}
+
+sub socketpair {
+ @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
+ my($class,$domain,$type,$protocol) = @_;
+ my $sock1 = $class->new();
+ my $sock2 = $class->new();
+
+ socketpair($sock1,$sock2,$domain,$type,$protocol) or
+ return ();
+
+ ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type;
+ ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
+
+ ($sock1,$sock2);
+}
+
+sub connect {
+ @_ == 2 or croak 'usage: $sock->connect(NAME)';
+ my $sock = shift;
+ my $addr = shift;
+ my $timeout = ${*$sock}{'io_socket_timeout'};
+ my $err;
+ my $blocking;
+
+ $blocking = $sock->blocking(0) if $timeout;
+ if (!connect($sock, $addr)) {
+ if (defined $timeout && ($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
+ require IO::Select;
+
+ my $sel = new IO::Select $sock;
+
+ undef $!;
+ if (!$sel->can_write($timeout)) {
+ $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
+ $@ = "connect: timeout";
+ }
+ elsif (!connect($sock,$addr) &&
+ not ($!{EISCONN} || ($! == 10022 && $^O eq 'MSWin32'))
+ ) {
+ # Some systems refuse to re-connect() to
+ # an already open socket and set errno to EISCONN.
+ # Windows sets errno to WSAEINVAL (10022)
+ $err = $!;
+ $@ = "connect: $!";
+ }
+ }
+ elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
+ $err = $!;
+ $@ = "connect: $!";
+ }
+ }
+
+ $sock->blocking(1) if $blocking;
+
+ $! = $err if $err;
+
+ $err ? undef : $sock;
+}
+
+# Enable/disable blocking IO on sockets.
+# Without args return the current status of blocking,
+# with args change the mode as appropriate, returning the
+# old setting, or in case of error during the mode change
+# undef.
+
+sub blocking {
+ my $sock = shift;
+
+ return $sock->SUPER::blocking(@_)
+ if $^O ne 'MSWin32';
+
+ # Windows handles blocking differently
+ #
+ # http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
+ # http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp
+ #
+ # 0x8004667e is FIONBIO
+ #
+ # which is used to set blocking behaviour.
+
+ # NOTE:
+ # This is a little confusing, the perl keyword for this is
+ # 'blocking' but the OS level behaviour is 'non-blocking', probably
+ # because sockets are blocking by default.
+ # Therefore internally we have to reverse the semantics.
+
+ my $orig= !${*$sock}{io_sock_nonblocking};
+
+ return $orig unless @_;
+
+ my $block = shift;
+
+ if ( !$block != !$orig ) {
+ ${*$sock}{io_sock_nonblocking} = $block ? 0 : 1;
+ ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking}))
+ or return undef;
+ }
+
+ return $orig;
+}
+
+
+sub close {
+ @_ == 1 or croak 'usage: $sock->close()';
+ my $sock = shift;
+ ${*$sock}{'io_socket_peername'} = undef;
+ $sock->SUPER::close();
+}
+
+sub bind {
+ @_ == 2 or croak 'usage: $sock->bind(NAME)';
+ my $sock = shift;
+ my $addr = shift;
+
+ return bind($sock, $addr) ? $sock
+ : undef;
+}
+
+sub listen {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
+ my($sock,$queue) = @_;
+ $queue = 5
+ unless $queue && $queue > 0;
+
+ return listen($sock, $queue) ? $sock
+ : undef;
+}
+
+sub accept {
+ @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
+ my $sock = shift;
+ my $pkg = shift || $sock;
+ my $timeout = ${*$sock}{'io_socket_timeout'};
+ my $new = $pkg->new(Timeout => $timeout);
+ my $peer = undef;
+
+ if(defined $timeout) {
+ require IO::Select;
+
+ my $sel = new IO::Select $sock;
+
+ unless ($sel->can_read($timeout)) {
+ $@ = 'accept: timeout';
+ $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
+ return;
+ }
+ }
+
+ $peer = accept($new,$sock)
+ or return;
+
+ return wantarray ? ($new, $peer)
+ : $new;
+}
+
+sub sockname {
+ @_ == 1 or croak 'usage: $sock->sockname()';
+ getsockname($_[0]);
+}
+
+sub peername {
+ @_ == 1 or croak 'usage: $sock->peername()';
+ my($sock) = @_;
+ ${*$sock}{'io_socket_peername'} ||= getpeername($sock);
+}
+
+sub connected {
+ @_ == 1 or croak 'usage: $sock->connected()';
+ my($sock) = @_;
+ getpeername($sock);
+}
+
+sub send {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
+ my $sock = $_[0];
+ my $flags = $_[2] || 0;
+ my $peer = $_[3] || $sock->peername;
+
+ croak 'send: Cannot determine peer address'
+ unless(defined $peer);
+
+ my $r = defined(getpeername($sock))
+ ? send($sock, $_[1], $flags)
+ : send($sock, $_[1], $flags, $peer);
+
+ # remember who we send to, if it was successful
+ ${*$sock}{'io_socket_peername'} = $peer
+ if(@_ == 4 && defined $r);
+
+ $r;
+}
+
+sub recv {
+ @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
+ my $sock = $_[0];
+ my $len = $_[2];
+ my $flags = $_[3] || 0;
+
+ # remember who we recv'd from
+ ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
+}
+
+sub shutdown {
+ @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
+ my($sock, $how) = @_;
+ ${*$sock}{'io_socket_peername'} = undef;
+ shutdown($sock, $how);
+}
+
+sub setsockopt {
+ @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
+ setsockopt($_[0],$_[1],$_[2],$_[3]);
+}
+
+my $intsize = length(pack("i",0));
+
+sub getsockopt {
+ @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
+ my $r = getsockopt($_[0],$_[1],$_[2]);
+ # Just a guess
+ $r = unpack("i", $r)
+ if(defined $r && length($r) == $intsize);
+ $r;
+}
+
+sub sockopt {
+ my $sock = shift;
+ @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
+ : $sock->setsockopt(SOL_SOCKET,@_);
+}
+
+sub atmark {
+ @_ == 1 or croak 'usage: $sock->atmark()';
+ my($sock) = @_;
+ sockatmark($sock);
+}
+
+sub timeout {
+ @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
+ my($sock,$val) = @_;
+ my $r = ${*$sock}{'io_socket_timeout'};
+
+ ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
+ if(@_ == 2);
+
+ $r;
+}
+
+sub sockdomain {
+ @_ == 1 or croak 'usage: $sock->sockdomain()';
+ my $sock = shift;
+ ${*$sock}{'io_socket_domain'};
+}
+
+sub socktype {
+ @_ == 1 or croak 'usage: $sock->socktype()';
+ my $sock = shift;
+ ${*$sock}{'io_socket_type'}
+}
+
+sub protocol {
+ @_ == 1 or croak 'usage: $sock->protocol()';
+ my($sock) = @_;
+ ${*$sock}{'io_socket_proto'};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Socket - Object interface to socket communications
+
+=head1 SYNOPSIS
+
+ use IO::Socket;
+
+=head1 DESCRIPTION
+
+C<IO::Socket> provides an object interface to creating and using sockets. It
+is built upon the L<IO::Handle> interface and inherits all the methods defined
+by L<IO::Handle>.
+
+C<IO::Socket> only defines methods for those operations which are common to all
+types of socket. Operations which are specified to a socket in a particular
+domain have methods defined in sub classes of C<IO::Socket>
+
+C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ARGS] )
+
+Creates an C<IO::Socket>, which is a reference to a
+newly created symbol (see the C<Symbol> package). C<new>
+optionally takes arguments, these arguments are in key-value pairs.
+C<new> only looks for one key C<Domain> which tells new which domain
+the socket will be in. All other arguments will be passed to the
+configuration method of the package for that domain, See below.
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+As of VERSION 1.18 all IO::Socket objects have autoflush turned on
+by default. This was not the case with earlier releases.
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+=back
+
+=head1 METHODS
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Socket> methods, which are just front ends for the
+corresponding built-in functions:
+
+ socket
+ socketpair
+ bind
+ listen
+ accept
+ send
+ recv
+ peername (getpeername)
+ sockname (getsockname)
+ shutdown
+
+Some methods take slightly different arguments to those defined in L<perlfunc>
+in attempt to make the interface more flexible. These are
+
+=over 4
+
+=item accept([PKG])
+
+perform the system call C<accept> on the socket and return a new
+object. The new object will be created in the same class as the listen
+socket, unless C<PKG> is specified. This object can be used to
+communicate with the client that was trying to connect.
+
+In a scalar context the new socket is returned, or undef upon
+failure. In a list context a two-element array is returned containing
+the new socket and the peer address; the list will be empty upon
+failure.
+
+The timeout in the [PKG] can be specified as zero to effect a "poll",
+but you shouldn't do that because a new IO::Select object will be
+created behind the scenes just to do the single poll. This is
+horrendously inefficient. Use rather true select() with a zero
+timeout on the handle, or non-blocking IO.
+
+=item socketpair(DOMAIN, TYPE, PROTOCOL)
+
+Call C<socketpair> and return a list of two sockets created, or an
+empty list on failure.
+
+=back
+
+Additional methods that are provided are:
+
+=over 4
+
+=item atmark
+
+True if the socket is currently positioned at the urgent data mark,
+false otherwise.
+
+ use IO::Socket;
+
+ my $sock = IO::Socket::INET->new('some_server');
+ $sock->read($data, 1024) until $sock->atmark;
+
+Note: this is a reasonably new addition to the family of socket
+functions, so all systems may not support this yet. If it is
+unsupported by the system, an attempt to use this method will
+abort the program.
+
+The atmark() functionality is also exportable as sockatmark() function:
+
+ use IO::Socket 'sockatmark';
+
+This allows for a more traditional use of sockatmark() as a procedural
+socket function. If your system does not support sockatmark(), the
+C<use> declaration will fail at compile time.
+
+=item connected
+
+If the socket is in a connected state the peer address is returned.
+If the socket is not in a connected state then undef will be returned.
+
+=item protocol
+
+Returns the numerical number for the protocol being used on the socket, if
+known. If the protocol is unknown, as with an AF_UNIX socket, zero
+is returned.
+
+=item sockdomain
+
+Returns the numerical number for the socket domain type. For example, for
+an AF_INET socket the value of &AF_INET will be returned.
+
+=item sockopt(OPT [, VAL])
+
+Unified method to both set and get options in the SOL_SOCKET level. If called
+with one argument then getsockopt is called, otherwise setsockopt is called.
+
+=item socktype
+
+Returns the numerical number for the socket type. For example, for
+a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
+
+=item timeout([VAL])
+
+Set or get the timeout value associated with this socket. If called without
+any arguments then the current setting is returned. If called with an argument
+the current setting is changed and the previous value returned.
+
+=back
+
+=head1 SEE ALSO
+
+L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
+
+=head1 AUTHOR
+
+Graham Barr. atmark() by Lincoln Stein. Currently maintained by the
+Perl Porters. Please report all bugs to <perl5-porters@perl.org>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>.
+This module is distributed under the same terms as Perl itself.
+Feel free to use, modify and redistribute it as long as you retain
+the correct attribution.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/IO/Socket/INET.pm b/Master/tlpkg/tlperl/lib/IO/Socket/INET.pm
new file mode 100755
index 00000000000..2f0e5d1d7a6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Socket/INET.pm
@@ -0,0 +1,464 @@
+# IO::Socket::INET.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Socket::INET;
+
+use strict;
+our(@ISA, $VERSION);
+use IO::Socket;
+use Socket;
+use Carp;
+use Exporter;
+use Errno;
+
+@ISA = qw(IO::Socket);
+$VERSION = "1.31";
+
+my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
+
+IO::Socket::INET->register_domain( AF_INET );
+
+my %socket_type = ( tcp => SOCK_STREAM,
+ udp => SOCK_DGRAM,
+ icmp => SOCK_RAW
+ );
+my %proto_number;
+$proto_number{tcp} = Socket::IPPROTO_TCP() if defined &Socket::IPPROTO_TCP;
+$proto_number{udp} = Socket::IPPROTO_UDP() if defined &Socket::IPPROTO_UDP;
+$proto_number{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
+my %proto_name = reverse %proto_number;
+
+sub new {
+ my $class = shift;
+ unshift(@_, "PeerAddr") if @_ == 1;
+ return $class->SUPER::new(@_);
+}
+
+sub _cache_proto {
+ my @proto = @_;
+ for (map lc($_), $proto[0], split(' ', $proto[1])) {
+ $proto_number{$_} = $proto[2];
+ }
+ $proto_name{$proto[2]} = $proto[0];
+}
+
+sub _get_proto_number {
+ my $name = lc(shift);
+ return undef unless defined $name;
+ return $proto_number{$name} if exists $proto_number{$name};
+
+ my @proto = getprotobyname($name);
+ return undef unless @proto;
+ _cache_proto(@proto);
+
+ return $proto[2];
+}
+
+sub _get_proto_name {
+ my $num = shift;
+ return undef unless defined $num;
+ return $proto_name{$num} if exists $proto_name{$num};
+
+ my @proto = getprotobynumber($num);
+ return undef unless @proto;
+ _cache_proto(@proto);
+
+ return $proto[0];
+}
+
+sub _sock_info {
+ my($addr,$port,$proto) = @_;
+ my $origport = $port;
+ my @serv = ();
+
+ $port = $1
+ if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
+
+ if(defined $proto && $proto =~ /\D/) {
+ my $num = _get_proto_number($proto);
+ unless (defined $num) {
+ $@ = "Bad protocol '$proto'";
+ return;
+ }
+ $proto = $num;
+ }
+
+ if(defined $port) {
+ my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef;
+ my $pnum = ($port =~ m,^(\d+)$,)[0];
+
+ @serv = getservbyname($port, _get_proto_name($proto) || "")
+ if ($port =~ m,\D,);
+
+ $port = $serv[2] || $defport || $pnum;
+ unless (defined $port) {
+ $@ = "Bad service '$origport'";
+ return;
+ }
+
+ $proto = _get_proto_number($serv[3]) if @serv && !$proto;
+ }
+
+ return ($addr || undef,
+ $port || undef,
+ $proto || undef
+ );
+}
+
+sub _error {
+ my $sock = shift;
+ my $err = shift;
+ {
+ local($!);
+ my $title = ref($sock).": ";
+ $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_);
+ $sock->close()
+ if(defined fileno($sock));
+ }
+ $! = $err;
+ return undef;
+}
+
+sub _get_addr {
+ my($sock,$addr_str, $multi) = @_;
+ my @addr;
+ if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) {
+ (undef, undef, undef, undef, @addr) = gethostbyname($addr_str);
+ } else {
+ my $h = inet_aton($addr_str);
+ push(@addr, $h) if defined $h;
+ }
+ @addr;
+}
+
+sub configure {
+ my($sock,$arg) = @_;
+ my($lport,$rport,$laddr,$raddr,$proto,$type);
+
+
+ $arg->{LocalAddr} = $arg->{LocalHost}
+ if exists $arg->{LocalHost} && !exists $arg->{LocalAddr};
+
+ ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
+ $arg->{LocalPort},
+ $arg->{Proto})
+ or return _error($sock, $!, $@);
+
+ $laddr = defined $laddr ? inet_aton($laddr)
+ : INADDR_ANY;
+
+ return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'")
+ unless(defined $laddr);
+
+ $arg->{PeerAddr} = $arg->{PeerHost}
+ if exists $arg->{PeerHost} && !exists $arg->{PeerAddr};
+
+ unless(exists $arg->{Listen}) {
+ ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
+ $arg->{PeerPort},
+ $proto)
+ or return _error($sock, $!, $@);
+ }
+
+ $proto ||= _get_proto_number('tcp');
+
+ $type = $arg->{Type} || $socket_type{lc _get_proto_name($proto)};
+
+ my @raddr = ();
+
+ if(defined $raddr) {
+ @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
+ return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
+ unless @raddr;
+ }
+
+ while(1) {
+
+ $sock->socket(AF_INET, $type, $proto) or
+ return _error($sock, $!, "$!");
+
+ if (defined $arg->{Blocking}) {
+ defined $sock->blocking($arg->{Blocking})
+ or return _error($sock, $!, "$!");
+ }
+
+ if ($arg->{Reuse} || $arg->{ReuseAddr}) {
+ $sock->sockopt(SO_REUSEADDR,1) or
+ return _error($sock, $!, "$!");
+ }
+
+ if ($arg->{ReusePort}) {
+ $sock->sockopt(SO_REUSEPORT,1) or
+ return _error($sock, $!, "$!");
+ }
+
+ if ($arg->{Broadcast}) {
+ $sock->sockopt(SO_BROADCAST,1) or
+ return _error($sock, $!, "$!");
+ }
+
+ if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) {
+ $sock->bind($lport || 0, $laddr) or
+ return _error($sock, $!, "$!");
+ }
+
+ if(exists $arg->{Listen}) {
+ $sock->listen($arg->{Listen} || 5) or
+ return _error($sock, $!, "$!");
+ last;
+ }
+
+ # don't try to connect unless we're given a PeerAddr
+ last unless exists($arg->{PeerAddr});
+
+ $raddr = shift @raddr;
+
+ return _error($sock, $EINVAL, 'Cannot determine remote port')
+ unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
+
+ last
+ unless($type == SOCK_STREAM || defined $raddr);
+
+ return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
+ unless defined $raddr;
+
+# my $timeout = ${*$sock}{'io_socket_timeout'};
+# my $before = time() if $timeout;
+
+ undef $@;
+ if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
+# ${*$sock}{'io_socket_timeout'} = $timeout;
+ return $sock;
+ }
+
+ return _error($sock, $!, $@ || "Timeout")
+ unless @raddr;
+
+# if ($timeout) {
+# my $new_timeout = $timeout - (time() - $before);
+# return _error($sock,
+# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
+# "Timeout") if $new_timeout <= 0;
+# ${*$sock}{'io_socket_timeout'} = $new_timeout;
+# }
+
+ }
+
+ $sock;
+}
+
+sub connect {
+ @_ == 2 || @_ == 3 or
+ croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)';
+ my $sock = shift;
+ return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_));
+}
+
+sub bind {
+ @_ == 2 || @_ == 3 or
+ croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)';
+ my $sock = shift;
+ return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_))
+}
+
+sub sockaddr {
+ @_ == 1 or croak 'usage: $sock->sockaddr()';
+ my($sock) = @_;
+ my $name = $sock->sockname;
+ $name ? (sockaddr_in($name))[1] : undef;
+}
+
+sub sockport {
+ @_ == 1 or croak 'usage: $sock->sockport()';
+ my($sock) = @_;
+ my $name = $sock->sockname;
+ $name ? (sockaddr_in($name))[0] : undef;
+}
+
+sub sockhost {
+ @_ == 1 or croak 'usage: $sock->sockhost()';
+ my($sock) = @_;
+ my $addr = $sock->sockaddr;
+ $addr ? inet_ntoa($addr) : undef;
+}
+
+sub peeraddr {
+ @_ == 1 or croak 'usage: $sock->peeraddr()';
+ my($sock) = @_;
+ my $name = $sock->peername;
+ $name ? (sockaddr_in($name))[1] : undef;
+}
+
+sub peerport {
+ @_ == 1 or croak 'usage: $sock->peerport()';
+ my($sock) = @_;
+ my $name = $sock->peername;
+ $name ? (sockaddr_in($name))[0] : undef;
+}
+
+sub peerhost {
+ @_ == 1 or croak 'usage: $sock->peerhost()';
+ my($sock) = @_;
+ my $addr = $sock->peeraddr;
+ $addr ? inet_ntoa($addr) : undef;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Socket::INET - Object interface for AF_INET domain sockets
+
+=head1 SYNOPSIS
+
+ use IO::Socket::INET;
+
+=head1 DESCRIPTION
+
+C<IO::Socket::INET> provides an object interface to creating and using sockets
+in the AF_INET domain. It is built upon the L<IO::Socket> interface and
+inherits all the methods defined by L<IO::Socket>.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ARGS] )
+
+Creates an C<IO::Socket::INET> object, which is a reference to a
+newly created symbol (see the C<Symbol> package). C<new>
+optionally takes arguments, these arguments are in key-value pairs.
+
+In addition to the key-value pairs accepted by L<IO::Socket>,
+C<IO::Socket::INET> provides.
+
+
+ PeerAddr Remote host address <hostname>[:<port>]
+ PeerHost Synonym for PeerAddr
+ PeerPort Remote port or service <service>[(<no>)] | <no>
+ LocalAddr Local host bind address hostname[:port]
+ LocalHost Synonym for LocalAddr
+ LocalPort Local host bind port <service>[(<no>)] | <no>
+ Proto Protocol name (or number) "tcp" | "udp" | ...
+ Type Socket type SOCK_STREAM | SOCK_DGRAM | ...
+ Listen Queue size for listen
+ ReuseAddr Set SO_REUSEADDR before binding
+ Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr)
+ ReusePort Set SO_REUSEPORT before binding
+ Broadcast Set SO_BROADCAST before binding
+ Timeout Timeout value for various operations
+ MultiHomed Try all addresses for multi-homed hosts
+ Blocking Determine if connection will be blocking mode
+
+If C<Listen> is defined then a listen socket is created, else if the
+socket type, which is derived from the protocol, is SOCK_STREAM then
+connect() is called.
+
+Although it is not illegal, the use of C<MultiHomed> on a socket
+which is in non-blocking mode is of little use. This is because the
+first connect will never fail with a timeout as the connect call
+will not block.
+
+The C<PeerAddr> can be a hostname or the IP-address on the
+"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic
+service name. The service name might be followed by a number in
+parenthesis which is used if the service is not known by the system.
+The C<PeerPort> specification can also be embedded in the C<PeerAddr>
+by preceding it with a ":".
+
+If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
+then the constructor will try to derive C<Proto> from the service
+name. As a last resort C<Proto> "tcp" is assumed. The C<Type>
+parameter will be deduced from C<Proto> if not specified.
+
+If the constructor is only passed a single argument, it is assumed to
+be a C<PeerAddr> specification.
+
+If C<Blocking> is set to 0, the connection will be in nonblocking mode.
+If not specified it defaults to 1 (blocking mode).
+
+Examples:
+
+ $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
+ PeerPort => 'http(80)',
+ Proto => 'tcp');
+
+ $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
+
+ $sock = IO::Socket::INET->new(Listen => 5,
+ LocalAddr => 'localhost',
+ LocalPort => 9000,
+ Proto => 'tcp');
+
+ $sock = IO::Socket::INET->new('127.0.0.1:25');
+
+ $sock = IO::Socket::INET->new(PeerPort => 9999,
+ PeerAddr => inet_ntoa(INADDR_BROADCAST),
+ Proto => udp,
+ LocalAddr => 'localhost',
+ Broadcast => 1 )
+ or die "Can't bind : $@\n";
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+As of VERSION 1.18 all IO::Socket objects have autoflush turned on
+by default. This was not the case with earlier releases.
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+=back
+
+=head2 METHODS
+
+=over 4
+
+=item sockaddr ()
+
+Return the address part of the sockaddr structure for the socket
+
+=item sockport ()
+
+Return the port number that the socket is using on the local host
+
+=item sockhost ()
+
+Return the address part of the sockaddr structure for the socket in a
+text form xx.xx.xx.xx
+
+=item peeraddr ()
+
+Return the address part of the sockaddr structure for the socket on
+the peer host
+
+=item peerport ()
+
+Return the port number for the socket on the peer host.
+
+=item peerhost ()
+
+Return the address part of the sockaddr structure for the socket on the
+peer host in a text form xx.xx.xx.xx
+
+=back
+
+=head1 SEE ALSO
+
+L<Socket>, L<IO::Socket>
+
+=head1 AUTHOR
+
+Graham Barr. Currently maintained by the Perl Porters. Please report all
+bugs to <perl5-porters@perl.org>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/IO/Socket/SSL.pm b/Master/tlpkg/tlperl/lib/IO/Socket/SSL.pm
new file mode 100755
index 00000000000..bcf098f58f3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Socket/SSL.pm
@@ -0,0 +1,2303 @@
+#!/usr/bin/perl -w
+#
+# IO::Socket::SSL:
+# a drop-in replacement for IO::Socket::INET that encapsulates
+# data passed over a network with SSL.
+#
+# Current Code Shepherd: Steffen Ullrich <steffen at genua.de>
+# Code Shepherd before: Peter Behroozi, <behrooz at fas.harvard.edu>
+#
+# The original version of this module was written by
+# Marko Asplund, <marko.asplund at kronodoc.fi>, who drew from
+# Crypt::SSLeay (Net::SSL) by Gisle Aas.
+#
+
+package IO::Socket::SSL;
+
+use IO::Socket;
+use Net::SSLeay 1.21;
+use Exporter ();
+use Errno qw( EAGAIN ETIMEDOUT );
+use Carp;
+use strict;
+
+use constant {
+ SSL_VERIFY_NONE => Net::SSLeay::VERIFY_NONE(),
+ SSL_VERIFY_PEER => Net::SSLeay::VERIFY_PEER(),
+ SSL_VERIFY_FAIL_IF_NO_PEER_CERT => Net::SSLeay::VERIFY_FAIL_IF_NO_PEER_CERT(),
+ SSL_VERIFY_CLIENT_ONCE => Net::SSLeay::VERIFY_CLIENT_ONCE(),
+ # from openssl/ssl.h, should be better in Net::SSLeay
+ SSL_SENT_SHUTDOWN => 1,
+ SSL_RECEIVED_SHUTDOWN => 2,
+};
+
+
+
+# non-XS Versions of Scalar::Util will fail
+BEGIN{
+ eval { use Scalar::Util 'dualvar'; dualvar(0,'') };
+ die "You need the XS Version of Scalar::Util for dualvar() support"
+ if $@;
+}
+
+use vars qw(@ISA $VERSION $DEBUG $SSL_ERROR $GLOBAL_CONTEXT_ARGS @EXPORT );
+
+{
+ # These constants will be used in $! at return from SSL_connect,
+ # SSL_accept, generic_read and write, thus notifying the caller
+ # the usual way of problems. Like with EAGAIN, EINPROGRESS..
+ # these are especially important for non-blocking sockets
+
+ my $x = Net::SSLeay::ERROR_WANT_READ();
+ use constant SSL_WANT_READ => dualvar( \$x, 'SSL wants a read first' );
+ my $y = Net::SSLeay::ERROR_WANT_WRITE();
+ use constant SSL_WANT_WRITE => dualvar( \$y, 'SSL wants a write first' );
+
+ @EXPORT = qw(
+ SSL_WANT_READ SSL_WANT_WRITE SSL_VERIFY_NONE SSL_VERIFY_PEER
+ SSL_VERIFY_FAIL_IF_NO_PEER_CERT SSL_VERIFY_CLIENT_ONCE
+ $SSL_ERROR GEN_DNS GEN_IPADD
+ );
+}
+
+my @caller_force_inet4; # in case inet4 gets forced we store here who forced it
+my $can_ipv6; # true if we successfully enabled ipv6 while loading
+
+BEGIN {
+ # Declare @ISA, $VERSION, $GLOBAL_CONTEXT_ARGS
+
+ # if we have IO::Socket::INET6 we will use this not IO::Socket::INET, because
+ # it can handle both IPv4 and IPv6. If we don't have INET6 available fall back
+ # to INET
+ if ( ! eval {
+ require Socket6;
+ Socket6->import( 'inet_pton' );
+ require IO::Socket::INET6;
+ @ISA = qw(IO::Socket::INET6);
+ $can_ipv6 = 1;
+ }) {
+ @ISA = qw(IO::Socket::INET);
+ }
+ $VERSION = '1.31';
+ $GLOBAL_CONTEXT_ARGS = {};
+
+ #Make $DEBUG another name for $Net::SSLeay::trace
+ *DEBUG = \$Net::SSLeay::trace;
+
+ #Compability
+ *ERROR = \$SSL_ERROR;
+
+ # Do Net::SSLeay initialization
+ Net::SSLeay::load_error_strings();
+ Net::SSLeay::SSLeay_add_ssl_algorithms();
+ Net::SSLeay::randomize();
+}
+
+sub DEBUG {
+ $DEBUG>=shift or return; # check against debug level
+ my (undef,$file,$line) = caller;
+ my $msg = shift;
+ $file = '...'.substr( $file,-17 ) if length($file)>20;
+ $msg = sprintf $msg,@_ if @_;
+ print STDERR "DEBUG: $file:$line: $msg\n";
+}
+
+BEGIN {
+ # import some constants from Net::SSLeay or use hard-coded defaults
+ # if Net::SSLeay isn't recent enough to provide the constants
+ my %const = (
+ NID_CommonName => 13,
+ GEN_DNS => 2,
+ GEN_IPADD => 7,
+ );
+ while ( my ($name,$value) = each %const ) {
+ no strict 'refs';
+ *{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
+ }
+
+ # check if we have something to handle IDN
+ local $SIG{__DIE__}; local $SIG{__WARN__}; # be silent
+ if ( eval { require Net::IDN::Encode }) {
+ *{idn_to_ascii} = \&Net::IDN::Encode::domain_to_ascii;
+ } elsif ( eval { require Net::LibIDN }) {
+ *{idn_to_ascii} = \&Net::LibIDN::idn_to_ascii;
+ } else {
+ # default: croak if we really got an unencoded international domain
+ *{idn_to_ascii} = sub {
+ my $domain = shift;
+ return $domain if $domain =~m{^[a-zA-Z0-9-_\.]+$};
+ croak "cannot handle international domains, please install Net::LibIDN or Net::IDN::Encode"
+ }
+ }
+}
+
+# Export some stuff
+# inet4|inet6|debug will be handeled by myself, everything
+# else will be handeld the Exporter way
+sub import {
+ my $class = shift;
+
+ my @export;
+ foreach (@_) {
+ if ( /^inet4$/i ) {
+ # explicitly fall back to inet4
+ @ISA = 'IO::Socket::INET';
+ @caller_force_inet4 = caller(); # save for warnings for 'inet6' case
+ } elsif ( /^inet6$/i ) {
+ # check if we have already ipv6 as base
+ if ( ! UNIVERSAL::isa( $class, 'IO::Socket::INET6' )) {
+ # either we don't support it or we disabled it by explicitly
+ # loading it with 'inet4'. In this case re-enable but warn
+ # because this is probably an error
+ if ( $can_ipv6 ) {
+ @ISA = 'IO::Socket::INET6';
+ warn "IPv6 support re-enabled in __PACKAGE__, got disabled in file $caller_force_inet4[1] line $caller_force_inet4[2]";
+ } else {
+ die "INET6 is not supported, missing Socket6 or IO::Socket::INET6";
+ }
+ }
+ } elsif ( /^:?debug(\d+)/ ) {
+ $DEBUG=$1;
+ } else {
+ push @export,$_
+ }
+ }
+
+ @_ = ( $class,@export );
+ goto &Exporter::import;
+}
+
+# You might be expecting to find a new() subroutine here, but that is
+# not how IO::Socket::INET works. All configuration gets performed in
+# the calls to configure() and either connect() or accept().
+
+#Call to configure occurs when a new socket is made using
+#IO::Socket::INET. Returns false (empty list) on failure.
+sub configure {
+ my ($self, $arg_hash) = @_;
+ return _invalid_object() unless($self);
+
+ # work around Bug in IO::Socket::INET6 where it doesn't use the
+ # right family for the socket on BSD systems:
+ # http://rt.cpan.org/Ticket/Display.html?id=39550
+ if ( $can_ipv6 && ! $arg_hash->{Domain} &&
+ ! ( $arg_hash->{LocalAddr} || $arg_hash->{LocalHost} ) &&
+ (my $peer = $arg_hash->{PeerAddr} || $arg_hash->{PeerHost})) {
+ # set Domain to AF_INET/AF_INET6 if there is only one choice
+ ($peer, my $port) = IO::Socket::INET6::_sock_info( $peer,$arg_hash->{PeerPort},6 );
+ my @res = Socket6::getaddrinfo( $peer,$port,AF_UNSPEC,SOCK_STREAM );
+ if (@res == 5) {
+ $arg_hash->{Domain} = $res[0];
+ DEBUG(2,'set domain to '.$res[0] );
+ }
+ }
+
+ # force initial blocking
+ # otherwise IO::Socket::SSL->new might return undef if the
+ # socket is nonblocking and it fails to connect immediatly
+ # for real nonblocking behavior one should create a nonblocking
+ # socket and later call connect explicitly
+ my $blocking = delete $arg_hash->{Blocking};
+
+ # because Net::HTTPS simple redefines blocking() to {} (e.g
+ # return undef) and IO::Socket::INET does not like this we
+
+ # set Blocking only explicitly if it was set
+ $arg_hash->{Blocking} = 1 if defined ($blocking);
+
+ $self->configure_SSL($arg_hash) || return;
+
+ $self->SUPER::configure($arg_hash)
+ || return $self->error("@ISA configuration failed");
+
+ $self->blocking(0) if defined $blocking && !$blocking;
+ return $self;
+}
+
+sub configure_SSL {
+ my ($self, $arg_hash) = @_;
+
+ my $is_server = $arg_hash->{'SSL_server'} || $arg_hash->{'Listen'} || 0;
+
+ my %default_args = (
+ Proto => 'tcp',
+ SSL_server => $is_server,
+ SSL_use_cert => $is_server,
+ SSL_check_crl => 0,
+ SSL_version => 'sslv23',
+ SSL_verify_mode => SSL_VERIFY_NONE,
+ SSL_verify_callback => undef,
+ SSL_verifycn_scheme => undef, # don't verify cn
+ SSL_verifycn_name => undef, # use from PeerAddr/PeerHost
+ );
+
+ # common problem forgetting SSL_use_cert
+ # if client cert is given but SSL_use_cert undef assume that it
+ # should be set
+ if ( ! $is_server && ! defined $arg_hash->{SSL_use_cert}
+ && ( grep { $arg_hash->{$_} } qw(SSL_cert SSL_cert_file))
+ && ( grep { $arg_hash->{$_} } qw(SSL_key SSL_key_file)) ) {
+ $arg_hash->{SSL_use_cert} = 1
+ }
+
+ # SSL_key_file and SSL_cert_file will only be set in defaults if
+ # SSL_key|SSL_key_file resp SSL_cert|SSL_cert_file are not set in
+ # $args_hash
+ foreach my $k (qw( key cert )) {
+ next if exists $arg_hash->{ "SSL_${k}" };
+ next if exists $arg_hash->{ "SSL_${k}_file" };
+ $default_args{ "SSL_${k}_file" } = $is_server
+ ? "certs/server-${k}.pem"
+ : "certs/client-${k}.pem";
+ }
+
+ # add only SSL_ca_* if not in args
+ if ( ! exists $arg_hash->{SSL_ca_file} && ! exists $arg_hash->{SSL_ca_path} ) {
+ if ( -f 'certs/my-ca.pem' ) {
+ $default_args{SSL_ca_file} = 'certs/my-ca.pem'
+ } elsif ( -d 'ca/' ) {
+ $default_args{SSL_ca_path} = 'ca/'
+ }
+ }
+
+ #Replace nonexistent entries with defaults
+ %$arg_hash = ( %default_args, %$GLOBAL_CONTEXT_ARGS, %$arg_hash );
+
+ #Avoid passing undef arguments to Net::SSLeay
+ defined($arg_hash->{$_}) or delete($arg_hash->{$_}) foreach (keys %$arg_hash);
+
+ my $vcn_scheme = delete $arg_hash->{SSL_verifycn_scheme};
+ if ( $vcn_scheme && $vcn_scheme ne 'none' ) {
+ # don't access ${*self} inside callback - this seems to create
+ # circular references from the ssl object to the context and back
+
+ # use SSL_verifycn_name or determine from PeerAddr
+ my $host = $arg_hash->{SSL_verifycn_name};
+ if (not defined($host)) {
+ if ( $host = $arg_hash->{PeerAddr} || $arg_hash->{PeerHost} ) {
+ $host =~s{:[a-zA-Z0-9_\-]+$}{};
+ }
+ }
+ $host ||= ref($vcn_scheme) && $vcn_scheme->{callback} && 'unknown';
+ $host or return $self->error( "Cannot determine peer hostname for verification" );
+
+ my $vcb = $arg_hash->{SSL_verify_callback};
+ $arg_hash->{SSL_verify_callback} = sub {
+ my ($ok,$ctx_store,$certname,$error,$cert) = @_;
+ $ok = $vcb->($ok,$ctx_store,$certname,$error,$cert) if $vcb;
+ $ok or return;
+ my $depth = Net::SSLeay::X509_STORE_CTX_get_error_depth($ctx_store);
+ return $ok if $depth != 0;
+
+ # verify name
+ my $rv = verify_hostname_of_cert( $host,$cert,$vcn_scheme );
+ # just do some code here against optimization because x509 has no
+ # increased reference and CRYPTO_add is not available from Net::SSLeay
+ return $rv;
+ };
+ }
+
+ ${*$self}{'_SSL_arguments'} = $arg_hash;
+ ${*$self}{'_SSL_ctx'} = IO::Socket::SSL::SSL_Context->new($arg_hash) || return;
+ ${*$self}{'_SSL_opened'} = 1 if $is_server;
+
+ return $self;
+}
+
+
+sub _set_rw_error {
+ my ($self,$ssl,$rv) = @_;
+ my $err = Net::SSLeay::get_error($ssl,$rv);
+ $SSL_ERROR =
+ $err == Net::SSLeay::ERROR_WANT_READ() ? SSL_WANT_READ :
+ $err == Net::SSLeay::ERROR_WANT_WRITE() ? SSL_WANT_WRITE :
+ return;
+ $! ||= EAGAIN;
+ ${*$self}{'_SSL_last_err'} = $SSL_ERROR if ref($self);
+ return 1;
+}
+
+
+#Call to connect occurs when a new client socket is made using
+#IO::Socket::INET
+sub connect {
+ my $self = shift || return _invalid_object();
+ return $self if ${*$self}{'_SSL_opened'}; # already connected
+
+ if ( ! ${*$self}{'_SSL_opening'} ) {
+ # call SUPER::connect if the underlying socket is not connected
+ # if this fails this might not be an error (e.g. if $! = EINPROGRESS
+ # and socket is nonblocking this is normal), so keep any error
+ # handling to the client
+ DEBUG(2, 'socket not yet connected' );
+ $self->SUPER::connect(@_) || return;
+ DEBUG(2,'socket connected' );
+ }
+ return $self->connect_SSL;
+}
+
+
+sub connect_SSL {
+ my $self = shift;
+ my $args = @_>1 ? {@_}: $_[0]||{};
+
+ my ($ssl,$ctx);
+ if ( ! ${*$self}{'_SSL_opening'} ) {
+ # start ssl connection
+ DEBUG(2,'ssl handshake not started' );
+ ${*$self}{'_SSL_opening'} = 1;
+ my $arg_hash = ${*$self}{'_SSL_arguments'};
+
+ my $fileno = ${*$self}{'_SSL_fileno'} = fileno($self);
+ return $self->error("Socket has no fileno") unless (defined $fileno);
+
+ $ctx = ${*$self}{'_SSL_ctx'}; # Reference to real context
+ $ssl = ${*$self}{'_SSL_object'} = Net::SSLeay::new($ctx->{context})
+ || return $self->error("SSL structure creation failed");
+
+ Net::SSLeay::set_fd($ssl, $fileno)
+ || return $self->error("SSL filehandle association failed");
+
+ if ( my $cl = $arg_hash->{SSL_cipher_list} ) {
+ Net::SSLeay::set_cipher_list($ssl, $cl )
+ || return $self->error("Failed to set SSL cipher list");
+ }
+
+ $arg_hash->{PeerAddr} || $self->_update_peer;
+ my $session = $ctx->session_cache( $arg_hash->{PeerAddr}, $arg_hash->{PeerPort} );
+ Net::SSLeay::set_session($ssl, $session) if ($session);
+ }
+
+ $ssl ||= ${*$self}{'_SSL_object'};
+
+ $SSL_ERROR = undef;
+ my $timeout = exists $args->{Timeout}
+ ? $args->{Timeout}
+ : ${*$self}{io_socket_timeout}; # from IO::Socket
+ if ( defined($timeout) && $timeout>0 && $self->blocking(0) ) {
+ DEBUG(2, "set socket to non-blocking to enforce timeout=$timeout" );
+ # timeout was given and socket was blocking
+ # enforce timeout with now non-blocking socket
+ } else {
+ # timeout does not apply because invalid or socket non-blocking
+ $timeout = undef;
+ }
+
+ my $start = defined($timeout) && time();
+ for my $dummy (1) {
+ #DEBUG( 'calling ssleay::connect' );
+ my $rv = Net::SSLeay::connect($ssl);
+ DEBUG( 3,"Net::SSLeay::connect -> $rv" );
+ if ( $rv < 0 ) {
+ unless ( $self->_set_rw_error( $ssl,$rv )) {
+ $self->error("SSL connect attempt failed with unknown error");
+ delete ${*$self}{'_SSL_opening'};
+ ${*$self}{'_SSL_opened'} = -1;
+ DEBUG(1, "fatal SSL error: $SSL_ERROR" );
+ return $self->fatal_ssl_error();
+ }
+
+ DEBUG(2,'ssl handshake in progress' );
+ # connect failed because handshake needs to be completed
+ # if socket was non-blocking or no timeout was given return with this error
+ return if ! defined($timeout);
+
+ # wait until socket is readable or writable
+ my $rv;
+ if ( $timeout>0 ) {
+ my $vec = '';
+ vec($vec,$self->fileno,1) = 1;
+ DEBUG(2, "waiting for fd to become ready: $SSL_ERROR" );
+ $rv =
+ $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) :
+ $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) :
+ undef;
+ } else {
+ DEBUG(2,"handshake failed because no more time" );
+ $! = ETIMEDOUT
+ }
+ if ( ! $rv ) {
+ DEBUG(2,"handshake failed because socket did not became ready" );
+ # failed because of timeout, return
+ $! ||= ETIMEDOUT;
+ delete ${*$self}{'_SSL_opening'};
+ ${*$self}{'_SSL_opened'} = -1;
+ $self->blocking(1); # was blocking before
+ return
+ }
+
+ # socket is ready, try non-blocking connect again after recomputing timeout
+ DEBUG(2,"socket ready, retrying connect" );
+ my $now = time();
+ $timeout -= $now - $start;
+ $start = $now;
+ redo;
+
+ } elsif ( $rv == 0 ) {
+ delete ${*$self}{'_SSL_opening'};
+ DEBUG(2,"connection failed - connect returned 0" );
+ $self->error("SSL connect attempt failed because of handshake problems" );
+ ${*$self}{'_SSL_opened'} = -1;
+ return $self->fatal_ssl_error();
+ }
+ }
+
+ DEBUG(2,'ssl handshake done' );
+ # ssl connect successful
+ delete ${*$self}{'_SSL_opening'};
+ ${*$self}{'_SSL_opened'}=1;
+ $self->blocking(1) if defined($timeout); # was blocking before
+
+ $ctx ||= ${*$self}{'_SSL_ctx'};
+ if ( $ctx->has_session_cache ) {
+ my $arg_hash = ${*$self}{'_SSL_arguments'};
+ $arg_hash->{PeerAddr} || $self->_update_peer;
+ my ($addr,$port) = ( $arg_hash->{PeerAddr}, $arg_hash->{PeerPort} );
+ my $session = $ctx->session_cache( $addr,$port );
+ $ctx->session_cache( $addr,$port, Net::SSLeay::get1_session($ssl) ) if !$session;
+ }
+
+ tie *{$self}, "IO::Socket::SSL::SSL_HANDLE", $self;
+
+ return $self;
+}
+
+# called if PeerAddr is not set in ${*$self}{'_SSL_arguments'}
+# this can be the case if start_SSL is called with a normal IO::Socket::INET
+# so that PeerAddr|PeerPort are not set from args
+sub _update_peer {
+ my $self = shift;
+ my $arg_hash = ${*$self}{'_SSL_arguments'};
+ eval {
+ my ($port,$addr) = sockaddr_in( getpeername( $self ));
+ $arg_hash->{PeerAddr} = inet_ntoa( $addr );
+ $arg_hash->{PeerPort} = $port;
+ }
+}
+
+#Call to accept occurs when a new client connects to a server using
+#IO::Socket::SSL
+sub accept {
+ my $self = shift || return _invalid_object();
+ my $class = shift || 'IO::Socket::SSL';
+
+ my $socket = ${*$self}{'_SSL_opening'};
+ if ( ! $socket ) {
+ # underlying socket not done
+ DEBUG(2,'no socket yet' );
+ $socket = $self->SUPER::accept($class) || return;
+ DEBUG(2,'accept created normal socket '.$socket );
+ }
+
+ $self->accept_SSL($socket) || return;
+ DEBUG(2,'accept_SSL ok' );
+
+ return wantarray ? ($socket, getpeername($socket) ) : $socket;
+}
+
+sub accept_SSL {
+ my $self = shift;
+ my $socket = ( @_ && UNIVERSAL::isa( $_[0], 'IO::Handle' )) ? shift : $self;
+ my $args = @_>1 ? {@_}: $_[0]||{};
+
+ my $ssl;
+ if ( ! ${*$self}{'_SSL_opening'} ) {
+ DEBUG(2,'starting sslifying' );
+ ${*$self}{'_SSL_opening'} = $socket;
+ my $arg_hash = ${*$self}{'_SSL_arguments'};
+ ${*$socket}{'_SSL_arguments'} = { %$arg_hash, SSL_server => 0 };
+ my $ctx = ${*$socket}{'_SSL_ctx'} = ${*$self}{'_SSL_ctx'};
+
+ my $fileno = ${*$socket}{'_SSL_fileno'} = fileno($socket);
+ return $socket->error("Socket has no fileno") unless (defined $fileno);
+
+ $ssl = ${*$socket}{'_SSL_object'} = Net::SSLeay::new($ctx->{context})
+ || return $socket->error("SSL structure creation failed");
+
+ Net::SSLeay::set_fd($ssl, $fileno)
+ || return $socket->error("SSL filehandle association failed");
+
+ if ( my $cl = $arg_hash->{SSL_cipher_list} ) {
+ Net::SSLeay::set_cipher_list($ssl, $cl )
+ || return $socket->error("Failed to set SSL cipher list");
+ }
+ }
+
+ $ssl ||= ${*$socket}{'_SSL_object'};
+
+ $SSL_ERROR = undef;
+ #DEBUG(2,'calling ssleay::accept' );
+
+ my $timeout = exists $args->{Timeout}
+ ? $args->{Timeout}
+ : ${*$self}{io_socket_timeout}; # from IO::Socket
+ if ( defined($timeout) && $timeout>0 && $socket->blocking(0) ) {
+ # timeout was given and socket was blocking
+ # enforce timeout with now non-blocking socket
+ } else {
+ # timeout does not apply because invalid or socket non-blocking
+ $timeout = undef;
+ }
+
+ my $start = defined($timeout) && time();
+ for my $dummy (1) {
+ my $rv = Net::SSLeay::accept($ssl);
+ DEBUG(3, "Net::SSLeay::accept -> $rv" );
+ if ( $rv < 0 ) {
+ unless ( $socket->_set_rw_error( $ssl,$rv )) {
+ $socket->error("SSL accept attempt failed with unknown error");
+ delete ${*$self}{'_SSL_opening'};
+ ${*$socket}{'_SSL_opened'} = -1;
+ return $socket->fatal_ssl_error();
+ }
+
+ # accept failed because handshake needs to be completed
+ # if socket was non-blocking or no timeout was given return with this error
+ return if ! defined($timeout);
+
+ # wait until socket is readable or writable
+ my $rv;
+ if ( $timeout>0 ) {
+ my $vec = '';
+ vec($vec,$socket->fileno,1) = 1;
+ $rv =
+ $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) :
+ $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) :
+ undef;
+ } else {
+ $! = ETIMEDOUT
+ }
+ if ( ! $rv ) {
+ # failed because of timeout, return
+ $! ||= ETIMEDOUT;
+ delete ${*$self}{'_SSL_opening'};
+ ${*$socket}{'_SSL_opened'} = -1;
+ $socket->blocking(1); # was blocking before
+ return
+ }
+
+ # socket is ready, try non-blocking accept again after recomputing timeout
+ my $now = time();
+ $timeout -= $now - $start;
+ $start = $now;
+ redo;
+
+ } elsif ( $rv == 0 ) {
+ $socket->error("SSL connect accept failed because of handshake problems" );
+ delete ${*$self}{'_SSL_opening'};
+ ${*$socket}{'_SSL_opened'} = -1;
+ return $socket->fatal_ssl_error();
+ }
+ }
+
+ DEBUG(2,'handshake done, socket ready' );
+ # socket opened
+ delete ${*$self}{'_SSL_opening'};
+ ${*$socket}{'_SSL_opened'} = 1;
+ $socket->blocking(1) if defined($timeout); # was blocking before
+
+ tie *{$socket}, "IO::Socket::SSL::SSL_HANDLE", $socket;
+
+ return $socket;
+}
+
+
+####### I/O subroutines ########################
+
+sub generic_read {
+ my ($self, $read_func, undef, $length, $offset) = @_;
+ my $ssl = $self->_get_ssl_object || return;
+ my $buffer=\$_[2];
+
+ $SSL_ERROR = undef;
+ my $data = $read_func->($ssl, $length);
+ if ( !defined($data)) {
+ $self->_set_rw_error( $ssl,-1 ) || $self->error("SSL read error");
+ return;
+ }
+
+ $length = length($data);
+ $$buffer = '' if !defined $$buffer;
+ $offset ||= 0;
+ if ($offset>length($$buffer)) {
+ $$buffer.="\0" x ($offset-length($$buffer)); #mimic behavior of read
+ }
+
+ substr($$buffer, $offset, length($$buffer), $data);
+ return $length;
+}
+
+sub read {
+ my $self = shift;
+ return $self->generic_read(
+ $self->blocking ? \&Net::SSLeay::ssl_read_all : \&Net::SSLeay::read,
+ @_
+ );
+}
+
+# contrary to the behavior of read sysread can read partial data
+sub sysread {
+ my $self = shift;
+ return $self->generic_read( \&Net::SSLeay::read, @_ );
+}
+
+sub peek {
+ my $self = shift;
+ if (Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x0090601f) {
+ return $self->generic_read(\&Net::SSLeay::peek, @_);
+ } else {
+ return $self->error("SSL_peek not supported for OpenSSL < v0.9.6a");
+ }
+}
+
+
+sub generic_write {
+ my ($self, $write_all, undef, $length, $offset) = @_;
+
+ my $ssl = $self->_get_ssl_object || return;
+ my $buffer = \$_[2];
+
+ my $buf_len = length($$buffer);
+ $length ||= $buf_len;
+ $offset ||= 0;
+ return $self->error("Invalid offset for SSL write") if ($offset>$buf_len);
+ return 0 if ($offset == $buf_len);
+
+ $SSL_ERROR = undef;
+ my $written;
+ if ( $write_all ) {
+ my $data = $length < $buf_len-$offset ? substr($$buffer, $offset, $length) : $$buffer;
+ ($written, my $errs) = Net::SSLeay::ssl_write_all($ssl, $data);
+ # ssl_write_all returns number of bytes written
+ $written = undef if ! $written && $errs;
+ } else {
+ $written = Net::SSLeay::write_partial( $ssl,$offset,$length,$$buffer );
+ # write_partial does SSL_write which returns -1 on error
+ $written = undef if $written < 0;
+ }
+ if ( !defined($written) ) {
+ $self->_set_rw_error( $ssl,-1 )
+ || $self->error("SSL write error");
+ return;
+ }
+
+ return $written;
+}
+
+# if socket is blocking write() should return only on error or
+# if all data are written
+sub write {
+ my $self = shift;
+ return $self->generic_write( scalar($self->blocking),@_ );
+}
+
+# contrary to write syswrite() returns already if only
+# a part of the data is written
+sub syswrite {
+ my $self = shift;
+ return $self->generic_write( 0,@_ );
+}
+
+sub print {
+ my $self = shift;
+ my $string = join(($, or ''), @_, ($\ or ''));
+ return $self->write( $string );
+}
+
+sub printf {
+ my ($self,$format) = (shift,shift);
+ return $self->write(sprintf($format, @_));
+}
+
+sub getc {
+ my ($self, $buffer) = (shift, undef);
+ return $buffer if $self->read($buffer, 1, 0);
+}
+
+sub readline {
+ my $self = shift;
+ my $ssl = $self->_get_ssl_object || return;
+
+ if (wantarray) {
+ my ($buf,$err) = Net::SSLeay::ssl_read_all($ssl);
+ return $self->error( "SSL read error" ) if $err;
+ if ( !defined($/) ) {
+ return $buf;
+ } elsif ( ref($/) ) {
+ my $size = ${$/};
+ die "bad value in ref \$/: $size" unless $size>0;
+ return $buf=~m{\G(.{1,$size})}g;
+ } elsif ( $/ eq '' ) {
+ return $buf =~m{\G(.*\n\n+|.+)}g;
+ } else {
+ return $buf =~m{\G(.*$/|.+)}g;
+ }
+ }
+
+ if ( !defined($/) ) {
+ my ($buf,$err) = Net::SSLeay::ssl_read_all($ssl);
+ return $self->error( "SSL read error" ) if $err;
+ return $buf;
+ } elsif ( ref($/) ) {
+ my $size = ${$/};
+ die "bad value in ref \$/: $size" unless $size>0;
+ my ($buf,$err) = Net::SSLeay::ssl_read_all($ssl,$size);
+ return $self->error( "SSL read error" ) if $err;
+ return $buf;
+ } elsif ( $/ ne '' ) {
+ my $line = Net::SSLeay::ssl_read_until($ssl,$/);
+ return $self->error( "SSL read error" ) if $line eq '';
+ return $line;
+ } else {
+ # $/ is ''
+ # ^.*?\n\n+, need peek to find all \n at the end
+ die "empty \$/ is not supported if I don't have peek"
+ if Net::SSLeay::OPENSSL_VERSION_NUMBER() < 0x0090601f;
+
+ # find first occurence of \n\n
+ my $buf = '';
+ my $eon = 0;
+ while (1) {
+ defined( Net::SSLeay::peek($ssl,1)) || last; # peek more, can block
+ my $pending = Net::SSLeay::pending($ssl);
+ $buf .= Net::SSLeay::peek( $ssl,$pending ); # will not block
+ if ( !$eon ) {
+ my $pos = index( $buf,"\n\n");
+ next if $pos<0; # newlines not found
+ $eon = $pos+2; # pos after second newline
+ }
+ # $eon >= 2 == bytes incl last known \n
+ while ( index( $buf,"\n",$eon ) == $eon ) {
+ # the next char ist \n too
+ $eon++;
+ }
+ last if $eon < length($buf); # found last \n before end of buf
+ }
+ if ( $eon > 0 ) {
+ # found something
+ # readed peeked data until $eon from $ssl
+ return Net::SSLeay::ssl_read_all( $ssl,$eon );
+ } else {
+ # found nothing
+ # return all what we have
+ if ( my $l = length($buf)) {
+ return Net::SSLeay::ssl_read_all( $ssl,$l );
+ } else {
+ return $self->error( "SSL read error" );
+ }
+ }
+ }
+}
+
+sub close {
+ my $self = shift || return _invalid_object();
+ my $close_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
+
+ return if ! $self->stop_SSL(
+ SSL_fast_shutdown => 1,
+ %$close_args,
+ _SSL_ioclass_downgrade => 0,
+ );
+
+ if ( ! $close_args->{_SSL_in_DESTROY} ) {
+ untie( *$self );
+ return $self->SUPER::close;
+ }
+ return 1;
+}
+
+sub stop_SSL {
+ my $self = shift || return _invalid_object();
+ my $stop_args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
+ return $self->error("SSL object not open")
+ if ! ${*$self}{'_SSL_opened'};
+
+ if (my $ssl = ${*$self}{'_SSL_object'}) {
+ my $shutdown_done;
+ if ( $stop_args->{SSL_no_shutdown} ) {
+ $shutdown_done = 1;
+ } else {
+ my $fast = $stop_args->{SSL_fast_shutdown};
+ my $status = Net::SSLeay::get_shutdown($ssl);
+ if ( $status == SSL_RECEIVED_SHUTDOWN
+ || ( $status != 0 && $fast )) {
+ # shutdown done
+ $shutdown_done = 1;
+ } else {
+ # need to initiate/continue shutdown
+ local $SIG{PIPE} = sub{};
+ for my $try (1,2 ) {
+ my $rv = Net::SSLeay::shutdown($ssl);
+ if ( $rv < 0 ) {
+ # non-blocking socket?
+ $self->_set_rw_error( $ssl,$rv );
+ # need to try again
+ return;
+ } elsif ( $rv
+ || ( $rv == 0 && $fast )) {
+ # shutdown finished
+ $shutdown_done = 1;
+ last;
+ } else {
+ # shutdown partly finished (e.g. one direction)
+ # call again
+ }
+ }
+ }
+ }
+
+ return if ! $shutdown_done;
+ Net::SSLeay::free($ssl);
+ delete ${*$self}{_SSL_object};
+ }
+
+ if ($stop_args->{'SSL_ctx_free'}) {
+ my $ctx = delete ${*$self}{'_SSL_ctx'};
+ $ctx && $ctx->DESTROY();
+ }
+
+ if (my $cert = delete ${*$self}{'_SSL_certificate'}) {
+ Net::SSLeay::X509_free($cert);
+ }
+
+ ${*$self}{'_SSL_opened'} = 0;
+
+ if ( ! $stop_args->{_SSL_in_DESTROY} ) {
+
+ my $downgrade = $stop_args->{_SSL_ioclass_downgrade};
+ if ( $downgrade || ! defined $downgrade ) {
+ # rebless to original class from start_SSL
+ if ( my $orig_class = delete ${*$self}{'_SSL_ioclass_upgraded'} ) {
+ bless $self,$orig_class;
+ untie(*$self);
+ # FIXME: if original class was tied too we need to restore the tie
+ }
+ # remove all _SSL related from *$self
+ my @sslkeys = grep { m{^_?SSL_} } keys %{*$self};
+ delete @{*$self}{@sslkeys} if @sslkeys;
+ }
+ }
+ return 1;
+}
+
+
+sub kill_socket {
+ my $self = shift;
+ shutdown($self, 2);
+ $self->close(SSL_no_shutdown => 1) if ${*$self}{'_SSL_opened'};
+ delete(${*$self}{'_SSL_ctx'});
+ return;
+}
+
+sub fileno {
+ my $self = shift;
+ my $fn = ${*$self}{'_SSL_fileno'};
+ return defined($fn) ? $fn : $self->SUPER::fileno();
+}
+
+
+####### IO::Socket::SSL specific functions #######
+# _get_ssl_object is for internal use ONLY!
+sub _get_ssl_object {
+ my $self = shift;
+ my $ssl = ${*$self}{'_SSL_object'};
+ return IO::Socket::SSL->error("Undefined SSL object") unless($ssl);
+ return $ssl;
+}
+
+# default error for undefined arguments
+sub _invalid_object {
+ return IO::Socket::SSL->error("Undefined IO::Socket::SSL object");
+}
+
+
+sub pending {
+ my $ssl = shift()->_get_ssl_object || return;
+ return Net::SSLeay::pending($ssl);
+}
+
+sub start_SSL {
+ my ($class,$socket) = (shift,shift);
+ return $class->error("Not a socket") unless(ref($socket));
+ my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
+ my %to = exists $arg_hash->{Timeout} ? ( Timeout => delete $arg_hash->{Timeout} ) :();
+ my $original_class = ref($socket);
+ my $original_fileno = (UNIVERSAL::can($socket, "fileno"))
+ ? $socket->fileno : CORE::fileno($socket);
+ return $class->error("Socket has no fileno") unless defined $original_fileno;
+
+ bless $socket, $class;
+ $socket->configure_SSL($arg_hash) or bless($socket, $original_class) && return;
+
+ ${*$socket}{'_SSL_fileno'} = $original_fileno;
+ ${*$socket}{'_SSL_ioclass_upgraded'} = $original_class;
+
+ my $start_handshake = $arg_hash->{SSL_startHandshake};
+ if ( ! defined($start_handshake) || $start_handshake ) {
+ # if we have no callback force blocking mode
+ DEBUG(2, "start handshake" );
+ my $blocking = $socket->blocking(1);
+ my $result = ${*$socket}{'_SSL_arguments'}{SSL_server}
+ ? $socket->accept_SSL(%to)
+ : $socket->connect_SSL(%to);
+ $socket->blocking(0) if !$blocking;
+ return $result ? $socket : (bless($socket, $original_class) && ());
+ } else {
+ DEBUG(2, "dont start handshake: $socket" );
+ return $socket; # just return upgraded socket
+ }
+
+}
+
+sub new_from_fd {
+ my ($class, $fd) = (shift,shift);
+ # Check for accidental inclusion of MODE in the argument list
+ if (length($_[0]) < 4) {
+ (my $mode = $_[0]) =~ tr/+<>//d;
+ shift unless length($mode);
+ }
+ my $handle = $ISA[0]->new_from_fd($fd, '+<')
+ || return($class->error("Could not create socket from file descriptor."));
+
+ # Annoying workaround for Perl 5.6.1 and below:
+ $handle = $ISA[0]->new_from_fd($handle, '+<');
+
+ return $class->start_SSL($handle, @_);
+}
+
+
+sub dump_peer_certificate {
+ my $ssl = shift()->_get_ssl_object || return;
+ return Net::SSLeay::dump_peer_certificate($ssl);
+}
+
+{
+ my %dispatcher = (
+ issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
+ subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
+ );
+ if ( $Net::SSLeay::VERSION >= 1.30 ) {
+ # I think X509_NAME_get_text_by_NID got added in 1.30
+ $dispatcher{commonName} = sub {
+ my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
+ Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
+ $cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
+ $cn;
+ }
+ } else {
+ $dispatcher{commonName} = sub {
+ croak "you need at least Net::SSLeay version 1.30 for getting commonName"
+ }
+ }
+
+ if ( $Net::SSLeay::VERSION >= 1.33 ) {
+ # X509_get_subjectAltNames did not really work before
+ $dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
+ } else {
+ $dispatcher{subjectAltNames} = sub {
+ croak "you need at least Net::SSLeay version 1.33 for getting subjectAltNames"
+ };
+ }
+
+ # alternative names
+ $dispatcher{authority} = $dispatcher{issuer};
+ $dispatcher{owner} = $dispatcher{subject};
+ $dispatcher{cn} = $dispatcher{commonName};
+
+ sub peer_certificate {
+ my ($self, $field) = @_;
+ my $ssl = $self->_get_ssl_object or return;
+
+ my $cert = ${*$self}{_SSL_certificate}
+ ||= Net::SSLeay::get_peer_certificate($ssl)
+ or return $self->error("Could not retrieve peer certificate");
+
+ if ($field) {
+ my $sub = $dispatcher{$field} or croak
+ "invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
+ "\nMaybe you need to upgrade your Net::SSLeay";
+ return $sub->($cert);
+ } else {
+ return $cert
+ }
+ }
+
+ # known schemes, possible attributes are:
+ # - wildcards_in_alt (0, 'leftmost', 'anywhere')
+ # - wildcards_in_cn (0, 'leftmost', 'anywhere')
+ # - check_cn (0, 'always', 'when_only')
+
+ my %scheme = (
+ # rfc 4513
+ ldap => {
+ wildcards_in_cn => 0,
+ wildcards_in_alt => 'leftmost',
+ check_cn => 'always',
+ },
+ # rfc 2818
+ http => {
+ wildcards_in_cn => 0,
+ wildcards_in_alt => 'anywhere',
+ check_cn => 'when_only',
+ },
+ # rfc 3207
+ # This is just a dumb guess
+ # RFC3207 itself just says, that the client should expect the
+ # domain name of the server in the certificate. It doesn't say
+ # anything about wildcards, so I forbid them. It doesn't say
+ # anything about alt names, but other documents show, that alt
+ # names should be possible. The check_cn value again is a guess.
+ # Fix the spec!
+ smtp => {
+ wildcards_in_cn => 0,
+ wildcards_in_alt => 0,
+ check_cn => 'always'
+ },
+ none => {}, # do not check
+ );
+
+ $scheme{www} = $scheme{http}; # alias
+ $scheme{xmpp} = $scheme{http}; # rfc 3920
+ $scheme{pop3} = $scheme{ldap}; # rfc 2595
+ $scheme{imap} = $scheme{ldap}; # rfc 2595
+ $scheme{acap} = $scheme{ldap}; # rfc 2595
+ $scheme{nntp} = $scheme{ldap}; # rfc 4642
+ $scheme{ftp} = $scheme{http}; # rfc 4217
+
+ # function to verify the hostname
+ #
+ # as every application protocol has its own rules to do this
+ # we provide some default rules as well as a user-defined
+ # callback
+
+ sub verify_hostname_of_cert {
+ my $identity = shift;
+ my $cert = shift;
+ my $scheme = shift || 'none';
+ if ( ! ref($scheme) ) {
+ DEBUG(3, "scheme=$scheme cert=$cert" );
+ $scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
+ }
+
+ # get data from certificate
+ my $commonName = $dispatcher{cn}->($cert);
+ my @altNames = $dispatcher{subjectAltNames}->($cert);
+ DEBUG(3,"identity=$identity cn=$commonName alt=@altNames" );
+
+ if ( my $sub = $scheme->{callback} ) {
+ # use custom callback
+ return $sub->($identity,$commonName,@altNames);
+ }
+
+ # is the given hostname an IP address? Then we have to convert to network byte order [RFC791][RFC2460]
+
+ my ($ip4,$ip6);
+ if ( $identity =~m{:} ) {
+ # no IPv4 or hostname have ':' in it, try IPv6.
+ # make sure that Socket6 was loaded properly
+ UNIVERSAL::can( __PACKAGE__, 'inet_pton' ) or croak
+ q[Looks like IPv6 address, make sure that Socket6 is loaded or make "use IO::Socket::SSL 'inet6'];
+ $ip6 = inet_pton( $identity ) or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
+ } elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
+ # definitly no hostname, try IPv4
+ $ip4 = inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
+ } else {
+ # assume hostname, check for umlauts etc
+ if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
+ $identity =~m{\0} and croak("name '$identity' has \\0 byte");
+ $identity = idn_to_ascii($identity) or
+ croak "Warning: Given name '$identity' could not be converted to IDNA!";
+ }
+ }
+
+ # do the actual verification
+ my $check_name = sub {
+ my ($name,$identity,$wtyp) = @_;
+ $wtyp ||= '';
+ my $pattern;
+ ### IMPORTANT!
+ # we accept only a single wildcard and only for a single part of the FQDN
+ # e.g *.example.org does match www.example.org but not bla.www.example.org
+ # The RFCs are in this regard unspecific but we don't want to have to
+ # deal with certificates like *.com, *.co.uk or even *
+ # see also http://nils.toedtmann.net/pub/subjectAltName.txt
+ if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
+ $pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
+ } elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
+ $pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
+ } else {
+ $pattern = qr{^\Q$name\E$}i;
+ }
+ return $identity =~ $pattern;
+ };
+
+ my $alt_dnsNames = 0;
+ while (@altNames) {
+ my ($type, $name) = splice (@altNames, 0, 2);
+ if ( $type == GEN_IPADD ) {
+ # exakt match needed for IP
+ # $name is already packed format (inet_xton)
+ return 1 if
+ $ip6 ? $ip6 eq $name :
+ $ip4 ? $ip4 eq $name :
+ 0;
+
+ } elsif ( $type == GEN_DNS ) {
+ $name =~s/\s+$//; $name =~s/^\s+//;
+ $alt_dnsNames++;
+ $check_name->($name,$identity,$scheme->{wildcards_in_alt})
+ and return 1;
+ }
+ }
+
+ if ( $scheme->{check_cn} eq 'always' or
+ $scheme->{check_cn} eq 'when_only' and !$alt_dnsNames) {
+ $check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
+ and return 1;
+ }
+
+ return 0; # no match
+ }
+}
+
+sub verify_hostname {
+ my $self = shift;
+ my $host = shift;
+ my $cert = $self->peer_certificate;
+ return verify_hostname_of_cert( $host,$cert,@_ );
+}
+
+
+sub get_cipher {
+ my $ssl = shift()->_get_ssl_object || return;
+ return Net::SSLeay::get_cipher($ssl);
+}
+
+sub errstr {
+ my $self = shift;
+ return ((ref($self) ? ${*$self}{'_SSL_last_err'} : $SSL_ERROR) or '');
+}
+
+sub fatal_ssl_error {
+ my $self = shift;
+ my $error_trap = ${*$self}{'_SSL_arguments'}->{'SSL_error_trap'};
+ $@ = $self->errstr;
+ if (defined $error_trap and ref($error_trap) eq 'CODE') {
+ $error_trap->($self, $self->errstr()."\n".$self->get_ssleay_error());
+ } else {
+ $self->kill_socket;
+ }
+ return;
+}
+
+sub get_ssleay_error {
+ #Net::SSLeay will print out the errors itself unless we explicitly
+ #undefine $Net::SSLeay::trace while running print_errs()
+ local $Net::SSLeay::trace;
+ return Net::SSLeay::print_errs('SSL error: ') || '';
+}
+
+sub error {
+ my ($self, $error, $destroy_socket) = @_;
+ $error .= Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
+ DEBUG(2, $error."\n".$self->get_ssleay_error());
+ $SSL_ERROR = dualvar( -1, $error );
+ ${*$self}{'_SSL_last_err'} = $SSL_ERROR if (ref($self));
+ return;
+}
+
+
+sub DESTROY {
+ my $self = shift || return;
+ $self->close(_SSL_in_DESTROY => 1, SSL_no_shutdown => 1)
+ if ${*$self}{'_SSL_opened'};
+ delete(${*$self}{'_SSL_ctx'});
+}
+
+
+#######Extra Backwards Compatibility Functionality#######
+sub socket_to_SSL { IO::Socket::SSL->start_SSL(@_); }
+sub socketToSSL { IO::Socket::SSL->start_SSL(@_); }
+
+sub issuer_name { return(shift()->peer_certificate("issuer")) }
+sub subject_name { return(shift()->peer_certificate("subject")) }
+sub get_peer_certificate { return shift() }
+
+sub context_init {
+ return($GLOBAL_CONTEXT_ARGS = (ref($_[0]) eq 'HASH') ? $_[0] : {@_});
+}
+
+sub set_default_context {
+ $GLOBAL_CONTEXT_ARGS->{'SSL_reuse_ctx'} = shift;
+}
+
+sub set_default_session_cache {
+ $GLOBAL_CONTEXT_ARGS->{SSL_session_cache} = shift;
+}
+
+sub set_ctx_defaults {
+ my %args = @_;
+ while ( my ($k,$v) = each %args ) {
+ $k =~s{^(SSL_)?}{SSL_};
+ $GLOBAL_CONTEXT_ARGS->{$k} = $v;
+ }
+}
+
+
+sub opened {
+ my $self = shift;
+ return IO::Handle::opened($self) && ${*$self}{'_SSL_opened'};
+}
+
+sub opening {
+ my $self = shift;
+ return ${*$self}{'_SSL_opening'};
+}
+
+sub want_read { shift->errstr == SSL_WANT_READ }
+sub want_write { shift->errstr == SSL_WANT_WRITE }
+
+
+#Redundant IO::Handle functionality
+sub getline { return(scalar shift->readline()) }
+sub getlines {
+ return(shift->readline()) if wantarray();
+ croak("Use of getlines() not allowed in scalar context");
+}
+
+#Useless IO::Handle functionality
+sub truncate { croak("Use of truncate() not allowed with SSL") }
+sub stat { croak("Use of stat() not allowed with SSL" ) }
+sub setbuf { croak("Use of setbuf() not allowed with SSL" ) }
+sub setvbuf { croak("Use of setvbuf() not allowed with SSL" ) }
+sub fdopen { croak("Use of fdopen() not allowed with SSL" ) }
+
+#Unsupported socket functionality
+sub ungetc { croak("Use of ungetc() not implemented in IO::Socket::SSL") }
+sub send { croak("Use of send() not implemented in IO::Socket::SSL; use print/printf/syswrite instead") }
+sub recv { croak("Use of recv() not implemented in IO::Socket::SSL; use read/sysread instead") }
+
+package IO::Socket::SSL::SSL_HANDLE;
+use strict;
+use vars qw($HAVE_WEAKREF);
+use Errno 'EBADF';
+
+BEGIN {
+ local ($@, $SIG{__DIE__});
+
+ #Use Scalar::Util or WeakRef if possible:
+ eval "use Scalar::Util qw(weaken isweak); 1" or
+ eval "use WeakRef";
+ $HAVE_WEAKREF = $@ ? 0 : 1;
+}
+
+
+sub TIEHANDLE {
+ my ($class, $handle) = @_;
+ weaken($handle) if $HAVE_WEAKREF;
+ bless \$handle, $class;
+}
+
+sub READ { ${shift()}->sysread(@_) }
+sub READLINE { ${shift()}->readline(@_) }
+sub GETC { ${shift()}->getc(@_) }
+
+sub PRINT { ${shift()}->print(@_) }
+sub PRINTF { ${shift()}->printf(@_) }
+sub WRITE { ${shift()}->syswrite(@_) }
+
+sub FILENO { ${shift()}->fileno(@_) }
+
+sub TELL { $! = EBADF; return -1 }
+sub BINMODE { return 0 } # not perfect, but better than not implementing the method
+
+sub CLOSE { #<---- Do not change this function!
+ my $ssl = ${$_[0]};
+ local @_;
+ $ssl->close();
+}
+
+
+package IO::Socket::SSL::SSL_Context;
+use Carp;
+use strict;
+
+my %CTX_CREATED_IN_THIS_THREAD;
+*DEBUG = *IO::Socket::SSL::DEBUG;
+
+# should be better taken from Net::SSLeay, but they are not (yet) defined there
+use constant SSL_MODE_ENABLE_PARTIAL_WRITE => 1;
+use constant SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER => 2;
+
+
+# Note that the final object will actually be a reference to the scalar
+# (C-style pointer) returned by Net::SSLeay::CTX_*_new() so that
+# it can be blessed.
+sub new {
+ my $class = shift;
+ #DEBUG( "$class @_" );
+ my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};
+
+ my $ctx_object = $arg_hash->{'SSL_reuse_ctx'};
+ if ($ctx_object) {
+ return $ctx_object if ($ctx_object->isa('IO::Socket::SSL::SSL_Context') and
+ $ctx_object->{context});
+
+ # The following "double entendre" applies only if someone passed
+ # in an IO::Socket::SSL object instead of an actual context.
+ return $ctx_object if ($ctx_object = ${*$ctx_object}{'_SSL_ctx'});
+ }
+
+ my $ctx;
+ foreach ($arg_hash->{'SSL_version'}) {
+ $ctx = /^sslv2$/i ? Net::SSLeay::CTX_v2_new() :
+ /^sslv3$/i ? Net::SSLeay::CTX_v3_new() :
+ /^tlsv1$/i ? Net::SSLeay::CTX_tlsv1_new() :
+ Net::SSLeay::CTX_new();
+ }
+
+ $ctx || return IO::Socket::SSL->error("SSL Context init failed");
+
+ Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL());
+
+ # SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER makes syswrite return if at least one
+ # buffer was written and not block for the rest
+ # SSL_MODE_ENABLE_PARTIAL_WRITE can be necessary for non-blocking because we
+ # cannot guarantee, that the location of the buffer stays constant
+ Net::SSLeay::CTX_set_mode( $ctx,
+ SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER|SSL_MODE_ENABLE_PARTIAL_WRITE);
+
+
+ my $verify_mode = $arg_hash->{SSL_verify_mode};
+ if ( $verify_mode != Net::SSLeay::VERIFY_NONE() and
+ ! Net::SSLeay::CTX_load_verify_locations(
+ $ctx, $arg_hash->{SSL_ca_file} || '',$arg_hash->{SSL_ca_path} || '') ) {
+ if ( ! $arg_hash->{SSL_ca_file} && ! $arg_hash->{SSL_ca_path} ) {
+ carp("No certificate verification because neither SSL_ca_file nor SSL_ca_path known");
+ $verify_mode = Net::SSLeay::VERIFY_NONE();
+ } else {
+ return IO::Socket::SSL->error("Invalid certificate authority locations");
+ }
+ }
+
+ if ($arg_hash->{'SSL_check_crl'}) {
+ if (Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x0090702f) {
+ Net::SSLeay::X509_STORE_set_flags(
+ Net::SSLeay::CTX_get_cert_store($ctx),
+ Net::SSLeay::X509_V_FLAG_CRL_CHECK()
+ );
+ if ($arg_hash->{'SSL_crl_file'}) {
+ my $bio = Net::SSLeay::BIO_new_file($arg_hash->{'SSL_crl_file'}, 'r');
+ my $crl = Net::SSLeay::PEM_read_bio_X509_CRL($bio);
+ if ( $crl ) {
+ Net::SSLeay::X509_STORE_add_crl(Net::SSLeay::CTX_get_cert_store($ctx), $crl);
+ } else {
+ return IO::Socket::SSL->error("Invalid certificate revocation list");
+ }
+ }
+ } else {
+ return IO::Socket::SSL->error("CRL not supported for OpenSSL < v0.9.7b");
+ }
+ }
+
+ if ($arg_hash->{'SSL_server'} || $arg_hash->{'SSL_use_cert'}) {
+ my $filetype = Net::SSLeay::FILETYPE_PEM();
+
+ if ($arg_hash->{'SSL_passwd_cb'}) {
+ Net::SSLeay::CTX_set_default_passwd_cb($ctx, $arg_hash->{'SSL_passwd_cb'});
+ }
+
+ if ( my $pkey= $arg_hash->{SSL_key} ) {
+ # binary, e.g. EVP_PKEY*
+ Net::SSLeay::CTX_use_PrivateKey($ctx, $pkey)
+ || return IO::Socket::SSL->error("Failed to use Private Key");
+ } elsif ( my $f = $arg_hash->{SSL_key_file} ) {
+ Net::SSLeay::CTX_use_PrivateKey_file($ctx, $f, $filetype)
+ || return IO::Socket::SSL->error("Failed to open Private Key");
+ }
+
+ if ( my $x509 = $arg_hash->{SSL_cert} ) {
+ # binary, e.g. X509*
+ # we habe either a single certificate or a list with
+ # a chain of certificates
+ my @x509 = ref($x509) eq 'ARRAY' ? @$x509: ($x509);
+ my $cert = shift @x509;
+ Net::SSLeay::CTX_use_certificate( $ctx,$cert )
+ || return IO::Socket::SSL->error("Failed to use Certificate");
+ foreach my $ca (@x509) {
+ Net::SSLeay::CTX_add_extra_chain_cert( $ctx,$ca )
+ || return IO::Socket::SSL->error("Failed to use Certificate");
+ }
+ } elsif ( my $f = $arg_hash->{SSL_cert_file} ) {
+ Net::SSLeay::CTX_use_certificate_chain_file($ctx, $f)
+ || return IO::Socket::SSL->error("Failed to open Certificate");
+ }
+
+ if ( my $dh = $arg_hash->{SSL_dh} ) {
+ # binary, e.g. DH*
+ Net::SSLeay::CTX_set_tmp_dh( $ctx,$dh )
+ || return IO::Socket::SSL->error( "Failed to set DH from SSL_dh" );
+ } elsif ( my $f = $arg_hash->{SSL_dh_file} ) {
+ my $bio = Net::SSLeay::BIO_new_file( $f,'r' )
+ || return IO::Socket::SSL->error( "Failed to open DH file $f" );
+ my $dh = Net::SSLeay::PEM_read_bio_DHparams($bio);
+ Net::SSLeay::BIO_free($bio);
+ $dh || return IO::Socket::SSL->error( "Failed to read PEM for DH from $f - wrong format?" );
+ my $rv = Net::SSLeay::CTX_set_tmp_dh( $ctx,$dh );
+ Net::SSLeay::DH_free( $dh );
+ $rv || return IO::Socket::SSL->error( "Failed to set DH from $f" );
+ }
+ }
+
+ my $verify_cb = $arg_hash->{SSL_verify_callback};
+ my $verify_callback = $verify_cb && sub {
+ my ($ok, $ctx_store) = @_;
+ my ($certname,$cert,$error);
+ if ($ctx_store) {
+ $cert = Net::SSLeay::X509_STORE_CTX_get_current_cert($ctx_store);
+ $error = Net::SSLeay::X509_STORE_CTX_get_error($ctx_store);
+ $certname = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_issuer_name($cert)).
+ Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert));
+ $error &&= Net::SSLeay::ERR_error_string($error);
+ }
+ DEBUG(3, "ok=$ok cert=$cert" );
+ return $verify_cb->($ok,$ctx_store,$certname,$error,$cert);
+ };
+
+ Net::SSLeay::CTX_set_verify($ctx, $verify_mode, $verify_callback);
+
+ $ctx_object = { context => $ctx };
+ $ctx_object->{has_verifycb} = 1 if $verify_callback;
+ DEBUG(3, "new ctx $ctx" );
+ $CTX_CREATED_IN_THIS_THREAD{$ctx} = 1;
+
+ if ( my $cache = $arg_hash->{SSL_session_cache} ) {
+ # use predefined cache
+ $ctx_object->{session_cache} = $cache
+ } elsif ( my $size = $arg_hash->{SSL_session_cache_size}) {
+ return IO::Socket::SSL->error("Session caches not supported for Net::SSLeay < v1.26")
+ if $Net::SSLeay::VERSION < 1.26;
+ $ctx_object->{session_cache} = IO::Socket::SSL::Session_Cache->new( $size );
+ }
+
+ return bless $ctx_object, $class;
+}
+
+
+sub session_cache {
+ my $ctx = shift;
+ my $cache = $ctx->{'session_cache'} || return;
+ my ($addr,$port,$session) = @_;
+ $port ||= $addr =~s{:(\w+)$}{} && $1; # host:port
+ my $key = "$addr:$port";
+ return defined($session)
+ ? $cache->add_session($key, $session)
+ : $cache->get_session($key);
+}
+
+sub has_session_cache {
+ return defined shift->{session_cache};
+}
+
+
+sub CLONE { %CTX_CREATED_IN_THIS_THREAD = (); }
+sub DESTROY {
+ my $self = shift;
+ if ( my $ctx = $self->{context} ) {
+ DEBUG( 3,"free ctx $ctx open=".join( " ",keys %CTX_CREATED_IN_THIS_THREAD ));
+ if ( %CTX_CREATED_IN_THIS_THREAD and
+ delete $CTX_CREATED_IN_THIS_THREAD{$ctx} ) {
+ # remove any verify callback for this context
+ if ( $self->{has_verifycb}) {
+ DEBUG( 3,"free ctx $ctx callback" );
+ Net::SSLeay::CTX_set_verify($ctx, 0,undef);
+ }
+ DEBUG( 3,"OK free ctx $ctx" );
+ Net::SSLeay::CTX_free($ctx);
+ }
+ }
+ delete(@{$self}{'context','session_cache'});
+}
+
+package IO::Socket::SSL::Session_Cache;
+use strict;
+
+sub new {
+ my ($class, $size) = @_;
+ $size>0 or return;
+ return bless { _maxsize => $size }, $class;
+}
+
+
+sub get_session {
+ my ($self, $key) = @_;
+ my $session = $self->{$key} || return;
+ return $session->{session} if ($self->{'_head'} eq $session);
+ $session->{prev}->{next} = $session->{next};
+ $session->{next}->{prev} = $session->{prev};
+ $session->{next} = $self->{'_head'};
+ $session->{prev} = $self->{'_head'}->{prev};
+ $self->{'_head'}->{prev} = $self->{'_head'}->{prev}->{next} = $session;
+ $self->{'_head'} = $session;
+ return $session->{session};
+}
+
+sub add_session {
+ my ($self, $key, $val) = @_;
+ return if ($key eq '_maxsize' or $key eq '_head');
+
+ if ((keys %$self) > $self->{'_maxsize'} + 1) {
+ my $last = $self->{'_head'}->{prev};
+ Net::SSLeay::SESSION_free($last->{session});
+ delete($self->{$last->{key}});
+ $self->{'_head'}->{prev} = $self->{'_head'}->{prev}->{prev};
+ delete($self->{'_head'}) if ($self->{'_maxsize'} == 1);
+ }
+
+ my $session = $self->{$key} = { session => $val, key => $key };
+
+ if ($self->{'_head'}) {
+ $session->{next} = $self->{'_head'};
+ $session->{prev} = $self->{'_head'}->{prev};
+ $self->{'_head'}->{prev}->{next} = $session;
+ $self->{'_head'}->{prev} = $session;
+ } else {
+ $session->{next} = $session->{prev} = $session;
+ }
+ $self->{'_head'} = $session;
+ return $session;
+}
+
+sub DESTROY {
+ my $self = shift;
+ delete(@{$self}{'_head','_maxsize'});
+ foreach my $key (keys %$self) {
+ Net::SSLeay::SESSION_free($self->{$key}->{session});
+ }
+}
+
+
+1;
+
+
+=head1 NAME
+
+IO::Socket::SSL -- Nearly transparent SSL encapsulation for IO::Socket::INET.
+
+=head1 SYNOPSIS
+
+ use strict;
+ use IO::Socket::SSL;
+
+ my $client = IO::Socket::SSL->new("www.example.com:https")
+ || warn "I encountered a problem: ".IO::Socket::SSL::errstr();
+ $client->verify_hostname( 'www.example.com','http' )
+ || die "hostname verification failed";
+
+ print $client "GET / HTTP/1.0\r\n\r\n";
+ print <$client>;
+
+
+=head1 DESCRIPTION
+
+This module is a true drop-in replacement for IO::Socket::INET that uses
+SSL to encrypt data before it is transferred to a remote server or
+client. IO::Socket::SSL supports all the extra features that one needs
+to write a full-featured SSL client or server application: multiple SSL contexts,
+cipher selection, certificate verification, and SSL version selection. As an
+extra bonus, it works perfectly with mod_perl.
+
+If you have never used SSL before, you should read the appendix labelled 'Using SSL'
+before attempting to use this module.
+
+If you have used this module before, read on, as versions 0.93 and above
+have several changes from the previous IO::Socket::SSL versions (especially
+see the note about return values).
+
+If you are using non-blocking sockets read on, as version 0.98 added better
+support for non-blocking.
+
+If you are trying to use it with threads see the BUGS section.
+
+=head1 METHODS
+
+IO::Socket::SSL inherits its methods from IO::Socket::INET, overriding them
+as necessary. If there is an SSL error, the method or operation will return an
+empty list (false in all contexts). The methods that have changed from the
+perspective of the user are re-documented here:
+
+=over 4
+
+=item B<new(...)>
+
+Creates a new IO::Socket::SSL object. You may use all the friendly options
+that came bundled with IO::Socket::INET, plus (optionally) the ones that follow:
+
+=over 2
+
+=item SSL_version
+
+Sets the version of the SSL protocol used to transmit data. The default is SSLv2/3,
+which auto-negotiates between SSLv2 and SSLv3. You may specify 'SSLv2', 'SSLv3', or
+'TLSv1' (case-insensitive) if you do not want this behavior.
+
+=item SSL_cipher_list
+
+If this option is set the cipher list for the connection will be set to the
+given value, e.g. something like 'ALL:!LOW:!EXP:!ADH'. Look into the OpenSSL
+documentation (L<http://www.openssl.org/docs/apps/ciphers.html#CIPHER_STRINGS>)
+for more details.
+If this option is not used the openssl builtin default is used which is suitable
+for most cases.
+
+=item SSL_use_cert
+
+If this is set, it forces IO::Socket::SSL to use a certificate and key, even if
+you are setting up an SSL client. If this is set to 0 (the default), then you will
+only need a certificate and key if you are setting up a server.
+
+SSL_use_cert will implicitly be set if SSL_server is set.
+For convinience it is also set if it was not given but a cert was given for use
+(SSL_cert_file or similar).
+
+=item SSL_server
+
+Use this, if the socket should be used as a server.
+If this is not explicitly set it is assumed, if Listen with given when creating
+the socket.
+
+=item SSL_key_file
+
+If your RSA private key is not in default place (F<certs/server-key.pem> for servers,
+F<certs/client-key.pem> for clients), then this is the option that you would use to
+specify a different location. Keys should be PEM formatted, and if they are
+encrypted, you will be prompted to enter a password before the socket is formed
+(unless you specified the SSL_passwd_cb option).
+
+=item SSL_key
+
+This is an EVP_PKEY* and can be used instead of SSL_key_file.
+Useful if you don't have your key in a file but create it dynamically or get it from
+a string (see openssl PEM_read_bio_PrivateKey etc for getting a EVP_PKEY* from
+a string).
+
+=item SSL_cert_file
+
+If your SSL certificate is not in the default place (F<certs/server-cert.pem> for servers,
+F<certs/client-cert.pem> for clients), then you should use this option to specify the
+location of your certificate. Note that a key and certificate are only required for an
+SSL server, so you do not need to bother with these trifling options should you be
+setting up an unauthenticated client.
+
+=item SSL_cert
+
+This is an X509* or an array of X509*.
+The first X509* is the internal representation of the certificate while the following
+ones are extra certificates. Useful if you create your certificate dynamically (like
+in a SSL intercepting proxy) or get it from a string (see openssl PEM_read_bio_X509 etc
+for getting a X509* from a string).
+
+=item SSL_dh_file
+
+If you want Diffie-Hellman key exchange you need to supply a suitable file here
+or use the SSL_dh parameter. See dhparam command in openssl for more information.
+
+=item SSL_dh
+
+Like SSL_dh_file, but instead of giving a file you use a preloaded or generated DH*.
+
+=item SSL_passwd_cb
+
+If your private key is encrypted, you might not want the default password prompt from
+Net::SSLeay. This option takes a reference to a subroutine that should return the
+password required to decrypt your private key.
+
+=item SSL_ca_file
+
+If you want to verify that the peer certificate has been signed by a reputable
+certificate authority, then you should use this option to locate the file
+containing the certificateZ<>(s) of the reputable certificate authorities if it is
+not already in the file F<certs/my-ca.pem>.
+
+=item SSL_ca_path
+
+If you are unusually friendly with the OpenSSL documentation, you might have set
+yourself up a directory containing several trusted certificates as separate files
+as well as an index of the certificates. If you want to use that directory for
+validation purposes, and that directory is not F<ca/>, then use this option to
+point IO::Socket::SSL to the right place to look.
+
+=item SSL_verify_mode
+
+This option sets the verification mode for the peer certificate. The default
+(0x00) does no authentication. You may combine 0x01 (verify peer), 0x02 (fail
+verification if no peer certificate exists; ignored for clients), and 0x04
+(verify client once) to change the default.
+See OpenSSL man page for SSL_CTX_set_verify for more information.
+
+=item SSL_verify_callback
+
+If you want to verify certificates yourself, you can pass a sub reference along
+with this parameter to do so. When the callback is called, it will be passed:
+1) a true/false value that indicates what OpenSSL thinks of the certificate,
+2) a C-style memory address of the certificate store,
+3) a string containing the certificate's issuer attributes and owner attributes, and
+4) a string containing any errors encountered (0 if no errors).
+The function should return 1 or 0, depending on whether it thinks the certificate
+is valid or invalid. The default is to let OpenSSL do all of the busy work.
+
+=item SSL_verifycn_scheme
+
+Set the scheme used to automatically verify the hostname of the peer.
+See the information about the verification schemes in B<verify_hostname>.
+The default is undef, e.g. to not automatically verify the hostname.
+
+=item SSL_verifycn_name
+
+Set the name which is used in verification of hostname. If SSL_verifycn_scheme
+is set and no SSL_verifycn_name is given it will try to use the PeerHost and
+PeerAddr settings and fail if no name caan be determined.
+
+Using PeerHost or PeerAddr works only if you create the connection directly
+with C<< IO::Socket::SSL->new >>, if an IO::Socket::INET object is upgraded
+with B<start_SSL> the name has to be given in B<SSL_verifycn_name>.
+
+=item SSL_check_crl
+
+If you want to verify that the peer certificate has not been revoked
+by the signing authority, set this value to true. OpenSSL will search
+for the CRL in your SSL_ca_path, or use the file specified by
+SSL_crl_file. See the Net::SSLeay documentation for more details.
+Note that this functionality appears to be broken with OpenSSL <
+v0.9.7b, so its use with lower versions will result in an error.
+
+=item SSL_crl_file
+
+If you want to specify the CRL file to be used, set this value to the
+pathname to be used. This must be used in addition to setting
+SSL_check_crl.
+
+=item SSL_reuse_ctx
+
+If you have already set the above options (SSL_version through SSL_check_crl;
+this does not include SSL_cipher_list yet) for a previous instance of
+IO::Socket::SSL, then you can reuse the SSL context of that instance by passing
+it as the value for the SSL_reuse_ctx parameter. You may also create a
+new instance of the IO::Socket::SSL::SSL_Context class, using any context options
+that you desire without specifying connection options, and pass that here instead.
+
+If you use this option, all other context-related options that you pass
+in the same call to new() will be ignored unless the context supplied was invalid.
+Note that, contrary to versions of IO::Socket::SSL below v0.90, a global SSL context
+will not be implicitly used unless you use the set_default_context() function.
+
+=item SSL_session_cache_size
+
+If you make repeated connections to the same host/port and the SSL renegotiation time
+is an issue, you can turn on client-side session caching with this option by specifying a
+positive cache size. For successive connections, pass the SSL_reuse_ctx option to
+the new() calls (or use set_default_context()) to make use of the cached sessions.
+The session cache size refers to the number of unique host/port pairs that can be
+stored at one time; the oldest sessions in the cache will be removed if new ones are
+added.
+
+=item SSL_session_cache
+
+Specifies session cache object which should be used instead of creating a new.
+Overrules SSL_session_cache_size.
+This option is useful if you want to reuse the cache, but not the rest of
+the context.
+
+A session cache object can be created using
+C<< IO::Socket::SSL::Session_Cache->new( cachesize ) >>.
+
+Use set_default_session_cache() to set a global cache object.
+
+=item SSL_error_trap
+
+When using the accept() or connect() methods, it may be the case that the
+actual socket connection works but the SSL negotiation fails, as in the case of
+an HTTP client connecting to an HTTPS server. Passing a subroutine ref attached
+to this parameter allows you to gain control of the orphaned socket instead of having it
+be closed forcibly. The subroutine, if called, will be passed two parameters:
+a reference to the socket on which the SSL negotiation failed and and the full
+text of the error message.
+
+=back
+
+=item B<close(...)>
+
+There are a number of nasty traps that lie in wait if you are not careful about using
+close(). The first of these will bite you if you have been using shutdown() on your
+sockets. Since the SSL protocol mandates that a SSL "close notify" message be
+sent before the socket is closed, a shutdown() that closes the socket's write channel
+will cause the close() call to hang. For a similar reason, if you try to close a
+copy of a socket (as in a forking server) you will affect the original socket as well.
+To get around these problems, call close with an object-oriented syntax
+(e.g. $socket->close(SSL_no_shutdown => 1))
+and one or more of the following parameters:
+
+=over 2
+
+=item SSL_no_shutdown
+
+If set to a true value, this option will make close() not use the SSL_shutdown() call
+on the socket in question so that the close operation can complete without problems
+if you have used shutdown() or are working on a copy of a socket.
+
+=item SSL_fast_shutdown
+
+If set to true only a unidirectional shutdown will be done, e.g. only the
+close_notify (see SSL_shutdown(3)) will be called. Otherwise a bidrectional
+shutdown will be done. If used within close() it defaults to true, if used
+within stop_SSL() it defaults to false.
+
+=item SSL_ctx_free
+
+If you want to make sure that the SSL context of the socket is destroyed when
+you close it, set this option to a true value.
+
+=back
+
+=item B<peek(...)>
+
+This function has exactly the same syntax as sysread(), and performs nearly the same
+task (reading data from the socket) but will not advance the read position so
+that successive calls to peek() with the same arguments will return the same results.
+This function requires OpenSSL 0.9.6a or later to work.
+
+
+=item B<pending()>
+
+This function will let you know how many bytes of data are immediately ready for reading
+from the socket. This is especially handy if you are doing reads on a blocking socket
+or just want to know if new data has been sent over the socket.
+
+
+=item B<get_cipher()>
+
+Returns the string form of the cipher that the IO::Socket::SSL object is using.
+
+=item B<dump_peer_certificate()>
+
+Returns a parsable string with select fields from the peer SSL certificate. This
+method directly returns the result of the dump_peer_certificate() method of Net::SSLeay.
+
+=item B<peer_certificate($field)>
+
+If a peer certificate exists, this function can retrieve values from it.
+If no field is given the internal representation of certificate from Net::SSLeay is
+returned.
+The following fields can be queried:
+
+=over 8
+
+=item authority (alias issuer)
+
+The certificate authority which signed the certificate.
+
+=item owner (alias subject)
+
+The owner of the certificate.
+
+=item commonName (alias cn) - only for Net::SSLeay version >=1.30
+
+The common name, usually the server name for SSL certificates.
+
+=item subjectAltNames - only for Net::SSLeay version >=1.33
+
+Alternative names for the subject, usually different names for the same
+server, like example.org, example.com, *.example.com.
+
+It returns a list of (typ,value) with typ GEN_DNS, GEN_IPADD etc (these
+constants are exported from IO::Socket::SSL).
+See Net::SSLeay::X509_get_subjectAltNames.
+
+=back
+
+=item B<verify_hostname($hostname,$scheme)>
+
+This verifies the given hostname against the peer certificate using the
+given scheme. Hostname is usually what you specify within the PeerAddr.
+
+Verification of hostname against a certificate is different between various
+applications and RFCs. Some scheme allow wildcards for hostnames, some only
+in subjectAltNames, and even their different wildcard schemes are possible.
+
+To ease the verification the following schemes are predefined:
+
+=over 8
+
+=item ldap (rfc4513), pop3,imap,acap (rfc2995), nntp (rfc4642)
+
+Simple wildcards in subjectAltNames are possible, e.g. *.example.org matches
+www.example.org but not lala.www.example.org. If nothing from subjectAltNames
+match it checks against the common name, but there are no wildcards allowed.
+
+=item http (rfc2818), alias is www
+
+Extended wildcards in subjectAltNames are possible, e.g. *.example.org or
+even www*.example.org. Wildcards in the common name are not allowed. The common
+name will be only checked if no names are given in subjectAltNames.
+
+=item smtp (rfc3207)
+
+This RFC doesn't say much useful about the verification so it just assumes
+that subjectAltNames are possible, but no wildcards are possible anywhere.
+
+=back
+
+The scheme can be given either by specifying the name for one of the above predefined
+schemes, by using a callback (see below) or by using a hash which can have the
+following keys and values:
+
+=over 8
+
+=item check_cn: 0|'always'|'when_only'
+
+Determines if the common name gets checked. If 'always' it will always be checked
+(like in ldap), if 'when_only' it will only be checked if no names are given in
+subjectAltNames (like in http), for any other values the common name will not be checked.
+
+=item wildcards_in_alt: 0|'leftmost'|'anywhere'
+
+Determines if and where wildcards in subjectAltNames are possible. If 'leftmost'
+only cases like *.example.org will be possible (like in ldap), for 'anywhere'
+www*.example.org is possible too (like http), dangerous things like but www.*.org
+or even '*' will not be allowed.
+
+=item wildcards_in_cn: 0|'leftmost'|'anywhere'
+
+Similar to wildcards_in_alt, but checks the common name. There is no predefined
+scheme which allows wildcards in common names.
+
+=back
+
+If you give a subroutine for verification it will be called with the arguments
+($hostname,$commonName,@subjectAltNames), where hostname is the name given for
+verification, commonName is the result from peer_certificate('cn') and
+subjectAltNames is the result from peer_certificate('subjectAltNames').
+
+=item B<errstr()>
+
+Returns the last error (in string form) that occurred. If you do not have a real
+object to perform this method on, call IO::Socket::SSL::errstr() instead.
+
+For read and write errors on non-blocking sockets, this method may include the string
+C<SSL wants a read first!> or C<SSL wants a write first!> meaning that the other side
+is expecting to read from or write to the socket and wants to be satisfied before you
+get to do anything. But with version 0.98 you are better comparing the global exported
+variable $SSL_ERROR against the exported symbols SSL_WANT_READ and SSL_WANT_WRITE.
+
+=item B<opened()>
+
+This returns false if the socket could not be opened, 1 if the socket could be opened
+and the SSL handshake was successful done and -1 if the underlying IO::Handle is open,
+but the SSL handshake failed.
+
+=item B<< IO::Socket::SSL->start_SSL($socket, ... ) >>
+
+This will convert a glob reference or a socket that you provide to an IO::Socket::SSL
+object. You may also pass parameters to specify context or connection options as with
+a call to new(). If you are using this function on an accept()ed socket, you must
+set the parameter "SSL_server" to 1, i.e. IO::Socket::SSL->start_SSL($socket, SSL_server => 1).
+If you have a class that inherits from IO::Socket::SSL and you want the $socket to be blessed
+into your own class instead, use MyClass->start_SSL($socket) to achieve the desired effect.
+
+Note that if start_SSL() fails in SSL negotiation, $socket will remain blessed in its
+original class. For non-blocking sockets you better just upgrade the socket to
+IO::Socket::SSL and call accept_SSL or connect_SSL and the upgraded object. To
+just upgrade the socket set B<SSL_startHandshake> explicitly to 0. If you call start_SSL
+w/o this parameter it will revert to blocking behavior for accept_SSL and connect_SSL.
+
+If given the parameter "Timeout" it will stop if after the timeout no SSL connection
+was established. This parameter is only used for blocking sockets, if it is not given the
+default Timeout from the underlying IO::Socket will be used.
+
+=item B<stop_SSL(...)>
+
+This is the opposite of start_SSL(), e.g. it will shutdown the SSL connection
+and return to the class before start_SSL(). It gets the same arguments as close(),
+in fact close() calls stop_SSL() (but without downgrading the class).
+
+Will return true if it suceeded and undef if failed. This might be the case for
+non-blocking sockets. In this case $! is set to EAGAIN and the ssl error to
+SSL_WANT_READ or SSL_WANT_WRITE. In this case the call should be retried again with
+the same arguments once the socket is ready is until it succeeds.
+
+=item B<< IO::Socket::SSL->new_from_fd($fd, ...) >>
+
+This will convert a socket identified via a file descriptor into an SSL socket.
+Note that the argument list does not include a "MODE" argument; if you supply one,
+it will be thoughtfully ignored (for compatibility with IO::Socket::INET). Instead,
+a mode of '+<' is assumed, and the file descriptor passed must be able to handle such
+I/O because the initial SSL handshake requires bidirectional communication.
+
+=item B<IO::Socket::SSL::set_default_context(...)>
+
+You may use this to make IO::Socket::SSL automatically re-use a given context (unless
+specifically overridden in a call to new()). It accepts one argument, which should
+be either an IO::Socket::SSL object or an IO::Socket::SSL::SSL_Context object. See
+the SSL_reuse_ctx option of new() for more details. Note that this sets the default
+context globally, so use with caution (esp. in mod_perl scripts).
+
+=item B<IO::Socket::SSL::set_default_session_cache(...)>
+
+You may use this to make IO::Socket::SSL automatically re-use a given session cache
+(unless specifically overridden in a call to new()). It accepts one argument, which should
+be an IO::Socket::SSL::Session_Cache object or similar (e.g something which implements
+get_session and add_session like IO::Socket::SSL::Session_Cache does).
+See the SSL_session_cache option of new() for more details. Note that this sets the default
+cache globally, so use with caution.
+
+=item B<IO::Socket::SSL::set_ctx_defaults(%args)>
+
+With this function one can set defaults for all SSL_* parameter used for creation of
+the context, like the SSL_verify* parameter.
+
+=over 8
+
+=item mode - set default SSL_verify_mode
+
+=item callback - set default SSL_verify_callback
+
+=item scheme - set default SSL_verifycn_scheme
+
+=item name - set default SSL_verifycn_name
+
+If not given and scheme is hash reference with key callback it will be set to 'unknown'
+
+=back
+
+=back
+
+The following methods are unsupported (not to mention futile!) and IO::Socket::SSL
+will emit a large CROAK() if you are silly enough to use them:
+
+=over 4
+
+=item truncate
+
+=item stat
+
+=item ungetc
+
+=item setbuf
+
+=item setvbuf
+
+=item fdopen
+
+=item send/recv
+
+Note that send() and recv() cannot be reliably trapped by a tied filehandle (such as
+that used by IO::Socket::SSL) and so may send unencrypted data over the socket. Object-oriented
+calls to these functions will fail, telling you to use the print/printf/syswrite
+and read/sysread families instead.
+
+=back
+
+=head1 IPv6
+
+Support for IPv6 with IO::Socket::SSL is expected to work and basic testing is done.
+If IO::Socket::INET6 is available it will automatically use it instead of
+IO::Socket::INET4.
+
+Please be aware of the associated problems: If you give a name as a host and the
+host resolves to both IPv6 and IPv4 it will try IPv6 first and if there is no IPv6
+connectivity it will fail.
+
+To avoid these problems you can either force IPv4 by specifying and AF_INET as the
+Domain (this is per socket) or load IO::Socket::SSL with the option 'inet4'
+(This is a global setting, e.g. affects all IO::Socket::SSL objects in the program).
+
+=head1 RETURN VALUES
+
+A few changes have gone into IO::Socket::SSL v0.93 and later with respect to
+return values. The behavior on success remains unchanged, but for I<all> functions,
+the return value on error is now an empty list. Therefore, the return value will be
+false in all contexts, but those who have been using the return values as arguments
+to subroutines (like C<mysub(IO::Socket::SSL(...)->new, ...)>) may run into problems.
+The moral of the story: I<always> check the return values of these functions before
+using them in any way that you consider meaningful.
+
+
+=head1 DEBUGGING
+
+If you are having problems using IO::Socket::SSL despite the fact that can recite backwards
+the section of this documentation labelled 'Using SSL', you should try enabling debugging. To
+specify the debug level, pass 'debug#' (where # is a number from 0 to 3) to IO::Socket::SSL
+when calling it.
+The debug level will also be propagated to Net::SSLeay::trace, see also L<Net::SSLeay>:
+
+=over 4
+
+=item use IO::Socket::SSL qw(debug0);
+
+No debugging (default).
+
+=item use IO::Socket::SSL qw(debug1);
+
+Print out errors from IO::Socket::SSL and ciphers from Net::SSLeay.
+
+=item use IO::Socket::SSL qw(debug2);
+
+Print also information about call flow from IO::Socket::SSL and progress
+information from Net::SSLeay.
+
+=item use IO::Socket::SSL qw(debug3);
+
+Print also some data dumps from IO::Socket::SSL and from Net::SSLeay.
+
+=back
+
+=head1 EXAMPLES
+
+See the 'example' directory.
+
+=head1 BUGS
+
+IO::Socket::SSL is not threadsafe.
+This is because IO::Socket::SSL is based on Net::SSLeay which
+uses a global object to access some of the API of openssl
+and is therefore not threadsafe.
+It might probably work if you don't use SSL_verify_callback and
+SSL_password_cb.
+
+IO::Socket::SSL does not work together with Storable::fd_retrieve/fd_store.
+See BUGS file for more information and how to work around the problem.
+
+Non-blocking and timeouts (which are based on non-blocking) are not
+supported on Win32, because the underlying IO::Socket::INET does not support
+non-blocking on this platform.
+
+=head1 LIMITATIONS
+
+IO::Socket::SSL uses Net::SSLeay as the shiny interface to OpenSSL, which is
+the shiny interface to the ugliness of SSL. As a result, you will need both Net::SSLeay
+and OpenSSL on your computer before using this module.
+
+If you have Scalar::Util (standard with Perl 5.8.0 and above) or WeakRef, IO::Socket::SSL
+sockets will auto-close when they go out of scope, just like IO::Socket::INET sockets. If
+you do not have one of these modules, then IO::Socket::SSL sockets will stay open until the
+program ends or you explicitly close them. This is due to the fact that a circular reference
+is required to make IO::Socket::SSL sockets act simultaneously like objects and glob references.
+
+=head1 DEPRECATIONS
+
+The following functions are deprecated and are only retained for compatibility:
+
+=over 2
+
+=item context_init()
+
+use the SSL_reuse_ctx option if you want to re-use a context
+
+
+=item socketToSSL() and socket_to_SSL()
+
+use IO::Socket::SSL->start_SSL() instead
+
+
+=item get_peer_certificate()
+
+use the peer_certificate() function instead.
+Used to return X509_Certificate with methods subject_name and issuer_name.
+Now simply returns $self which has these methods (although depreceated).
+
+=item issuer_name()
+
+use peer_certificate( 'issuer' ) instead
+
+=item subject_name()
+
+use peer_certificate( 'subject' ) instead
+
+=back
+
+The following classes have been removed:
+
+=over 2
+
+=item SSL_SSL
+
+(not that you should have been directly accessing this anyway):
+
+=item X509_Certificate
+
+(but get_peer_certificate() will still Do The Right Thing)
+
+=back
+
+=head1 SEE ALSO
+
+IO::Socket::INET, IO::Socket::INET6, Net::SSLeay.
+
+=head1 AUTHORS
+
+Steffen Ullrich, <steffen at genua.de> is the current maintainer.
+
+Peter Behroozi, <behrooz at fas.harvard.edu> (Note the lack of an "i" at the end of "behrooz")
+
+Marko Asplund, <marko.asplund at kronodoc.fi>, was the original author of IO::Socket::SSL.
+
+Patches incorporated from various people, see file Changes.
+
+=head1 COPYRIGHT
+
+Working support for non-blocking was added by Steffen Ullrich.
+
+The rewrite of this module is Copyright (C) 2002-2005 Peter Behroozi.
+
+The original versions of this module are Copyright (C) 1999-2002 Marko Asplund.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+
+=head1 Appendix: Using SSL
+
+If you are unfamiliar with the way OpenSSL works, good references may be found in
+both the book "Network Security with OpenSSL" (Oreilly & Assoc.) and the web site
+L<http://www.tldp.org/HOWTO/SSL-Certificates-HOWTO/>. Read on for a quick overview.
+
+=head2 The Long of It (Detail)
+
+The usual reason for using SSL is to keep your data safe. This means that not only
+do you have to encrypt the data while it is being transported over a network, but
+you also have to make sure that the right person gets the data. To accomplish this
+with SSL, you have to use certificates. A certificate closely resembles a
+Government-issued ID (at least in places where you can trust them). The ID contains some sort of
+identifying information such as a name and address, and is usually stamped with a seal
+of Government Approval. Theoretically, this means that you may trust the information on
+the card and do business with the owner of the card. The same ideas apply to SSL certificates,
+which have some identifying information and are "stamped" [most people refer to this as
+I<signing> instead] by someone (a Certificate Authority) who you trust will adequately
+verify the identifying information. In this case, because of some clever number theory,
+it is extremely difficult to falsify the stamping process. Another useful consequence
+of number theory is that the certificate is linked to the encryption process, so you may
+encrypt data (using information on the certificate) that only the certificate owner can
+decrypt.
+
+What does this mean for you? It means that at least one person in the party has to
+have an ID to get drinks :-). Seriously, it means that one of the people communicating
+has to have a certificate to ensure that your data is safe. For client/server
+interactions, the server must B<always> have a certificate. If the server wants to
+verify that the client is safe, then the client must also have a personal certificate.
+To verify that a certificate is safe, one compares the stamped "seal" [commonly called
+an I<encrypted digest/hash/signature>] on the certificate with the official "seal" of
+the Certificate Authority to make sure that they are the same. To do this, you will
+need the [unfortunately named] certificate of the Certificate Authority. With all these
+in hand, you can set up a SSL connection and be reasonably confident that no-one is
+reading your data.
+
+=head2 The Short of It (Summary)
+
+For servers, you will need to generate a cryptographic private key and a certificate
+request. You will need to send the certificate request to a Certificate Authority to
+get a real certificate back, after which you can start serving people. For clients,
+you will not need anything unless the server wants validation, in which case you will
+also need a private key and a real certificate. For more information about how to
+get these, see L<http://www.modssl.org/docs/2.8/ssl_faq.html#ToC24>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm b/Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm
new file mode 100755
index 00000000000..baa092ba1fb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm
@@ -0,0 +1,143 @@
+# IO::Socket::UNIX.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Socket::UNIX;
+
+use strict;
+our(@ISA, $VERSION);
+use IO::Socket;
+use Carp;
+
+@ISA = qw(IO::Socket);
+$VERSION = "1.23";
+$VERSION = eval $VERSION;
+
+IO::Socket::UNIX->register_domain( AF_UNIX );
+
+sub new {
+ my $class = shift;
+ unshift(@_, "Peer") if @_ == 1;
+ return $class->SUPER::new(@_);
+}
+
+sub configure {
+ my($sock,$arg) = @_;
+ my($bport,$cport);
+
+ my $type = $arg->{Type} || SOCK_STREAM;
+
+ $sock->socket(AF_UNIX, $type, 0) or
+ return undef;
+
+ if(exists $arg->{Local}) {
+ my $addr = sockaddr_un($arg->{Local});
+ $sock->bind($addr) or
+ return undef;
+ }
+ if(exists $arg->{Listen} && $type != SOCK_DGRAM) {
+ $sock->listen($arg->{Listen} || 5) or
+ return undef;
+ }
+ elsif(exists $arg->{Peer}) {
+ my $addr = sockaddr_un($arg->{Peer});
+ $sock->connect($addr) or
+ return undef;
+ }
+
+ $sock;
+}
+
+sub hostpath {
+ @_ == 1 or croak 'usage: $sock->hostpath()';
+ my $n = $_[0]->sockname || return undef;
+ (sockaddr_un($n))[0];
+}
+
+sub peerpath {
+ @_ == 1 or croak 'usage: $sock->peerpath()';
+ my $n = $_[0]->peername || return undef;
+ (sockaddr_un($n))[0];
+}
+
+1; # Keep require happy
+
+__END__
+
+=head1 NAME
+
+IO::Socket::UNIX - Object interface for AF_UNIX domain sockets
+
+=head1 SYNOPSIS
+
+ use IO::Socket::UNIX;
+
+=head1 DESCRIPTION
+
+C<IO::Socket::UNIX> provides an object interface to creating and using sockets
+in the AF_UNIX domain. It is built upon the L<IO::Socket> interface and
+inherits all the methods defined by L<IO::Socket>.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ARGS] )
+
+Creates an C<IO::Socket::UNIX> object, which is a reference to a
+newly created symbol (see the C<Symbol> package). C<new>
+optionally takes arguments, these arguments are in key-value pairs.
+
+In addition to the key-value pairs accepted by L<IO::Socket>,
+C<IO::Socket::UNIX> provides.
+
+ Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
+ Local Path to local fifo
+ Peer Path to peer fifo
+ Listen Create a listen socket
+
+If the constructor is only passed a single argument, it is assumed to
+be a C<Peer> specification.
+
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+As of VERSION 1.18 all IO::Socket objects have autoflush turned on
+by default. This was not the case with earlier releases.
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item hostpath()
+
+Returns the pathname to the fifo at the local end
+
+=item peerpath()
+
+Returns the pathanme to the fifo at the peer end
+
+=back
+
+=head1 SEE ALSO
+
+L<Socket>, L<IO::Socket>
+
+=head1 AUTHOR
+
+Graham Barr. Currently maintained by the Perl Porters. Please report all
+bugs to <perl5-porters@perl.org>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/IO/String.pm b/Master/tlpkg/tlperl/lib/IO/String.pm
new file mode 100755
index 00000000000..4bc8e719601
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/String.pm
@@ -0,0 +1,551 @@
+package IO::String;
+
+# Copyright 1998-2005 Gisle Aas.
+#
+# This library is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+require 5.005_03;
+use strict;
+use vars qw($VERSION $DEBUG $IO_CONSTANTS);
+$VERSION = "1.08"; # $Date: 2005/12/05 12:00:47 $
+
+use Symbol ();
+
+sub new
+{
+ my $class = shift;
+ my $self = bless Symbol::gensym(), ref($class) || $class;
+ tie *$self, $self;
+ $self->open(@_);
+ return $self;
+}
+
+sub open
+{
+ my $self = shift;
+ return $self->new(@_) unless ref($self);
+
+ if (@_) {
+ my $bufref = ref($_[0]) ? $_[0] : \$_[0];
+ $$bufref = "" unless defined $$bufref;
+ *$self->{buf} = $bufref;
+ }
+ else {
+ my $buf = "";
+ *$self->{buf} = \$buf;
+ }
+ *$self->{pos} = 0;
+ *$self->{lno} = 0;
+ return $self;
+}
+
+sub pad
+{
+ my $self = shift;
+ my $old = *$self->{pad};
+ *$self->{pad} = substr($_[0], 0, 1) if @_;
+ return "\0" unless defined($old) && length($old);
+ return $old;
+}
+
+sub dump
+{
+ require Data::Dumper;
+ my $self = shift;
+ print Data::Dumper->Dump([$self], ['*self']);
+ print Data::Dumper->Dump([*$self{HASH}], ['$self{HASH}']);
+ return;
+}
+
+sub TIEHANDLE
+{
+ print "TIEHANDLE @_\n" if $DEBUG;
+ return $_[0] if ref($_[0]);
+ my $class = shift;
+ my $self = bless Symbol::gensym(), $class;
+ $self->open(@_);
+ return $self;
+}
+
+sub DESTROY
+{
+ print "DESTROY @_\n" if $DEBUG;
+}
+
+sub close
+{
+ my $self = shift;
+ delete *$self->{buf};
+ delete *$self->{pos};
+ delete *$self->{lno};
+ undef *$self if $] eq "5.008"; # workaround for some bug
+ return 1;
+}
+
+sub opened
+{
+ my $self = shift;
+ return defined *$self->{buf};
+}
+
+sub binmode
+{
+ my $self = shift;
+ return 1 unless @_;
+ # XXX don't know much about layers yet :-(
+ return 0;
+}
+
+sub getc
+{
+ my $self = shift;
+ my $buf;
+ return $buf if $self->read($buf, 1);
+ return undef;
+}
+
+sub ungetc
+{
+ my $self = shift;
+ $self->setpos($self->getpos() - 1);
+ return 1;
+}
+
+sub eof
+{
+ my $self = shift;
+ return length(${*$self->{buf}}) <= *$self->{pos};
+}
+
+sub print
+{
+ my $self = shift;
+ if (defined $\) {
+ if (defined $,) {
+ $self->write(join($,, @_).$\);
+ }
+ else {
+ $self->write(join("",@_).$\);
+ }
+ }
+ else {
+ if (defined $,) {
+ $self->write(join($,, @_));
+ }
+ else {
+ $self->write(join("",@_));
+ }
+ }
+ return 1;
+}
+*printflush = \*print;
+
+sub printf
+{
+ my $self = shift;
+ print "PRINTF(@_)\n" if $DEBUG;
+ my $fmt = shift;
+ $self->write(sprintf($fmt, @_));
+ return 1;
+}
+
+
+my($SEEK_SET, $SEEK_CUR, $SEEK_END);
+
+sub _init_seek_constants
+{
+ if ($IO_CONSTANTS) {
+ require IO::Handle;
+ $SEEK_SET = &IO::Handle::SEEK_SET;
+ $SEEK_CUR = &IO::Handle::SEEK_CUR;
+ $SEEK_END = &IO::Handle::SEEK_END;
+ }
+ else {
+ $SEEK_SET = 0;
+ $SEEK_CUR = 1;
+ $SEEK_END = 2;
+ }
+}
+
+
+sub seek
+{
+ my($self,$off,$whence) = @_;
+ my $buf = *$self->{buf} || return 0;
+ my $len = length($$buf);
+ my $pos = *$self->{pos};
+
+ _init_seek_constants() unless defined $SEEK_SET;
+
+ if ($whence == $SEEK_SET) { $pos = $off }
+ elsif ($whence == $SEEK_CUR) { $pos += $off }
+ elsif ($whence == $SEEK_END) { $pos = $len + $off }
+ else { die "Bad whence ($whence)" }
+ print "SEEK(POS=$pos,OFF=$off,LEN=$len)\n" if $DEBUG;
+
+ $pos = 0 if $pos < 0;
+ $self->truncate($pos) if $pos > $len; # extend file
+ *$self->{pos} = $pos;
+ return 1;
+}
+
+sub pos
+{
+ my $self = shift;
+ my $old = *$self->{pos};
+ if (@_) {
+ my $pos = shift || 0;
+ my $buf = *$self->{buf};
+ my $len = $buf ? length($$buf) : 0;
+ $pos = $len if $pos > $len;
+ *$self->{pos} = $pos;
+ }
+ return $old;
+}
+
+sub getpos { shift->pos; }
+
+*sysseek = \&seek;
+*setpos = \&pos;
+*tell = \&getpos;
+
+
+
+sub getline
+{
+ my $self = shift;
+ my $buf = *$self->{buf} || return;
+ my $len = length($$buf);
+ my $pos = *$self->{pos};
+ return if $pos >= $len;
+
+ unless (defined $/) { # slurp
+ *$self->{pos} = $len;
+ return substr($$buf, $pos);
+ }
+
+ unless (length $/) { # paragraph mode
+ # XXX slow&lazy implementation using getc()
+ my $para = "";
+ my $eol = 0;
+ my $c;
+ while (defined($c = $self->getc)) {
+ if ($c eq "\n") {
+ $eol++;
+ next if $eol > 2;
+ }
+ elsif ($eol > 1) {
+ $self->ungetc($c);
+ last;
+ }
+ else {
+ $eol = 0;
+ }
+ $para .= $c;
+ }
+ return $para; # XXX wantarray
+ }
+
+ my $idx = index($$buf,$/,$pos);
+ if ($idx < 0) {
+ # return rest of it
+ *$self->{pos} = $len;
+ $. = ++ *$self->{lno};
+ return substr($$buf, $pos);
+ }
+ $len = $idx - $pos + length($/);
+ *$self->{pos} += $len;
+ $. = ++ *$self->{lno};
+ return substr($$buf, $pos, $len);
+}
+
+sub getlines
+{
+ die "getlines() called in scalar context\n" unless wantarray;
+ my $self = shift;
+ my($line, @lines);
+ push(@lines, $line) while defined($line = $self->getline);
+ return @lines;
+}
+
+sub READLINE
+{
+ goto &getlines if wantarray;
+ goto &getline;
+}
+
+sub input_line_number
+{
+ my $self = shift;
+ my $old = *$self->{lno};
+ *$self->{lno} = shift if @_;
+ return $old;
+}
+
+sub truncate
+{
+ my $self = shift;
+ my $len = shift || 0;
+ my $buf = *$self->{buf};
+ if (length($$buf) >= $len) {
+ substr($$buf, $len) = '';
+ *$self->{pos} = $len if $len < *$self->{pos};
+ }
+ else {
+ $$buf .= ($self->pad x ($len - length($$buf)));
+ }
+ return 1;
+}
+
+sub read
+{
+ my $self = shift;
+ my $buf = *$self->{buf};
+ return undef unless $buf;
+
+ my $pos = *$self->{pos};
+ my $rem = length($$buf) - $pos;
+ my $len = $_[1];
+ $len = $rem if $len > $rem;
+ return undef if $len < 0;
+ if (@_ > 2) { # read offset
+ substr($_[0],$_[2]) = substr($$buf, $pos, $len);
+ }
+ else {
+ $_[0] = substr($$buf, $pos, $len);
+ }
+ *$self->{pos} += $len;
+ return $len;
+}
+
+sub write
+{
+ my $self = shift;
+ my $buf = *$self->{buf};
+ return unless $buf;
+
+ my $pos = *$self->{pos};
+ my $slen = length($_[0]);
+ my $len = $slen;
+ my $off = 0;
+ if (@_ > 1) {
+ $len = $_[1] if $_[1] < $len;
+ if (@_ > 2) {
+ $off = $_[2] || 0;
+ die "Offset outside string" if $off > $slen;
+ if ($off < 0) {
+ $off += $slen;
+ die "Offset outside string" if $off < 0;
+ }
+ my $rem = $slen - $off;
+ $len = $rem if $rem < $len;
+ }
+ }
+ substr($$buf, $pos, $len) = substr($_[0], $off, $len);
+ *$self->{pos} += $len;
+ return $len;
+}
+
+*sysread = \&read;
+*syswrite = \&write;
+
+sub stat
+{
+ my $self = shift;
+ return unless $self->opened;
+ return 1 unless wantarray;
+ my $len = length ${*$self->{buf}};
+
+ return (
+ undef, undef, # dev, ino
+ 0666, # filemode
+ 1, # links
+ $>, # user id
+ $), # group id
+ undef, # device id
+ $len, # size
+ undef, # atime
+ undef, # mtime
+ undef, # ctime
+ 512, # blksize
+ int(($len+511)/512) # blocks
+ );
+}
+
+sub FILENO {
+ return undef; # XXX perlfunc says this means the file is closed
+}
+
+sub blocking {
+ my $self = shift;
+ my $old = *$self->{blocking} || 0;
+ *$self->{blocking} = shift if @_;
+ return $old;
+}
+
+my $notmuch = sub { return };
+
+*fileno = $notmuch;
+*error = $notmuch;
+*clearerr = $notmuch;
+*sync = $notmuch;
+*flush = $notmuch;
+*setbuf = $notmuch;
+*setvbuf = $notmuch;
+
+*untaint = $notmuch;
+*autoflush = $notmuch;
+*fcntl = $notmuch;
+*ioctl = $notmuch;
+
+*GETC = \&getc;
+*PRINT = \&print;
+*PRINTF = \&printf;
+*READ = \&read;
+*WRITE = \&write;
+*SEEK = \&seek;
+*TELL = \&getpos;
+*EOF = \&eof;
+*CLOSE = \&close;
+*BINMODE = \&binmode;
+
+
+sub string_ref
+{
+ my $self = shift;
+ return *$self->{buf};
+}
+*sref = \&string_ref;
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::String - Emulate file interface for in-core strings
+
+=head1 SYNOPSIS
+
+ use IO::String;
+ $io = IO::String->new;
+ $io = IO::String->new($var);
+ tie *IO, 'IO::String';
+
+ # read data
+ <$io>;
+ $io->getline;
+ read($io, $buf, 100);
+
+ # write data
+ print $io "string\n";
+ $io->print(@data);
+ syswrite($io, $buf, 100);
+
+ select $io;
+ printf "Some text %s\n", $str;
+
+ # seek
+ $pos = $io->getpos;
+ $io->setpos(0); # rewind
+ $io->seek(-30, -1);
+ seek($io, 0, 0);
+
+=head1 DESCRIPTION
+
+The C<IO::String> module provides the C<IO::File> interface for in-core
+strings. An C<IO::String> object can be attached to a string, and
+makes it possible to use the normal file operations for reading or
+writing data, as well as for seeking to various locations of the string.
+This is useful when you want to use a library module that only
+provides an interface to file handles on data that you have in a string
+variable.
+
+Note that perl-5.8 and better has built-in support for "in memory"
+files, which are set up by passing a reference instead of a filename
+to the open() call. The reason for using this module is that it
+makes the code backwards compatible with older versions of Perl.
+
+The C<IO::String> module provides an interface compatible with
+C<IO::File> as distributed with F<IO-1.20>, but the following methods
+are not available: new_from_fd, fdopen, format_write,
+format_page_number, format_lines_per_page, format_lines_left,
+format_name, format_top_name.
+
+The following methods are specific to the C<IO::String> class:
+
+=over 4
+
+=item $io = IO::String->new
+
+=item $io = IO::String->new( $string )
+
+The constructor returns a newly-created C<IO::String> object. It
+takes an optional argument, which is the string to read from or write
+into. If no $string argument is given, then an internal buffer
+(initially empty) is allocated.
+
+The C<IO::String> object returned is tied to itself. This means
+that you can use most Perl I/O built-ins on it too: readline, <>, getc,
+print, printf, syswrite, sysread, close.
+
+=item $io->open
+
+=item $io->open( $string )
+
+Attaches an existing IO::String object to some other $string, or
+allocates a new internal buffer (if no argument is given). The
+position is reset to 0.
+
+=item $io->string_ref
+
+Returns a reference to the string that is attached to
+the C<IO::String> object. Most useful when you let the C<IO::String>
+create an internal buffer to write into.
+
+=item $io->pad
+
+=item $io->pad( $char )
+
+Specifies the padding to use if
+the string is extended by either the seek() or truncate() methods. It
+is a single character and defaults to "\0".
+
+=item $io->pos
+
+=item $io->pos( $newpos )
+
+Yet another interface for reading and setting the current read/write
+position within the string (the normal getpos/setpos/tell/seek
+methods are also available). The pos() method always returns the
+old position, and if you pass it an argument it sets the new
+position.
+
+There is (deliberately) a difference between the setpos() and seek()
+methods in that seek() extends the string (with the specified
+padding) if you go to a location past the end, whereas setpos()
+just snaps back to the end. If truncate() is used to extend the string,
+then it works as seek().
+
+=back
+
+=head1 BUGS
+
+In Perl versions < 5.6, the TIEHANDLE interface was incomplete.
+If you use such a Perl, then seek(), tell(), eof(), fileno(), binmode() will
+not do anything on an C<IO::String> handle. See L<perltie> for
+details.
+
+=head1 SEE ALSO
+
+L<IO::File>, L<IO::Stringy>, L<perlfunc/open>
+
+=head1 COPYRIGHT
+
+Copyright 1998-2005 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/IO/Stringy.pm b/Master/tlpkg/tlperl/lib/IO/Stringy.pm
new file mode 100755
index 00000000000..978e53caf3f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Stringy.pm
@@ -0,0 +1,446 @@
+package IO::Stringy;
+
+use vars qw($VERSION);
+$VERSION = "2.110";
+
+1;
+__END__
+
+
+=head1 NAME
+
+IO-stringy - I/O on in-core objects like strings and arrays
+
+
+=head1 SYNOPSIS
+
+ IO::
+ ::AtomicFile adpO Write a file which is updated atomically ERYQ
+ ::Lines bdpO I/O handle to read/write to array of lines ERYQ
+ ::Scalar RdpO I/O handle to read/write to a string ERYQ
+ ::ScalarArray RdpO I/O handle to read/write to array of scalars ERYQ
+ ::Wrap RdpO Wrap old-style FHs in standard OO interface ERYQ
+ ::WrapTie adpO Tie your handles & retain full OO interface ERYQ
+
+
+=head1 DESCRIPTION
+
+This toolkit primarily provides modules for performing both traditional
+and object-oriented i/o) on things I<other> than normal filehandles;
+in particular, L<IO::Scalar|IO::Scalar>, L<IO::ScalarArray|IO::ScalarArray>,
+and L<IO::Lines|IO::Lines>.
+
+In the more-traditional IO::Handle front, we
+have L<IO::AtomicFile|IO::AtomicFile>
+which may be used to painlessly create files which are updated
+atomically.
+
+And in the "this-may-prove-useful" corner, we have L<IO::Wrap|IO::Wrap>,
+whose exported wraphandle() function will clothe anything that's not
+a blessed object in an IO::Handle-like wrapper... so you can just
+use OO syntax and stop worrying about whether your function's caller
+handed you a string, a globref, or a FileHandle.
+
+
+=head1 WARNINGS
+
+Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
+it was missing support for C<seek()>, C<tell()>, and C<eof()>.
+Attempting to use these functions with an IO::Scalar, IO::ScalarArray,
+IO::Lines, etc. B<will not work> prior to 5.005_57.
+None of the relevant methods will be invoked by Perl;
+and even worse, this kind of bug can lie dormant for a while.
+If you turn warnings on (via C<$^W> or C<perl -w>), and you see
+something like this...
+
+ seek() on unopened file
+
+...then you are probably trying to use one of these functions
+on one of our IO:: classes with an old Perl. The remedy is to simply
+use the OO version; e.g.:
+
+ $SH->seek(0,0); ### GOOD: will work on any 5.005
+ seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond
+
+
+
+=head1 INSTALLATION
+
+
+=head2 Requirements
+
+As of version 2.x, this toolkit requires Perl 5.005 for
+the IO::Handle subclasses, and 5.005_57 or better is
+B<strongly> recommended. See L<"WARNINGS"> for details.
+
+
+=head2 Directions
+
+Most of you already know the drill...
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+For everyone else out there...
+if you've never installed Perl code before, or you're trying to use
+this in an environment where your sysadmin or ISP won't let you do
+interesting things, B<relax:> since this module contains no binary
+extensions, you can cheat. That means copying the directory tree
+under my "./lib" directory into someplace where your script can "see"
+it. For example, under Linux:
+
+ cp -r IO-stringy-1.234/lib/* /path/to/my/perl/
+
+Now, in your Perl code, do this:
+
+ use lib "/path/to/my/perl";
+ use IO::Scalar; ### or whatever
+
+Ok, now you've been told. At this point, anyone who whines about
+not being given enough information gets an unflattering haiku
+written about them in the next change log. I'll do it.
+Don't think I won't.
+
+
+
+=head1 VERSION
+
+$Id: Stringy.pm,v 1.3 2005/02/10 21:24:05 dfs Exp $
+
+
+
+=head1 TO DO
+
+=over 4
+
+=item (2000/08/02) Finalize $/ support
+
+Graham Barr submitted this patch half a I<year> ago;
+Like a moron, I lost his message under a ton of others,
+and only now have the experimental implementation done.
+
+Will the sudden sensitivity to $/ hose anyone out there?
+I'm worried, so you have to enable it explicitly in 1.x.
+It will be on by default in 2.x, though only IO::Scalar
+has been implemented.
+
+=item (2001/08/08) Remove IO::WrapTie from new IO:: classes
+
+It's not needed. Backwards compatibility could be maintained
+by having new_tie() be identical to new(). Heck, I'll bet
+that IO::WrapTie should be reimplemented so the returned
+object is just like an IO::Scalar in its use of globrefs.
+
+
+=back
+
+
+
+=head1 CHANGE LOG
+
+=over 4
+
+
+=item Version 2.110 (2005/02/10)
+
+Maintainership taken over by DSKOLL <dfs@roaringpenguin.com>
+
+Closed the following bugs at
+https://rt.cpan.org/NoAuth/Bugs.html?Dist=IO-stringy:
+
+=item
+
+2208 IO::ScalarArray->getline does not return undef for EOF if undef($/)
+
+=item
+
+7132 IO-stringy/Makefile.PL bug - name should be module name
+
+=item
+
+11249 IO::Scalar flush shouldn't return undef
+
+=item
+
+2172 $\ (output record separator) not respected
+
+=item
+
+8605 IO::InnerFile::seek() should return 1 on success
+
+=item
+
+4798 *.html in lib/
+
+=item
+
+4369 Improvement: handling of fixed-size reads in IO::Scalar
+
+(Actually, bug 4369 was closed in Version 2.109)
+
+=item Version 2.109 (2003/12/21)
+
+IO::Scalar::getline now works with ref to int.
+I<Thanks to Dominique Quatravaux for this patch.>
+
+
+=item Version 2.108 (2001/08/20)
+
+The terms-of-use have been placed in the distribution file "COPYING".
+Also, small documentation tweaks were made.
+
+
+=item Version 2.105 (2001/08/09)
+
+Added support for various seek() whences to IO::ScalarArray.
+
+Added support for consulting $/ in IO::Scalar and IO::ScalarArray.
+The old C<use_RS()> is not even an option.
+Unsupported record separators will cause a croak().
+
+Added a lot of regression tests to supoprt the above.
+
+Better on-line docs (hyperlinks to individual functions).
+
+
+=item Version 2.103 (2001/08/08)
+
+After sober consideration I have reimplemented IO::Scalar::print()
+so that it once again always seeks to the end of the string.
+Benchmarks show the new implementation to be just as fast as
+Juergen's contributed patch; until someone can convince me otherwise,
+the current, safer implementation stays.
+
+I thought more about giving IO::Scalar two separate handles,
+one for reading and one for writing, as suggested by Binkley.
+His points about what tell() and eof() return are, I think,
+show-stoppers for this feature. Even the manpages for stdio's fseek()
+seem to imply a I<single> file position indicator, not two.
+So I think I will take this off the TO DO list.
+B<Remedy:> you can always have two handles open on the same
+scalar, one which you only write to, and one which you only read from.
+That should give the same effect.
+
+
+=item Version 2.101 (2001/08/07)
+
+B<Alpha release.>
+This is the initial release of the "IO::Scalar and friends are
+now subclasses of IO::Handle". I'm flinging it against the wall.
+Please tell me if the banana sticks. When it does, the banana
+will be called 2.2x.
+
+First off, I<many many thanks to Doug Wilson>, who
+has provided an I<invaluable> service by patching IO::Scalar
+and friends so that they (1) inherit from IO::Handle, (2) automatically
+tie themselves so that the C<new()> objects can be used in native i/o
+constructs, and (3) doing it so that the whole damn thing passes
+its regression tests. As Doug knows, my globref Kung-Fu was not
+up to the task; he graciously provided the patches. This has earned
+him a seat at the L<Co-Authors|"AUTHOR"> table, and the
+right to have me address him as I<sensei>.
+
+Performance of IO::Scalar::print() has been improved by as much as 2x
+for lots of little prints, with the cost of forcing those
+who print-then-seek-then-print to explicitly seek to end-of-string
+before printing again.
+I<Thanks to Juergen Zeller for this patch.>
+
+Added the COPYING file, which had been missing from prior versions.
+I<Thanks to Albert Chin-A-Young for pointing this out.>
+
+IO::Scalar consults $/ by default (1.x ignored it by default).
+Yes, I still need to support IO::ScalarArray.
+
+
+=item Version 1.221 (2001/08/07)
+
+I threatened in L<"INSTALLATION"> to write an unflattering haiku
+about anyone who whined that I gave them insufficient information...
+but it turns out that I left out a crucial direction. D'OH!
+I<Thanks to David Beroff for the "patch" and the haiku...>
+
+ Enough info there?
+ Here's unflattering haiku:
+ Forgot the line, "make"! ;-)
+
+
+
+=item Version 1.220 (2001/04/03)
+
+Added untested SEEK, TELL, and EOF methods to IO::Scalar
+and IO::ScalarArray to support corresponding functions for
+tied filehandles: untested, because I'm still running 5.00556
+and Perl is complaining about "tell() on unopened file".
+I<Thanks to Graham Barr for the suggestion.>
+
+Removed not-fully-blank lines from modules; these were causing
+lots of POD-related warnings.
+I<Thanks to Nicolas Joly for the suggestion.>
+
+
+=item Version 1.219 (2001/02/23)
+
+IO::Scalar objects can now be made sensitive to $/ .
+Pains were taken to keep the fast code fast while adding this feature.
+I<Cheers to Graham Barr for submitting his patch;
+jeers to me for losing his email for 6 months.>
+
+
+=item Version 1.218 (2001/02/23)
+
+IO::Scalar has a new sysseek() method.
+I<Thanks again to Richard Jones.>
+
+New "TO DO" section, because people who submit patches/ideas should
+at least know that they're in the system... and that I won't lose
+their stuff. Please read it.
+
+New entries in L<"AUTHOR">.
+Please read those too.
+
+
+
+=item Version 1.216 (2000/09/28)
+
+B<IO::Scalar and IO::ScalarArray now inherit from IO::Handle.>
+I thought I'd remembered a problem with this ages ago, related to
+the fact that these IO:: modules don't have "real" filehandles,
+but the problem apparently isn't surfacing now.
+If you suddenly encounter Perl warnings during global destruction
+(especially if you're using tied filehandles), then please let me know!
+I<Thanks to B. K. Oxley (binkley) for this.>
+
+B<Nasty bug fixed in IO::Scalar::write().>
+Apparently, the offset and the number-of-bytes arguments were,
+for all practical purposes, I<reversed.> You were okay if
+you did all your writing with print(), but boy was I<this> a stupid bug!
+I<Thanks to Richard Jones for finding this one.
+For you, Rich, a double-length haiku:>
+
+ Newspaper headline
+ typeset by dyslexic man
+ loses urgency
+
+ BABY EATS FISH is
+ simply not equivalent
+ to FISH EATS BABY
+
+B<New sysread and syswrite methods for IO::Scalar.>
+I<Thanks again to Richard Jones for this.>
+
+
+=item Version 1.215 (2000/09/05)
+
+Added 'bool' overload to '""' overload, so object always evaluates
+to true. (Whew. Glad I caught this before it went to CPAN.)
+
+
+=item Version 1.214 (2000/09/03)
+
+Evaluating an IO::Scalar in a string context now yields
+the underlying string.
+I<Thanks to B. K. Oxley (binkley) for this.>
+
+
+=item Version 1.213 (2000/08/16)
+
+Minor documentation fixes.
+
+
+=item Version 1.212 (2000/06/02)
+
+Fixed IO::InnerFile incompatibility with Perl5.004.
+I<Thanks to many folks for reporting this.>
+
+
+=item Version 1.210 (2000/04/17)
+
+Added flush() and other no-op methods.
+I<Thanks to Doru Petrescu for suggesting this.>
+
+
+=item Version 1.209 (2000/03/17)
+
+Small bug fixes.
+
+
+=item Version 1.208 (2000/03/14)
+
+Incorporated a number of contributed patches and extensions,
+mostly related to speed hacks, support for "offset", and
+WRITE/CLOSE methods.
+I<Thanks to Richard Jones, Doru Petrescu, and many others.>
+
+
+
+=item Version 1.206 (1999/04/18)
+
+Added creation of ./testout when Makefile.PL is run.
+
+
+=item Version 1.205 (1999/01/15)
+
+Verified for Perl5.005.
+
+
+=item Version 1.202 (1998/04/18)
+
+New IO::WrapTie and IO::AtomicFile added.
+
+
+=item Version 1.110
+
+Added IO::WrapTie.
+
+
+=item Version 1.107
+
+Added IO::Lines, and made some bug fixes to IO::ScalarArray.
+Also, added getc().
+
+
+=item Version 1.105
+
+No real changes; just upgraded IO::Wrap to have a $VERSION string.
+
+=back
+
+
+
+
+=head1 AUTHOR
+
+=over 4
+
+=item Primary Maintainer
+
+David F. Skoll (F<dfs@roaringpenguin.com>).
+
+=item Original Author
+
+Eryq (F<eryq@zeegee.com>).
+President, ZeeGee Software Inc (F<http://www.zeegee.com>).
+
+=item Co-Authors
+
+For all their bug reports and patch submissions, the following
+are officially recognized:
+
+ Richard Jones
+ B. K. Oxley (binkley)
+ Doru Petrescu
+ Doug Wilson (for picking up the ball I dropped, and doing tie() right)
+
+
+=back
+
+Go to F<http://www.zeegee.com> for the latest downloads
+and on-line documentation for this module.
+
+Enjoy. Yell if it breaks.
+
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Bunzip2.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Bunzip2.pm
new file mode 100755
index 00000000000..98677e3c09f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Bunzip2.pm
@@ -0,0 +1,112 @@
+package IO::Uncompress::Adapter::Bunzip2;
+
+use strict;
+use warnings;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(:Status);
+
+use Compress::Raw::Bzip2 2.024 ;
+
+our ($VERSION, @ISA);
+$VERSION = '2.024';
+
+sub mkUncompObject
+{
+ my $small = shift || 0;
+ my $verbosity = shift || 0;
+
+ my ($inflate, $status) = new Compress::Raw::Bunzip2(1, 1, $small, $verbosity, 1);
+
+ return (undef, "Could not create Inflation object: $status", $status)
+ if $status != BZ_OK ;
+
+ return bless {'Inf' => $inflate,
+ 'CompSize' => 0,
+ 'UnCompSize' => 0,
+ 'Error' => '',
+ 'ConsumesInput' => 1,
+ } ;
+
+}
+
+sub uncompr
+{
+ my $self = shift ;
+ my $from = shift ;
+ my $to = shift ;
+ my $eof = shift ;
+
+ my $inf = $self->{Inf};
+
+ my $status = $inf->bzinflate($from, $to);
+ $self->{ErrorNo} = $status;
+
+ if ($status != BZ_OK && $status != BZ_STREAM_END )
+ {
+ $self->{Error} = "Inflation Error: $status";
+ return STATUS_ERROR;
+ }
+
+
+ return STATUS_OK if $status == BZ_OK ;
+ return STATUS_ENDSTREAM if $status == BZ_STREAM_END ;
+ return STATUS_ERROR ;
+}
+
+
+sub reset
+{
+ my $self = shift ;
+
+ my ($inf, $status) = new Compress::Raw::Bunzip2();
+ $self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ;
+
+ if ($status != BZ_OK)
+ {
+ $self->{Error} = "Cannot create Inflate object: $status";
+ return STATUS_ERROR;
+ }
+
+ $self->{Inf} = $inf;
+
+ return STATUS_OK ;
+}
+
+sub compressedBytes
+{
+ my $self = shift ;
+ $self->{Inf}->compressedBytes();
+}
+
+sub uncompressedBytes
+{
+ my $self = shift ;
+ $self->{Inf}->uncompressedBytes();
+}
+
+sub crc32
+{
+ my $self = shift ;
+ #$self->{Inf}->crc32();
+}
+
+sub adler32
+{
+ my $self = shift ;
+ #$self->{Inf}->adler32();
+}
+
+sub sync
+{
+ my $self = shift ;
+ #( $self->{Inf}->inflateSync(@_) == BZ_OK)
+ # ? STATUS_OK
+ # : STATUS_ERROR ;
+}
+
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm
new file mode 100755
index 00000000000..27de6e0f36b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Identity.pm
@@ -0,0 +1,105 @@
+package IO::Uncompress::Adapter::Identity;
+
+use warnings;
+use strict;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(:Status);
+
+our ($VERSION);
+
+$VERSION = '2.024';
+
+use Compress::Raw::Zlib 2.024 ();
+
+sub mkUncompObject
+{
+ my $crc32 = 1; #shift ;
+ my $adler32 = shift;
+
+ bless { 'CompSize' => 0,
+ 'UnCompSize' => 0,
+ 'wantCRC32' => $crc32,
+ 'CRC32' => Compress::Raw::Zlib::crc32(''),
+ 'wantADLER32'=> $adler32,
+ 'ADLER32' => Compress::Raw::Zlib::adler32(''),
+ 'ConsumesInput' => 1,
+
+ } ;
+}
+
+sub uncompr
+{
+ my $self = shift;
+ my $eof = $_[2];
+
+ if (defined ${ $_[0] } && length ${ $_[0] }) {
+ $self->{CompSize} += length ${ $_[0] } ;
+ $self->{UnCompSize} = $self->{CompSize} ;
+
+ $self->{CRC32} = Compress::Raw::Zlib::crc32($_[0], $self->{CRC32})
+ if $self->{wantCRC32};
+
+ $self->{ADLER32} = Compress::Zlib::adler32($_[0], $self->{ADLER32})
+ if $self->{wantADLER32};
+
+ ${ $_[1] } .= ${ $_[0] };
+ ${ $_[0] } = "";
+ }
+
+ return STATUS_ENDSTREAM if $eof;
+ return STATUS_OK ;
+}
+
+sub reset
+{
+ my $self = shift;
+
+ $self->{CompSize} = 0;
+ $self->{UnCompSize} = 0;
+ $self->{CRC32} = Compress::Raw::Zlib::crc32('');
+ $self->{ADLER32} = Compress::Raw::Zlib::adler32('');
+
+ return STATUS_OK ;
+}
+
+
+#sub count
+#{
+# my $self = shift ;
+# return $self->{UnCompSize} ;
+#}
+
+sub compressedBytes
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+sub uncompressedBytes
+{
+ my $self = shift ;
+ return $self->{UnCompSize} ;
+}
+
+sub sync
+{
+ return STATUS_OK ;
+}
+
+sub crc32
+{
+ my $self = shift ;
+ return $self->{CRC32};
+}
+
+sub adler32
+{
+ my $self = shift ;
+ return $self->{ADLER32};
+}
+
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Inflate.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Inflate.pm
new file mode 100755
index 00000000000..aac1e413ffe
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Adapter/Inflate.pm
@@ -0,0 +1,158 @@
+package IO::Uncompress::Adapter::Inflate;
+
+use strict;
+use warnings;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(:Status);
+use Compress::Raw::Zlib 2.024 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS);
+
+our ($VERSION);
+$VERSION = '2.024';
+
+
+
+sub mkUncompObject
+{
+ my $crc32 = shift || 1;
+ my $adler32 = shift || 1;
+ my $scan = shift || 0;
+
+ my $inflate ;
+ my $status ;
+
+ if ($scan)
+ {
+ ($inflate, $status) = new Compress::Raw::Zlib::InflateScan
+ #LimitOutput => 1,
+ CRC32 => $crc32,
+ ADLER32 => $adler32,
+ WindowBits => - MAX_WBITS ;
+ }
+ else
+ {
+ ($inflate, $status) = new Compress::Raw::Zlib::Inflate
+ AppendOutput => 1,
+ LimitOutput => 1,
+ CRC32 => $crc32,
+ ADLER32 => $adler32,
+ WindowBits => - MAX_WBITS ;
+ }
+
+ return (undef, "Could not create Inflation object: $status", $status)
+ if $status != Z_OK ;
+
+ return bless {'Inf' => $inflate,
+ 'CompSize' => 0,
+ 'UnCompSize' => 0,
+ 'Error' => '',
+ 'ConsumesInput' => 1,
+ } ;
+
+}
+
+sub uncompr
+{
+ my $self = shift ;
+ my $from = shift ;
+ my $to = shift ;
+ my $eof = shift ;
+
+ my $inf = $self->{Inf};
+
+ my $status = $inf->inflate($from, $to, $eof);
+ $self->{ErrorNo} = $status;
+
+ if ($status != Z_OK && $status != Z_STREAM_END && $status != Z_BUF_ERROR)
+ {
+ $self->{Error} = "Inflation Error: $status";
+ return STATUS_ERROR;
+ }
+
+ return STATUS_OK if $status == Z_BUF_ERROR ; # ???
+ return STATUS_OK if $status == Z_OK ;
+ return STATUS_ENDSTREAM if $status == Z_STREAM_END ;
+ return STATUS_ERROR ;
+}
+
+sub reset
+{
+ my $self = shift ;
+ $self->{Inf}->inflateReset();
+
+ return STATUS_OK ;
+}
+
+#sub count
+#{
+# my $self = shift ;
+# $self->{Inf}->inflateCount();
+#}
+
+sub crc32
+{
+ my $self = shift ;
+ $self->{Inf}->crc32();
+}
+
+sub compressedBytes
+{
+ my $self = shift ;
+ $self->{Inf}->compressedBytes();
+}
+
+sub uncompressedBytes
+{
+ my $self = shift ;
+ $self->{Inf}->uncompressedBytes();
+}
+
+sub adler32
+{
+ my $self = shift ;
+ $self->{Inf}->adler32();
+}
+
+sub sync
+{
+ my $self = shift ;
+ ( $self->{Inf}->inflateSync(@_) == Z_OK)
+ ? STATUS_OK
+ : STATUS_ERROR ;
+}
+
+
+sub getLastBlockOffset
+{
+ my $self = shift ;
+ $self->{Inf}->getLastBlockOffset();
+}
+
+sub getEndOffset
+{
+ my $self = shift ;
+ $self->{Inf}->getEndOffset();
+}
+
+sub resetLastBlockByte
+{
+ my $self = shift ;
+ $self->{Inf}->resetLastBlockByte(@_);
+}
+
+sub createDeflateStream
+{
+ my $self = shift ;
+ my $deflate = $self->{Inf}->createDeflateStream(@_);
+ return bless {'Def' => $deflate,
+ 'CompSize' => 0,
+ 'UnCompSize' => 0,
+ 'Error' => '',
+ }, 'IO::Compress::Adapter::Deflate';
+}
+
+1;
+
+
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm
new file mode 100755
index 00000000000..68038f5d374
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyInflate.pm
@@ -0,0 +1,987 @@
+package IO::Uncompress::AnyInflate ;
+
+# for RFC1950, RFC1951 or RFC1952
+
+use strict;
+use warnings;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject);
+
+use IO::Uncompress::Adapter::Inflate 2.024 ();
+
+
+use IO::Uncompress::Base 2.024 ;
+use IO::Uncompress::Gunzip 2.024 ;
+use IO::Uncompress::Inflate 2.024 ;
+use IO::Uncompress::RawInflate 2.024 ;
+use IO::Uncompress::Unzip 2.024 ;
+
+require Exporter ;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError);
+
+$VERSION = '2.024';
+$AnyInflateError = '';
+
+@ISA = qw( Exporter IO::Uncompress::Base );
+@EXPORT_OK = qw( $AnyInflateError anyinflate ) ;
+%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+# TODO - allow the user to pick a set of the three formats to allow
+# or just assume want to auto-detect any of the three formats.
+
+sub new
+{
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$AnyInflateError);
+ $obj->_create(undef, 0, @_);
+}
+
+sub anyinflate
+{
+ my $obj = createSelfTiedObject(undef, \$AnyInflateError);
+ return $obj->_inf(@_) ;
+}
+
+sub getExtraParams
+{
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+ return ( 'RawInflate' => [1, 1, Parse_boolean, 0] ) ;
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ # any always needs both crc32 and adler32
+ $got->value('CRC32' => 1);
+ $got->value('ADLER32' => 1);
+
+ return 1;
+}
+
+sub mkUncomp
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ my @possible = qw( Inflate Gunzip Unzip );
+ unshift @possible, 'RawInflate'
+ if 1 || $got->value('RawInflate');
+
+ my $magic = $self->ckMagic( @possible );
+
+ if ($magic) {
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ return 1;
+ }
+
+ return 0 ;
+}
+
+
+
+sub ckMagic
+{
+ my $self = shift;
+ my @names = @_ ;
+
+ my $keep = ref $self ;
+ for my $class ( map { "IO::Uncompress::$_" } @names)
+ {
+ bless $self => $class;
+ my $magic = $self->ckMagic();
+
+ if ($magic)
+ {
+ #bless $self => $class;
+ return $magic ;
+ }
+
+ $self->pushBack(*$self->{HeaderPending}) ;
+ *$self->{HeaderPending} = '' ;
+ }
+
+ bless $self => $keep;
+ return undef;
+}
+
+1 ;
+
+__END__
+
+
+=head1 NAME
+
+IO::Uncompress::AnyInflate - Uncompress zlib-based (zip, gzip) file/buffer
+
+=head1 SYNOPSIS
+
+ use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ;
+
+ my $status = anyinflate $input => $output [,OPTS]
+ or die "anyinflate failed: $AnyInflateError\n";
+
+ my $z = new IO::Uncompress::AnyInflate $input [OPTS]
+ or die "anyinflate failed: $AnyInflateError\n";
+
+ $status = $z->read($buffer)
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+ $line = $z->getline()
+ $char = $z->getc()
+ $char = $z->ungetc()
+ $char = $z->opened()
+
+ $status = $z->inflateSync()
+
+ $data = $z->trailingData()
+ $status = $z->nextStream()
+ $data = $z->getHeaderInfo()
+ $z->tell()
+ $z->seek($position, $whence)
+ $z->binmode()
+ $z->fileno()
+ $z->eof()
+ $z->close()
+
+ $AnyInflateError ;
+
+ # IO::File mode
+
+ <$z>
+ read($z, $buffer);
+ read($z, $buffer, $length);
+ read($z, $buffer, $length, $offset);
+ tell($z)
+ seek($z, $position, $whence)
+ binmode($z)
+ fileno($z)
+ eof($z)
+ close($z)
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows the reading of
+files/buffers that have been compressed in a number of formats that use the
+zlib compression library.
+
+The formats supported are
+
+=over 5
+
+=item RFC 1950
+
+=item RFC 1951 (optionally)
+
+=item gzip (RFC 1952)
+
+=item zip
+
+=back
+
+The module will auto-detect which, if any, of the supported
+compression formats is being used.
+
+=head1 Functional Interface
+
+A top-level function, C<anyinflate>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
+
+ use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ;
+
+ anyinflate $input => $output [,OPTS]
+ or die "anyinflate failed: $AnyInflateError\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 anyinflate $input => $output [, OPTS]
+
+C<anyinflate> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the compressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is uncompressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<anyinflate> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<anyinflate> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
+concatenation of all the uncompressed data from each of the input
+files/buffers.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<anyinflate>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<anyinflate> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<anyinflate> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeOut => 0|1 >>
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+The behaviour of this option is dependent on the type of output data
+stream.
+
+=over 5
+
+=item * A Buffer
+
+If C<Append> is enabled, all uncompressed data will be append to the end of
+the output buffer. Otherwise the output buffer will be cleared before any
+uncompressed data is written to it.
+
+=item * A Filename
+
+If C<Append> is enabled, the file will be opened in append mode. Otherwise
+the contents of the file, if any, will be truncated before any uncompressed
+data is written to it.
+
+=item * A Filehandle
+
+If C<Append> is enabled, the filehandle will be positioned to the end of
+the file via a call to C<seek> before any uncompressed data is
+written to it. Otherwise the file pointer will not be moved.
+
+=back
+
+When C<Append> is specified, and set to true, it will I<append> all uncompressed
+data to the output data stream.
+
+So when the output is a filehandle it will carry out a seek to the eof
+before writing any uncompressed data. If the output is a filename, it will be opened for
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
+
+Conversely when C<Append> is not specified, or it is present and is set to
+false, it will operate as follows.
+
+When the output is a filename, it will truncate the contents of the file
+before writing any uncompressed data. If the output is a filehandle
+its position will not be changed. If the output is a buffer, it will be
+wiped before any uncompressed data is output.
+
+Defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+If the input file/buffer contains multiple compressed data streams, this
+option will uncompress the whole lot as a single data stream.
+
+Defaults to 0.
+
+=item C<< TrailingData => $scalar >>
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt.Compressed> and write the
+uncompressed data to the file C<file1.txt>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ;
+
+ my $input = "file1.txt.Compressed";
+ my $output = "file1.txt";
+ anyinflate $input => $output
+ or die "anyinflate failed: $AnyInflateError\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+uncompressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt.Compressed"
+ or die "Cannot open 'file1.txt.Compressed': $!\n" ;
+ my $buffer ;
+ anyinflate $input => \$buffer
+ or die "anyinflate failed: $AnyInflateError\n";
+
+To uncompress all files in the directory "/my/home" that match "*.txt.Compressed" and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ;
+
+ anyinflate '</my/home/*.txt.Compressed>' => '</my/home/#1.txt>'
+ or die "anyinflate failed: $AnyInflateError\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ;
+
+ for my $input ( glob "/my/home/*.txt.Compressed" )
+ {
+ my $output = $input;
+ $output =~ s/.Compressed// ;
+ anyinflate $input => $output
+ or die "Error compressing '$input': $AnyInflateError\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for IO::Uncompress::AnyInflate is shown below
+
+ my $z = new IO::Uncompress::AnyInflate $input [OPTS]
+ or die "IO::Uncompress::AnyInflate failed: $AnyInflateError\n";
+
+Returns an C<IO::Uncompress::AnyInflate> object on success and undef on failure.
+The variable C<$AnyInflateError> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::AnyInflate can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
+
+ $line = $z->getline();
+ $line = <$z>;
+
+The mandatory parameter C<$input> is used to determine the source of the
+compressed data. This parameter can take one of three forms.
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a scalar, it is assumed to be a filename. This
+file will be opened for reading and the compressed data will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the compressed data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the compressed data will be read from
+C<$$output>.
+
+=back
+
+=head2 Constructor Options
+
+The option names defined below are case insensitive and can be optionally
+prefixed by a '-'. So all of the following are valid
+
+ -AutoClose
+ -autoclose
+ AUTOCLOSE
+ autoclose
+
+OPTS is a combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$input> parameter is a filehandle. If
+specified, and the value is true, it will result in the file being closed once
+either the C<close> method is called or the IO::Uncompress::AnyInflate object is
+destroyed.
+
+This parameter defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+Allows multiple concatenated compressed streams to be treated as a single
+compressed stream. Decompression will stop once either the end of the
+file/buffer is reached, an error is encountered (premature eof, corrupt
+compressed data) or the end of a stream is not immediately followed by the
+start of another stream.
+
+This parameter defaults to 0.
+
+=item C<< Prime => $string >>
+
+This option will uncompress the contents of C<$string> before processing the
+input file/buffer.
+
+This option can be useful when the compressed data is embedded in another
+file/data structure and it is not possible to work out where the compressed
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
+
+=item C<< Transparent => 0|1 >>
+
+If this option is set and the input file/buffer is not compressed data,
+the module will allow reading of it anyway.
+
+In addition, if the input file/buffer does contain compressed data and
+there is non-compressed data immediately following it, setting this option
+will make this module treat the whole file/bufffer as a single data stream.
+
+This option defaults to 1.
+
+=item C<< BlockSize => $num >>
+
+When reading the compressed input data, IO::Uncompress::AnyInflate will read it in
+blocks of C<$num> bytes.
+
+This option defaults to 4096.
+
+=item C<< InputLength => $size >>
+
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
+
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
+compressed data stream.
+
+This option defaults to off.
+
+=item C<< Append => 0|1 >>
+
+This option controls what the C<read> method does with uncompressed data.
+
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
+
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
+
+Defaults to 0.
+
+=item C<< Strict => 0|1 >>
+
+This option controls whether the extra checks defined below are used when
+carrying out the decompression. When Strict is on, the extra tests are
+carried out, when Strict is off they are not.
+
+The default for this option is off.
+
+If the input is an RFC 1950 data stream, the following will be checked:
+
+=over 5
+
+=item 1
+
+The ADLER32 checksum field must be present.
+
+=item 2
+
+The value of the ADLER32 field read must match the adler32 value of the
+uncompressed data actually contained in the file.
+
+=back
+
+If the input is a gzip (RFC 1952) data stream, the following will be checked:
+
+=over 5
+
+=item 1
+
+If the FHCRC bit is set in the gzip FLG header byte, the CRC16 bytes in the
+header must match the crc16 value of the gzip header actually read.
+
+=item 2
+
+If the gzip header contains a name field (FNAME) it consists solely of ISO
+8859-1 characters.
+
+=item 3
+
+If the gzip header contains a comment field (FCOMMENT) it consists solely
+of ISO 8859-1 characters plus line-feed.
+
+=item 4
+
+If the gzip FEXTRA header field is present it must conform to the sub-field
+structure as defined in RFC 1952.
+
+=item 5
+
+The CRC32 and ISIZE trailer fields must be present.
+
+=item 6
+
+The value of the CRC32 field read must match the crc32 value of the
+uncompressed data actually contained in the gzip file.
+
+=item 7
+
+The value of the ISIZE fields read must match the length of the
+uncompressed data actually read from the file.
+
+=back
+
+=item C<< RawInflate => 0|1 >>
+
+When auto-detecting the compressed format, try to test for raw-deflate (RFC
+1951) content using the C<IO::Uncompress::RawInflate> module.
+
+The reason this is not default behaviour is because RFC 1951 content can
+only be detected by attempting to uncompress it. This process is error
+prone and can result is false positives.
+
+Defaults to 0.
+
+=item C<< ParseExtra => 0|1 >>
+If the gzip FEXTRA header field is present and this option is set, it will
+force the module to check that it conforms to the sub-field structure as
+defined in RFC 1952.
+
+If the C<Strict> is on it will automatically enable this option.
+
+Defaults to 0.
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer)
+
+Reads a block of compressed data (the size the the compressed block is
+determined by the C<Buffer> option in the constructor), uncompresses it and
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+
+ $status = read($z, $buffer, $length)
+ $status = read($z, $buffer, $length, $offset)
+
+Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
+
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 getline
+
+Usage is
+
+ $line = $z->getline()
+ $line = <$z>
+
+Reads a single line.
+
+This method fully supports the use of of the variable C<$/> (or
+C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
+determine what constitutes an end of line. Paragraph mode, record mode and
+file slurp mode are all supported.
+
+=head2 getc
+
+Usage is
+
+ $char = $z->getc()
+
+Read a single character.
+
+=head2 ungetc
+
+Usage is
+
+ $char = $z->ungetc($string)
+
+=head2 inflateSync
+
+Usage is
+
+ $status = $z->inflateSync()
+
+TODO
+
+=head2 getHeaderInfo
+
+Usage is
+
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the end of the compressed input stream has been reached.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the input file/buffer.
+It is a fatal error to attempt to seek backward.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+Returns the current uncompressed line number. If C<EXPR> is present it has
+the effect of setting the line number. Note that setting the line number
+does not change the current position within the file/buffer being read.
+
+The contents of C<$/> are used to to determine what constitutes a line
+terminator.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Uncompress::AnyInflate object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Uncompress::AnyInflate
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 nextStream
+
+Usage is
+
+ my $status = $z->nextStream();
+
+Skips to the next compressed data stream in the input file/buffer. If a new
+compressed data stream is found, the eof marker will be cleared and C<$.>
+will be reset to 0.
+
+Returns 1 if a new stream was found, 0 if none was found, and -1 if an
+error was encountered.
+
+=head2 trailingData
+
+Usage is
+
+ my $data = $z->trailingData();
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete. It only makes sense to call
+this method once the end of the compressed data stream has been
+encountered.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option in the constructor.
+
+=head1 Importing
+
+No symbolic constants are required by this IO::Uncompress::AnyInflate at present.
+
+=over 5
+
+=item :all
+
+Imports C<anyinflate> and C<$AnyInflateError>.
+Same as doing this
+
+ use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ;
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Working with Net::FTP
+
+See L<IO::Uncompress::AnyInflate::FAQ|IO::Uncompress::AnyInflate::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm
new file mode 100755
index 00000000000..5984921e25b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/AnyUncompress.pm
@@ -0,0 +1,1018 @@
+package IO::Uncompress::AnyUncompress ;
+
+use strict;
+use warnings;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject);
+
+use IO::Uncompress::Base 2.024 ;
+
+
+require Exporter ;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError);
+
+$VERSION = '2.024';
+$AnyUncompressError = '';
+
+@ISA = qw( Exporter IO::Uncompress::Base );
+@EXPORT_OK = qw( $AnyUncompressError anyuncompress ) ;
+%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+# TODO - allow the user to pick a set of the three formats to allow
+# or just assume want to auto-detect any of the three formats.
+
+BEGIN
+{
+ eval ' use IO::Uncompress::Adapter::Inflate 2.024 ;';
+ eval ' use IO::Uncompress::Adapter::Bunzip2 2.024 ;';
+ eval ' use IO::Uncompress::Adapter::LZO 2.024 ;';
+ eval ' use IO::Uncompress::Adapter::Lzf 2.024 ;';
+ eval ' use IO::Uncompress::Adapter::UnLzma 2.020 ;';
+ eval ' use IO::Uncompress::Adapter::UnXz 2.020 ;';
+
+ eval ' use IO::Uncompress::Bunzip2 2.024 ;';
+ eval ' use IO::Uncompress::UnLzop 2.024 ;';
+ eval ' use IO::Uncompress::Gunzip 2.024 ;';
+ eval ' use IO::Uncompress::Inflate 2.024 ;';
+ eval ' use IO::Uncompress::RawInflate 2.024 ;';
+ eval ' use IO::Uncompress::Unzip 2.024 ;';
+ eval ' use IO::Uncompress::UnLzf 2.024 ;';
+ eval ' use IO::Uncompress::UnLzma 2.024 ;';
+ eval ' use IO::Uncompress::UnXz 2.024 ;';
+}
+
+sub new
+{
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$AnyUncompressError);
+ $obj->_create(undef, 0, @_);
+}
+
+sub anyuncompress
+{
+ my $obj = createSelfTiedObject(undef, \$AnyUncompressError);
+ return $obj->_inf(@_) ;
+}
+
+sub getExtraParams
+{
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+ return ( 'RawInflate' => [1, 1, Parse_boolean, 0] ,
+ 'UnLzma' => [1, 1, Parse_boolean, 0] ) ;
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ # any always needs both crc32 and adler32
+ $got->value('CRC32' => 1);
+ $got->value('ADLER32' => 1);
+
+ return 1;
+}
+
+sub mkUncomp
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ my $magic ;
+
+ # try zlib first
+ if (defined $IO::Uncompress::RawInflate::VERSION )
+ {
+ my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ my @possible = qw( Inflate Gunzip Unzip );
+ unshift @possible, 'RawInflate'
+ if $got->value('RawInflate');
+
+ $magic = $self->ckMagic( @possible );
+
+ if ($magic) {
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ return 1;
+ }
+ }
+
+ if (defined $IO::Uncompress::UnLzma::VERSION && $got->value('UnLzma'))
+ {
+ my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::UnLzma::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ my @possible = qw( UnLzma );
+ #unshift @possible, 'RawInflate'
+ # if $got->value('RawInflate');
+
+ if ( *$self->{Info} = $self->ckMagic( @possible ))
+ {
+ return 1;
+ }
+ }
+
+ if (defined $IO::Uncompress::UnXz::VERSION and
+ $magic = $self->ckMagic('UnXz')) {
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ my ($obj, $errstr, $errno) =
+ IO::Uncompress::Adapter::UnXz::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ return 1;
+ }
+
+ if (defined $IO::Uncompress::Bunzip2::VERSION and
+ $magic = $self->ckMagic('Bunzip2')) {
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Bunzip2::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ return 1;
+ }
+
+ if (defined $IO::Uncompress::UnLzop::VERSION and
+ $magic = $self->ckMagic('UnLzop')) {
+
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::LZO::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ return 1;
+ }
+
+ if (defined $IO::Uncompress::UnLzf::VERSION and
+ $magic = $self->ckMagic('UnLzf')) {
+
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Lzf::mkUncompObject();
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ return 1;
+ }
+
+ return 0 ;
+}
+
+
+
+sub ckMagic
+{
+ my $self = shift;
+ my @names = @_ ;
+
+ my $keep = ref $self ;
+ for my $class ( map { "IO::Uncompress::$_" } @names)
+ {
+ bless $self => $class;
+ my $magic = $self->ckMagic();
+
+ if ($magic)
+ {
+ #bless $self => $class;
+ return $magic ;
+ }
+
+ $self->pushBack(*$self->{HeaderPending}) ;
+ *$self->{HeaderPending} = '' ;
+ }
+
+ bless $self => $keep;
+ return undef;
+}
+
+1 ;
+
+__END__
+
+
+=head1 NAME
+
+IO::Uncompress::AnyUncompress - Uncompress gzip, zip, bzip2 or lzop file/buffer
+
+=head1 SYNOPSIS
+
+ use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ;
+
+ my $status = anyuncompress $input => $output [,OPTS]
+ or die "anyuncompress failed: $AnyUncompressError\n";
+
+ my $z = new IO::Uncompress::AnyUncompress $input [OPTS]
+ or die "anyuncompress failed: $AnyUncompressError\n";
+
+ $status = $z->read($buffer)
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+ $line = $z->getline()
+ $char = $z->getc()
+ $char = $z->ungetc()
+ $char = $z->opened()
+
+ $data = $z->trailingData()
+ $status = $z->nextStream()
+ $data = $z->getHeaderInfo()
+ $z->tell()
+ $z->seek($position, $whence)
+ $z->binmode()
+ $z->fileno()
+ $z->eof()
+ $z->close()
+
+ $AnyUncompressError ;
+
+ # IO::File mode
+
+ <$z>
+ read($z, $buffer);
+ read($z, $buffer, $length);
+ read($z, $buffer, $length, $offset);
+ tell($z)
+ seek($z, $position, $whence)
+ binmode($z)
+ fileno($z)
+ eof($z)
+ close($z)
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows the reading of
+files/buffers that have been compressed with a variety of compression
+libraries.
+
+The formats supported are:
+
+=over 5
+
+=item RFC 1950
+
+=item RFC 1951 (optionally)
+
+=item gzip (RFC 1952)
+
+=item zip
+
+=item bzip2
+
+=item lzop
+
+=item lzf
+
+=item lzma
+
+=item xz
+
+=back
+
+The module will auto-detect which, if any, of the supported
+compression formats is being used.
+
+=head1 Functional Interface
+
+A top-level function, C<anyuncompress>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
+
+ use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ;
+
+ anyuncompress $input => $output [,OPTS]
+ or die "anyuncompress failed: $AnyUncompressError\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 anyuncompress $input => $output [, OPTS]
+
+C<anyuncompress> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the compressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is uncompressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<anyuncompress> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<anyuncompress> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
+concatenation of all the uncompressed data from each of the input
+files/buffers.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<anyuncompress>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<anyuncompress> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<anyuncompress> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeOut => 0|1 >>
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+The behaviour of this option is dependent on the type of output data
+stream.
+
+=over 5
+
+=item * A Buffer
+
+If C<Append> is enabled, all uncompressed data will be append to the end of
+the output buffer. Otherwise the output buffer will be cleared before any
+uncompressed data is written to it.
+
+=item * A Filename
+
+If C<Append> is enabled, the file will be opened in append mode. Otherwise
+the contents of the file, if any, will be truncated before any uncompressed
+data is written to it.
+
+=item * A Filehandle
+
+If C<Append> is enabled, the filehandle will be positioned to the end of
+the file via a call to C<seek> before any uncompressed data is
+written to it. Otherwise the file pointer will not be moved.
+
+=back
+
+When C<Append> is specified, and set to true, it will I<append> all uncompressed
+data to the output data stream.
+
+So when the output is a filehandle it will carry out a seek to the eof
+before writing any uncompressed data. If the output is a filename, it will be opened for
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
+
+Conversely when C<Append> is not specified, or it is present and is set to
+false, it will operate as follows.
+
+When the output is a filename, it will truncate the contents of the file
+before writing any uncompressed data. If the output is a filehandle
+its position will not be changed. If the output is a buffer, it will be
+wiped before any uncompressed data is output.
+
+Defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+If the input file/buffer contains multiple compressed data streams, this
+option will uncompress the whole lot as a single data stream.
+
+Defaults to 0.
+
+=item C<< TrailingData => $scalar >>
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt.Compressed> and write the
+uncompressed data to the file C<file1.txt>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ;
+
+ my $input = "file1.txt.Compressed";
+ my $output = "file1.txt";
+ anyuncompress $input => $output
+ or die "anyuncompress failed: $AnyUncompressError\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+uncompressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt.Compressed"
+ or die "Cannot open 'file1.txt.Compressed': $!\n" ;
+ my $buffer ;
+ anyuncompress $input => \$buffer
+ or die "anyuncompress failed: $AnyUncompressError\n";
+
+To uncompress all files in the directory "/my/home" that match "*.txt.Compressed" and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ;
+
+ anyuncompress '</my/home/*.txt.Compressed>' => '</my/home/#1.txt>'
+ or die "anyuncompress failed: $AnyUncompressError\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ;
+
+ for my $input ( glob "/my/home/*.txt.Compressed" )
+ {
+ my $output = $input;
+ $output =~ s/.Compressed// ;
+ anyuncompress $input => $output
+ or die "Error compressing '$input': $AnyUncompressError\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for IO::Uncompress::AnyUncompress is shown below
+
+ my $z = new IO::Uncompress::AnyUncompress $input [OPTS]
+ or die "IO::Uncompress::AnyUncompress failed: $AnyUncompressError\n";
+
+Returns an C<IO::Uncompress::AnyUncompress> object on success and undef on failure.
+The variable C<$AnyUncompressError> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::AnyUncompress can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
+
+ $line = $z->getline();
+ $line = <$z>;
+
+The mandatory parameter C<$input> is used to determine the source of the
+compressed data. This parameter can take one of three forms.
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a scalar, it is assumed to be a filename. This
+file will be opened for reading and the compressed data will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the compressed data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the compressed data will be read from
+C<$$output>.
+
+=back
+
+=head2 Constructor Options
+
+The option names defined below are case insensitive and can be optionally
+prefixed by a '-'. So all of the following are valid
+
+ -AutoClose
+ -autoclose
+ AUTOCLOSE
+ autoclose
+
+OPTS is a combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$input> parameter is a filehandle. If
+specified, and the value is true, it will result in the file being closed once
+either the C<close> method is called or the IO::Uncompress::AnyUncompress object is
+destroyed.
+
+This parameter defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+Allows multiple concatenated compressed streams to be treated as a single
+compressed stream. Decompression will stop once either the end of the
+file/buffer is reached, an error is encountered (premature eof, corrupt
+compressed data) or the end of a stream is not immediately followed by the
+start of another stream.
+
+This parameter defaults to 0.
+
+=item C<< Prime => $string >>
+
+This option will uncompress the contents of C<$string> before processing the
+input file/buffer.
+
+This option can be useful when the compressed data is embedded in another
+file/data structure and it is not possible to work out where the compressed
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
+
+=item C<< Transparent => 0|1 >>
+
+If this option is set and the input file/buffer is not compressed data,
+the module will allow reading of it anyway.
+
+In addition, if the input file/buffer does contain compressed data and
+there is non-compressed data immediately following it, setting this option
+will make this module treat the whole file/bufffer as a single data stream.
+
+This option defaults to 1.
+
+=item C<< BlockSize => $num >>
+
+When reading the compressed input data, IO::Uncompress::AnyUncompress will read it in
+blocks of C<$num> bytes.
+
+This option defaults to 4096.
+
+=item C<< InputLength => $size >>
+
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
+
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
+compressed data stream.
+
+This option defaults to off.
+
+=item C<< Append => 0|1 >>
+
+This option controls what the C<read> method does with uncompressed data.
+
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
+
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
+
+Defaults to 0.
+
+=item C<< Strict => 0|1 >>
+
+This option controls whether the extra checks defined below are used when
+carrying out the decompression. When Strict is on, the extra tests are
+carried out, when Strict is off they are not.
+
+The default for this option is off.
+
+=item C<< RawInflate => 0|1 >>
+
+When auto-detecting the compressed format, try to test for raw-deflate (RFC
+1951) content using the C<IO::Uncompress::RawInflate> module.
+
+The reason this is not default behaviour is because RFC 1951 content can
+only be detected by attempting to uncompress it. This process is error
+prone and can result is false positives.
+
+Defaults to 0.
+
+=item C<< UnLzma => 0|1 >>
+
+When auto-detecting the compressed format, try to test for lzma_alone
+content using the C<IO::Uncompress::UnLzma> module.
+
+The reason this is not default behaviour is because lzma_alone content can
+only be detected by attempting to uncompress it. This process is error
+prone and can result is false positives.
+
+Defaults to 0.
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer)
+
+Reads a block of compressed data (the size the the compressed block is
+determined by the C<Buffer> option in the constructor), uncompresses it and
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+
+ $status = read($z, $buffer, $length)
+ $status = read($z, $buffer, $length, $offset)
+
+Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
+
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 getline
+
+Usage is
+
+ $line = $z->getline()
+ $line = <$z>
+
+Reads a single line.
+
+This method fully supports the use of of the variable C<$/> (or
+C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
+determine what constitutes an end of line. Paragraph mode, record mode and
+file slurp mode are all supported.
+
+=head2 getc
+
+Usage is
+
+ $char = $z->getc()
+
+Read a single character.
+
+=head2 ungetc
+
+Usage is
+
+ $char = $z->ungetc($string)
+
+=head2 getHeaderInfo
+
+Usage is
+
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the end of the compressed input stream has been reached.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the input file/buffer.
+It is a fatal error to attempt to seek backward.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+Returns the current uncompressed line number. If C<EXPR> is present it has
+the effect of setting the line number. Note that setting the line number
+does not change the current position within the file/buffer being read.
+
+The contents of C<$/> are used to to determine what constitutes a line
+terminator.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Uncompress::AnyUncompress object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Uncompress::AnyUncompress
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 nextStream
+
+Usage is
+
+ my $status = $z->nextStream();
+
+Skips to the next compressed data stream in the input file/buffer. If a new
+compressed data stream is found, the eof marker will be cleared and C<$.>
+will be reset to 0.
+
+Returns 1 if a new stream was found, 0 if none was found, and -1 if an
+error was encountered.
+
+=head2 trailingData
+
+Usage is
+
+ my $data = $z->trailingData();
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete. It only makes sense to call
+this method once the end of the compressed data stream has been
+encountered.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option in the constructor.
+
+=head1 Importing
+
+No symbolic constants are required by this IO::Uncompress::AnyUncompress at present.
+
+=over 5
+
+=item :all
+
+Imports C<anyuncompress> and C<$AnyUncompressError>.
+Same as doing this
+
+ use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ;
+
+=back
+
+=head1 EXAMPLES
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/Base.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Base.pm
new file mode 100755
index 00000000000..33f2ac23758
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Base.pm
@@ -0,0 +1,1474 @@
+
+package IO::Uncompress::Base ;
+
+use strict ;
+use warnings;
+use bytes;
+
+our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS);
+@ISA = qw(Exporter IO::File);
+
+
+$VERSION = '2.024';
+
+use constant G_EOF => 0 ;
+use constant G_ERR => -1 ;
+
+use IO::Compress::Base::Common 2.024 ;
+#use Parse::Parameters ;
+
+use IO::File ;
+use Symbol;
+use Scalar::Util qw(readonly);
+use List::Util qw(min);
+use Carp ;
+
+%EXPORT_TAGS = ( );
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+#Exporter::export_ok_tags('all') ;
+
+
+
+sub smartRead
+{
+ my $self = $_[0];
+ my $out = $_[1];
+ my $size = $_[2];
+ $$out = "" ;
+
+ my $offset = 0 ;
+
+
+ if (defined *$self->{InputLength}) {
+ return 0
+ if *$self->{InputLengthRemaining} <= 0 ;
+ $size = min($size, *$self->{InputLengthRemaining});
+ }
+
+ if ( length *$self->{Prime} ) {
+ #$$out = substr(*$self->{Prime}, 0, $size, '') ;
+ $$out = substr(*$self->{Prime}, 0, $size) ;
+ substr(*$self->{Prime}, 0, $size) = '' ;
+ if (length $$out == $size) {
+ *$self->{InputLengthRemaining} -= length $$out
+ if defined *$self->{InputLength};
+
+ return length $$out ;
+ }
+ $offset = length $$out ;
+ }
+
+ my $get_size = $size - $offset ;
+
+ if (defined *$self->{FH}) {
+ if ($offset) {
+ # Not using this
+ #
+ # *$self->{FH}->read($$out, $get_size, $offset);
+ #
+ # because the filehandle may not support the offset parameter
+ # An example is Net::FTP
+ my $tmp = '';
+ *$self->{FH}->read($tmp, $get_size) &&
+ (substr($$out, $offset) = $tmp);
+ }
+ else
+ { *$self->{FH}->read($$out, $get_size) }
+ }
+ elsif (defined *$self->{InputEvent}) {
+ my $got = 1 ;
+ while (length $$out < $size) {
+ last
+ if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0;
+ }
+
+ if (length $$out > $size ) {
+ #*$self->{Prime} = substr($$out, $size, length($$out), '');
+ *$self->{Prime} = substr($$out, $size, length($$out));
+ substr($$out, $size, length($$out)) = '';
+ }
+
+ *$self->{EventEof} = 1 if $got <= 0 ;
+ }
+ else {
+ no warnings 'uninitialized';
+ my $buf = *$self->{Buffer} ;
+ $$buf = '' unless defined $$buf ;
+ #$$out = '' unless defined $$out ;
+ substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size);
+ if (*$self->{ConsumeInput})
+ { substr($$buf, 0, $get_size) = '' }
+ else
+ { *$self->{BufferOffset} += length($$out) - $offset }
+ }
+
+ *$self->{InputLengthRemaining} -= length($$out) #- $offset
+ if defined *$self->{InputLength};
+
+ $self->saveStatus(length $$out < 0 ? STATUS_ERROR : STATUS_OK) ;
+
+ return length $$out;
+}
+
+sub pushBack
+{
+ my $self = shift ;
+
+ return if ! defined $_[0] || length $_[0] == 0 ;
+
+ if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
+ *$self->{Prime} = $_[0] . *$self->{Prime} ;
+ *$self->{InputLengthRemaining} += length($_[0]);
+ }
+ else {
+ my $len = length $_[0];
+
+ if($len > *$self->{BufferOffset}) {
+ *$self->{Prime} = substr($_[0], 0, $len - *$self->{BufferOffset}) . *$self->{Prime} ;
+ *$self->{InputLengthRemaining} = *$self->{InputLength};
+ *$self->{BufferOffset} = 0
+ }
+ else {
+ *$self->{InputLengthRemaining} += length($_[0]);
+ *$self->{BufferOffset} -= length($_[0]) ;
+ }
+ }
+}
+
+sub smartSeek
+{
+ my $self = shift ;
+ my $offset = shift ;
+ my $truncate = shift;
+ #print "smartSeek to $offset\n";
+
+ # TODO -- need to take prime into account
+ if (defined *$self->{FH})
+ { *$self->{FH}->seek($offset, SEEK_SET) }
+ else {
+ *$self->{BufferOffset} = $offset ;
+ substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = ''
+ if $truncate;
+ return 1;
+ }
+}
+
+sub smartWrite
+{
+ my $self = shift ;
+ my $out_data = shift ;
+
+ if (defined *$self->{FH}) {
+ # flush needed for 5.8.0
+ defined *$self->{FH}->write($out_data, length $out_data) &&
+ defined *$self->{FH}->flush() ;
+ }
+ else {
+ my $buf = *$self->{Buffer} ;
+ substr($$buf, *$self->{BufferOffset}, length $out_data) = $out_data ;
+ *$self->{BufferOffset} += length($out_data) ;
+ return 1;
+ }
+}
+
+sub smartReadExact
+{
+ return $_[0]->smartRead($_[1], $_[2]) == $_[2];
+}
+
+sub smartEof
+{
+ my ($self) = $_[0];
+ local $.;
+
+ return 0 if length *$self->{Prime} || *$self->{PushMode};
+
+ if (defined *$self->{FH})
+ {
+ # Could use
+ #
+ # *$self->{FH}->eof()
+ #
+ # here, but this can cause trouble if
+ # the filehandle is itself a tied handle, but it uses sysread.
+ # Then we get into mixing buffered & non-buffered IO, which will cause trouble
+
+ my $info = $self->getErrInfo();
+
+ my $buffer = '';
+ my $status = $self->smartRead(\$buffer, 1);
+ $self->pushBack($buffer) if length $buffer;
+ $self->setErrInfo($info);
+
+ return $status == 0 ;
+ }
+ elsif (defined *$self->{InputEvent})
+ { *$self->{EventEof} }
+ else
+ { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) }
+}
+
+sub clearError
+{
+ my $self = shift ;
+
+ *$self->{ErrorNo} = 0 ;
+ ${ *$self->{Error} } = '' ;
+}
+
+sub getErrInfo
+{
+ my $self = shift ;
+
+ return [ *$self->{ErrorNo}, ${ *$self->{Error} } ] ;
+}
+
+sub setErrInfo
+{
+ my $self = shift ;
+ my $ref = shift;
+
+ *$self->{ErrorNo} = $ref->[0] ;
+ ${ *$self->{Error} } = $ref->[1] ;
+}
+
+sub saveStatus
+{
+ my $self = shift ;
+ my $errno = shift() + 0 ;
+ #return $errno unless $errno || ! defined *$self->{ErrorNo};
+ #return $errno unless $errno ;
+
+ *$self->{ErrorNo} = $errno;
+ ${ *$self->{Error} } = '' ;
+
+ return *$self->{ErrorNo} ;
+}
+
+
+sub saveErrorString
+{
+ my $self = shift ;
+ my $retval = shift ;
+
+ #return $retval if ${ *$self->{Error} };
+
+ ${ *$self->{Error} } = shift ;
+ *$self->{ErrorNo} = shift() + 0 if @_ ;
+
+ #warn "saveErrorString: " . ${ *$self->{Error} } . " " . *$self->{Error} . "\n" ;
+ return $retval;
+}
+
+sub croakError
+{
+ my $self = shift ;
+ $self->saveErrorString(0, $_[0]);
+ croak $_[0];
+}
+
+
+sub closeError
+{
+ my $self = shift ;
+ my $retval = shift ;
+
+ my $errno = *$self->{ErrorNo};
+ my $error = ${ *$self->{Error} };
+
+ $self->close();
+
+ *$self->{ErrorNo} = $errno ;
+ ${ *$self->{Error} } = $error ;
+
+ return $retval;
+}
+
+sub error
+{
+ my $self = shift ;
+ return ${ *$self->{Error} } ;
+}
+
+sub errorNo
+{
+ my $self = shift ;
+ return *$self->{ErrorNo};
+}
+
+sub HeaderError
+{
+ my ($self) = shift;
+ return $self->saveErrorString(undef, "Header Error: $_[0]", STATUS_ERROR);
+}
+
+sub TrailerError
+{
+ my ($self) = shift;
+ return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", STATUS_ERROR);
+}
+
+sub TruncatedHeader
+{
+ my ($self) = shift;
+ return $self->HeaderError("Truncated in $_[0] Section");
+}
+
+sub TruncatedTrailer
+{
+ my ($self) = shift;
+ return $self->TrailerError("Truncated in $_[0] Section");
+}
+
+sub postCheckParams
+{
+ return 1;
+}
+
+sub checkParams
+{
+ my $self = shift ;
+ my $class = shift ;
+
+ my $got = shift || IO::Compress::Base::Parameters::new();
+
+ my $Valid = {
+ 'BlockSize' => [1, 1, Parse_unsigned, 16 * 1024],
+ 'AutoClose' => [1, 1, Parse_boolean, 0],
+ 'Strict' => [1, 1, Parse_boolean, 0],
+ 'Append' => [1, 1, Parse_boolean, 0],
+ 'Prime' => [1, 1, Parse_any, undef],
+ 'MultiStream' => [1, 1, Parse_boolean, 0],
+ 'Transparent' => [1, 1, Parse_any, 1],
+ 'Scan' => [1, 1, Parse_boolean, 0],
+ 'InputLength' => [1, 1, Parse_unsigned, undef],
+ 'BinModeOut' => [1, 1, Parse_boolean, 0],
+ #'Encode' => [1, 1, Parse_any, undef],
+
+ #'ConsumeInput' => [1, 1, Parse_boolean, 0],
+
+ $self->getExtraParams(),
+
+ #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0,
+ # ContinueAfterEof
+ } ;
+
+ $Valid->{TrailingData} = [1, 1, Parse_writable_scalar, undef]
+ if *$self->{OneShot} ;
+
+ $got->parse($Valid, @_ )
+ or $self->croakError("${class}: $got->{Error}") ;
+
+ $self->postCheckParams($got)
+ or $self->croakError("${class}: " . $self->error()) ;
+
+ return $got;
+}
+
+sub _create
+{
+ my $obj = shift;
+ my $got = shift;
+ my $append_mode = shift ;
+
+ my $class = ref $obj;
+ $obj->croakError("$class: Missing Input parameter")
+ if ! @_ && ! $got ;
+
+ my $inValue = shift ;
+
+ *$obj->{OneShot} = 0 ;
+
+ if (! $got)
+ {
+ $got = $obj->checkParams($class, undef, @_)
+ or return undef ;
+ }
+
+ my $inType = whatIsInput($inValue, 1);
+
+ $obj->ckInputParam($class, $inValue, 1)
+ or return undef ;
+
+ *$obj->{InNew} = 1;
+
+ $obj->ckParams($got)
+ or $obj->croakError("${class}: " . *$obj->{Error});
+
+ if ($inType eq 'buffer' || $inType eq 'code') {
+ *$obj->{Buffer} = $inValue ;
+ *$obj->{InputEvent} = $inValue
+ if $inType eq 'code' ;
+ }
+ else {
+ if ($inType eq 'handle') {
+ *$obj->{FH} = $inValue ;
+ *$obj->{Handle} = 1 ;
+
+ # Need to rewind for Scan
+ *$obj->{FH}->seek(0, SEEK_SET)
+ if $got->value('Scan');
+ }
+ else {
+ no warnings ;
+ my $mode = '<';
+ $mode = '+<' if $got->value('Scan');
+ *$obj->{StdIO} = ($inValue eq '-');
+ *$obj->{FH} = new IO::File "$mode $inValue"
+ or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ;
+ }
+
+ *$obj->{LineNo} = $. = 0;
+ setBinModeInput(*$obj->{FH}) ;
+
+ my $buff = "" ;
+ *$obj->{Buffer} = \$buff ;
+ }
+
+ if ($got->parsed('Encode')) {
+ my $want_encoding = $got->value('Encode');
+ *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding);
+ }
+
+
+ *$obj->{InputLength} = $got->parsed('InputLength')
+ ? $got->value('InputLength')
+ : undef ;
+ *$obj->{InputLengthRemaining} = $got->value('InputLength');
+ *$obj->{BufferOffset} = 0 ;
+ *$obj->{AutoClose} = $got->value('AutoClose');
+ *$obj->{Strict} = $got->value('Strict');
+ *$obj->{BlockSize} = $got->value('BlockSize');
+ *$obj->{Append} = $got->value('Append');
+ *$obj->{AppendOutput} = $append_mode || $got->value('Append');
+ *$obj->{ConsumeInput} = $got->value('ConsumeInput');
+ *$obj->{Transparent} = $got->value('Transparent');
+ *$obj->{MultiStream} = $got->value('MultiStream');
+
+ # TODO - move these two into RawDeflate
+ *$obj->{Scan} = $got->value('Scan');
+ *$obj->{ParseExtra} = $got->value('ParseExtra')
+ || $got->value('Strict') ;
+ *$obj->{Type} = '';
+ *$obj->{Prime} = $got->value('Prime') || '' ;
+ *$obj->{Pending} = '';
+ *$obj->{Plain} = 0;
+ *$obj->{PlainBytesRead} = 0;
+ *$obj->{InflatedBytesRead} = 0;
+ *$obj->{UnCompSize} = new U64;
+ *$obj->{CompSize} = new U64;
+ *$obj->{TotalInflatedBytesRead} = 0;
+ *$obj->{NewStream} = 0 ;
+ *$obj->{EventEof} = 0 ;
+ *$obj->{ClassName} = $class ;
+ *$obj->{Params} = $got ;
+
+ if (*$obj->{ConsumeInput}) {
+ *$obj->{InNew} = 0;
+ *$obj->{Closed} = 0;
+ return $obj
+ }
+
+ my $status = $obj->mkUncomp($got);
+
+ return undef
+ unless defined $status;
+
+ if ( ! $status) {
+ return undef
+ unless *$obj->{Transparent};
+
+ $obj->clearError();
+ *$obj->{Type} = 'plain';
+ *$obj->{Plain} = 1;
+ #$status = $obj->mkIdentityUncomp($class, $got);
+ $obj->pushBack(*$obj->{HeaderPending}) ;
+ }
+
+ push @{ *$obj->{InfoList} }, *$obj->{Info} ;
+
+ $obj->saveStatus(STATUS_OK) ;
+ *$obj->{InNew} = 0;
+ *$obj->{Closed} = 0;
+
+ return $obj;
+}
+
+sub ckInputParam
+{
+ my $self = shift ;
+ my $from = shift ;
+ my $inType = whatIsInput($_[0], $_[1]);
+
+ $self->croakError("$from: input parameter not a filename, filehandle, array ref or scalar ref")
+ if ! $inType ;
+
+# if ($inType eq 'filename' )
+# {
+# return $self->saveErrorString(1, "$from: input filename is undef or null string", STATUS_ERROR)
+# if ! defined $_[0] || $_[0] eq '' ;
+#
+# if ($_[0] ne '-' && ! -e $_[0] )
+# {
+# return $self->saveErrorString(1,
+# "input file '$_[0]' does not exist", STATUS_ERROR);
+# }
+# }
+
+ return 1;
+}
+
+
+sub _inf
+{
+ my $obj = shift ;
+
+ my $class = (caller)[0] ;
+ my $name = (caller(1))[3] ;
+
+ $obj->croakError("$name: expected at least 1 parameters\n")
+ unless @_ >= 1 ;
+
+ my $input = shift ;
+ my $haveOut = @_ ;
+ my $output = shift ;
+
+
+ my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output)
+ or return undef ;
+
+ push @_, $output if $haveOut && $x->{Hash};
+
+ *$obj->{OneShot} = 1 ;
+
+ my $got = $obj->checkParams($name, undef, @_)
+ or return undef ;
+
+ if ($got->parsed('TrailingData'))
+ {
+ *$obj->{TrailingData} = $got->value('TrailingData');
+ }
+
+ *$obj->{MultiStream} = $got->value('MultiStream');
+ $got->value('MultiStream', 0);
+
+ $x->{Got} = $got ;
+
+# if ($x->{Hash})
+# {
+# while (my($k, $v) = each %$input)
+# {
+# $v = \$input->{$k}
+# unless defined $v ;
+#
+# $obj->_singleTarget($x, $k, $v, @_)
+# or return undef ;
+# }
+#
+# return keys %$input ;
+# }
+
+ if ($x->{GlobMap})
+ {
+ $x->{oneInput} = 1 ;
+ foreach my $pair (@{ $x->{Pairs} })
+ {
+ my ($from, $to) = @$pair ;
+ $obj->_singleTarget($x, $from, $to, @_)
+ or return undef ;
+ }
+
+ return scalar @{ $x->{Pairs} } ;
+ }
+
+ if (! $x->{oneOutput} )
+ {
+ my $inFile = ($x->{inType} eq 'filenames'
+ || $x->{inType} eq 'filename');
+
+ $x->{inType} = $inFile ? 'filename' : 'buffer';
+
+ foreach my $in ($x->{oneInput} ? $input : @$input)
+ {
+ my $out ;
+ $x->{oneInput} = 1 ;
+
+ $obj->_singleTarget($x, $in, $output, @_)
+ or return undef ;
+ }
+
+ return 1 ;
+ }
+
+ # finally the 1 to 1 and n to 1
+ return $obj->_singleTarget($x, $input, $output, @_);
+
+ croak "should not be here" ;
+}
+
+sub retErr
+{
+ my $x = shift ;
+ my $string = shift ;
+
+ ${ $x->{Error} } = $string ;
+
+ return undef ;
+}
+
+sub _singleTarget
+{
+ my $self = shift ;
+ my $x = shift ;
+ my $input = shift;
+ my $output = shift;
+
+ my $buff = '';
+ $x->{buff} = \$buff ;
+
+ my $fh ;
+ if ($x->{outType} eq 'filename') {
+ my $mode = '>' ;
+ $mode = '>>'
+ if $x->{Got}->value('Append') ;
+ $x->{fh} = new IO::File "$mode $output"
+ or return retErr($x, "cannot open file '$output': $!") ;
+ binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
+
+ }
+
+ elsif ($x->{outType} eq 'handle') {
+ $x->{fh} = $output;
+ binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
+ if ($x->{Got}->value('Append')) {
+ seek($x->{fh}, 0, SEEK_END)
+ or return retErr($x, "Cannot seek to end of output filehandle: $!") ;
+ }
+ }
+
+
+ elsif ($x->{outType} eq 'buffer' )
+ {
+ $$output = ''
+ unless $x->{Got}->value('Append');
+ $x->{buff} = $output ;
+ }
+
+ if ($x->{oneInput})
+ {
+ defined $self->_rd2($x, $input, $output)
+ or return undef;
+ }
+ else
+ {
+ for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
+ {
+ defined $self->_rd2($x, $element, $output)
+ or return undef ;
+ }
+ }
+
+
+ if ( ($x->{outType} eq 'filename' && $output ne '-') ||
+ ($x->{outType} eq 'handle' && $x->{Got}->value('AutoClose'))) {
+ $x->{fh}->close()
+ or return retErr($x, $!);
+ delete $x->{fh};
+ }
+
+ return 1 ;
+}
+
+sub _rd2
+{
+ my $self = shift ;
+ my $x = shift ;
+ my $input = shift;
+ my $output = shift;
+
+ my $z = createSelfTiedObject($x->{Class}, *$self->{Error});
+
+ $z->_create($x->{Got}, 1, $input, @_)
+ or return undef ;
+
+ my $status ;
+ my $fh = $x->{fh};
+
+ while (1) {
+
+ while (($status = $z->read($x->{buff})) > 0) {
+ if ($fh) {
+ print $fh ${ $x->{buff} }
+ or return $z->saveErrorString(undef, "Error writing to output file: $!", $!);
+ ${ $x->{buff} } = '' ;
+ }
+ }
+
+ if (! $x->{oneOutput} ) {
+ my $ot = $x->{outType} ;
+
+ if ($ot eq 'array')
+ { push @$output, $x->{buff} }
+ elsif ($ot eq 'hash')
+ { $output->{$input} = $x->{buff} }
+
+ my $buff = '';
+ $x->{buff} = \$buff;
+ }
+
+ last if $status < 0 || $z->smartEof();
+ #last if $status < 0 ;
+
+ last
+ unless *$self->{MultiStream};
+
+ $status = $z->nextStream();
+
+ last
+ unless $status == 1 ;
+ }
+
+ return $z->closeError(undef)
+ if $status < 0 ;
+
+ ${ *$self->{TrailingData} } = $z->trailingData()
+ if defined *$self->{TrailingData} ;
+
+ $z->close()
+ or return undef ;
+
+ return 1 ;
+}
+
+sub TIEHANDLE
+{
+ return $_[0] if ref($_[0]);
+ die "OOPS\n" ;
+
+}
+
+sub UNTIE
+{
+ my $self = shift ;
+}
+
+
+sub getHeaderInfo
+{
+ my $self = shift ;
+ wantarray ? @{ *$self->{InfoList} } : *$self->{Info};
+}
+
+sub readBlock
+{
+ my $self = shift ;
+ my $buff = shift ;
+ my $size = shift ;
+
+ if (defined *$self->{CompressedInputLength}) {
+ if (*$self->{CompressedInputLengthRemaining} == 0) {
+ delete *$self->{CompressedInputLength};
+ *$self->{CompressedInputLengthDone} = 1;
+ return STATUS_OK ;
+ }
+ $size = min($size, *$self->{CompressedInputLengthRemaining} );
+ *$self->{CompressedInputLengthRemaining} -= $size ;
+ }
+
+ my $status = $self->smartRead($buff, $size) ;
+ return $self->saveErrorString(STATUS_ERROR, "Error Reading Data")
+ if $status < 0 ;
+
+ if ($status == 0 ) {
+ *$self->{Closed} = 1 ;
+ *$self->{EndStream} = 1 ;
+ return $self->saveErrorString(STATUS_ERROR, "unexpected end of file", STATUS_ERROR);
+ }
+
+ return STATUS_OK;
+}
+
+sub postBlockChk
+{
+ return STATUS_OK;
+}
+
+sub _raw_read
+{
+ # return codes
+ # >0 - ok, number of bytes read
+ # =0 - ok, eof
+ # <0 - not ok
+
+ my $self = shift ;
+
+ return G_EOF if *$self->{Closed} ;
+ #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
+ return G_EOF if *$self->{EndStream} ;
+
+ my $buffer = shift ;
+ my $scan_mode = shift ;
+
+ if (*$self->{Plain}) {
+ my $tmp_buff ;
+ my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ;
+
+ return $self->saveErrorString(G_ERR, "Error reading data: $!", $!)
+ if $len < 0 ;
+
+ if ($len == 0 ) {
+ *$self->{EndStream} = 1 ;
+ }
+ else {
+ *$self->{PlainBytesRead} += $len ;
+ $$buffer .= $tmp_buff;
+ }
+
+ return $len ;
+ }
+
+ if (*$self->{NewStream}) {
+
+ $self->gotoNextStream() > 0
+ or return G_ERR;
+
+ # For the headers that actually uncompressed data, put the
+ # uncompressed data into the output buffer.
+ $$buffer .= *$self->{Pending} ;
+ my $len = length *$self->{Pending} ;
+ *$self->{Pending} = '';
+ return $len;
+ }
+
+ my $temp_buf = '';
+ my $outSize = 0;
+ my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ;
+ return G_ERR
+ if $status == STATUS_ERROR ;
+
+ my $buf_len = 0;
+ if ($status == STATUS_OK) {
+ my $beforeC_len = length $temp_buf;
+ my $before_len = defined $$buffer ? length $$buffer : 0 ;
+ $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer,
+ defined *$self->{CompressedInputLengthDone} ||
+ $self->smartEof(), $outSize);
+
+ # Remember the input buffer if it wasn't consumed completely
+ $self->pushBack($temp_buf) if *$self->{Uncomp}{ConsumesInput};
+
+ return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo})
+ if $self->saveStatus($status) == STATUS_ERROR;
+
+ $self->postBlockChk($buffer, $before_len) == STATUS_OK
+ or return G_ERR;
+
+ $buf_len = defined $$buffer ? length($$buffer) - $before_len : 0;
+
+ *$self->{CompSize}->add($beforeC_len - length $temp_buf) ;
+
+ *$self->{InflatedBytesRead} += $buf_len ;
+ *$self->{TotalInflatedBytesRead} += $buf_len ;
+ *$self->{UnCompSize}->add($buf_len) ;
+
+ $self->filterUncompressed($buffer);
+
+ if (*$self->{Encoding}) {
+ $$buffer = *$self->{Encoding}->decode($$buffer);
+ }
+ }
+
+ if ($status == STATUS_ENDSTREAM) {
+
+ *$self->{EndStream} = 1 ;
+#$self->pushBack($temp_buf) ;
+#$temp_buf = '';
+
+ my $trailer;
+ my $trailer_size = *$self->{Info}{TrailerLength} ;
+ my $got = 0;
+ if (*$self->{Info}{TrailerLength})
+ {
+ $got = $self->smartRead(\$trailer, $trailer_size) ;
+ }
+
+ if ($got == $trailer_size) {
+ $self->chkTrailer($trailer) == STATUS_OK
+ or return G_ERR;
+ }
+ else {
+ return $self->TrailerError("trailer truncated. Expected " .
+ "$trailer_size bytes, got $got")
+ if *$self->{Strict};
+ $self->pushBack($trailer) ;
+ }
+
+ # TODO - if want to file file pointer, do it here
+
+ if (! $self->smartEof()) {
+ *$self->{NewStream} = 1 ;
+
+ if (*$self->{MultiStream}) {
+ *$self->{EndStream} = 0 ;
+ return $buf_len ;
+ }
+ }
+
+ }
+
+
+ # return the number of uncompressed bytes read
+ return $buf_len ;
+}
+
+sub reset
+{
+ my $self = shift ;
+
+ return *$self->{Uncomp}->reset();
+}
+
+sub filterUncompressed
+{
+}
+
+#sub isEndStream
+#{
+# my $self = shift ;
+# return *$self->{NewStream} ||
+# *$self->{EndStream} ;
+#}
+
+sub nextStream
+{
+ my $self = shift ;
+
+ my $status = $self->gotoNextStream();
+ $status == 1
+ or return $status ;
+
+ *$self->{TotalInflatedBytesRead} = 0 ;
+ *$self->{LineNo} = $. = 0;
+
+ return 1;
+}
+
+sub gotoNextStream
+{
+ my $self = shift ;
+
+ if (! *$self->{NewStream}) {
+ my $status = 1;
+ my $buffer ;
+
+ # TODO - make this more efficient if know the offset for the end of
+ # the stream and seekable
+ $status = $self->read($buffer)
+ while $status > 0 ;
+
+ return $status
+ if $status < 0;
+ }
+
+ *$self->{NewStream} = 0 ;
+ *$self->{EndStream} = 0 ;
+ $self->reset();
+ *$self->{UnCompSize}->reset();
+ *$self->{CompSize}->reset();
+
+ my $magic = $self->ckMagic();
+ #*$self->{EndStream} = 0 ;
+
+ if ( ! defined $magic) {
+ if (! *$self->{Transparent} )
+ {
+ *$self->{EndStream} = 1 ;
+ return 0;
+ }
+
+ $self->clearError();
+ *$self->{Type} = 'plain';
+ *$self->{Plain} = 1;
+ $self->pushBack(*$self->{HeaderPending}) ;
+ }
+ else
+ {
+ *$self->{Info} = $self->readHeader($magic);
+
+ if ( ! defined *$self->{Info} ) {
+ *$self->{EndStream} = 1 ;
+ return -1;
+ }
+ }
+
+ push @{ *$self->{InfoList} }, *$self->{Info} ;
+
+ return 1;
+}
+
+sub streamCount
+{
+ my $self = shift ;
+ return 1 if ! defined *$self->{InfoList};
+ return scalar @{ *$self->{InfoList} } ;
+}
+
+sub read
+{
+ # return codes
+ # >0 - ok, number of bytes read
+ # =0 - ok, eof
+ # <0 - not ok
+
+ my $self = shift ;
+
+ return G_EOF if *$self->{Closed} ;
+
+ my $buffer ;
+
+ if (ref $_[0] ) {
+ $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
+ if readonly(${ $_[0] });
+
+ $self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" )
+ unless ref $_[0] eq 'SCALAR' ;
+ $buffer = $_[0] ;
+ }
+ else {
+ $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
+ if readonly($_[0]);
+
+ $buffer = \$_[0] ;
+ }
+
+ my $length = $_[1] ;
+ my $offset = $_[2] || 0;
+
+ if (! *$self->{AppendOutput}) {
+ if (! $offset) {
+ $$buffer = '' ;
+ }
+ else {
+ if ($offset > length($$buffer)) {
+ $$buffer .= "\x00" x ($offset - length($$buffer));
+ }
+ else {
+ substr($$buffer, $offset) = '';
+ }
+ }
+ }
+
+ return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
+
+ # the core read will return 0 if asked for 0 bytes
+ return 0 if defined $length && $length == 0 ;
+
+ $length = $length || 0;
+
+ $self->croakError(*$self->{ClassName} . "::read: length parameter is negative")
+ if $length < 0 ;
+
+ # Short-circuit if this is a simple read, with no length
+ # or offset specified.
+ unless ( $length || $offset) {
+ if (length *$self->{Pending}) {
+ $$buffer .= *$self->{Pending} ;
+ my $len = length *$self->{Pending};
+ *$self->{Pending} = '' ;
+ return $len ;
+ }
+ else {
+ my $len = 0;
+ $len = $self->_raw_read($buffer)
+ while ! *$self->{EndStream} && $len == 0 ;
+ return $len ;
+ }
+ }
+
+ # Need to jump through more hoops - either length or offset
+ # or both are specified.
+ my $out_buffer = *$self->{Pending} ;
+ *$self->{Pending} = '';
+
+
+ while (! *$self->{EndStream} && length($out_buffer) < $length)
+ {
+ my $buf_len = $self->_raw_read(\$out_buffer);
+ return $buf_len
+ if $buf_len < 0 ;
+ }
+
+ $length = length $out_buffer
+ if length($out_buffer) < $length ;
+
+ return 0
+ if $length == 0 ;
+
+ $$buffer = ''
+ if ! defined $$buffer;
+
+ $offset = length $$buffer
+ if *$self->{AppendOutput} ;
+
+ *$self->{Pending} = $out_buffer;
+ $out_buffer = \*$self->{Pending} ;
+
+ #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ;
+ substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ;
+ substr($$out_buffer, 0, $length) = '' ;
+
+ return $length ;
+}
+
+sub _getline
+{
+ my $self = shift ;
+
+ # Slurp Mode
+ if ( ! defined $/ ) {
+ my $data ;
+ 1 while $self->read($data) > 0 ;
+ return \$data ;
+ }
+
+ # Record Mode
+ if ( ref $/ eq 'SCALAR' && ${$/} =~ /^\d+$/ && ${$/} > 0) {
+ my $reclen = ${$/} ;
+ my $data ;
+ $self->read($data, $reclen) ;
+ return \$data ;
+ }
+
+ # Paragraph Mode
+ if ( ! length $/ ) {
+ my $paragraph ;
+ while ($self->read($paragraph) > 0 ) {
+ if ($paragraph =~ s/^(.*?\n\n+)//s) {
+ *$self->{Pending} = $paragraph ;
+ my $par = $1 ;
+ return \$par ;
+ }
+ }
+ return \$paragraph;
+ }
+
+ # $/ isn't empty, or a reference, so it's Line Mode.
+ {
+ my $line ;
+ my $offset;
+ my $p = \*$self->{Pending} ;
+
+ if (length(*$self->{Pending}) &&
+ ($offset = index(*$self->{Pending}, $/)) >=0) {
+ my $l = substr(*$self->{Pending}, 0, $offset + length $/ );
+ substr(*$self->{Pending}, 0, $offset + length $/) = '';
+ return \$l;
+ }
+
+ while ($self->read($line) > 0 ) {
+ my $offset = index($line, $/);
+ if ($offset >= 0) {
+ my $l = substr($line, 0, $offset + length $/ );
+ substr($line, 0, $offset + length $/) = '';
+ $$p = $line;
+ return \$l;
+ }
+ }
+
+ return \$line;
+ }
+}
+
+sub getline
+{
+ my $self = shift;
+ my $current_append = *$self->{AppendOutput} ;
+ *$self->{AppendOutput} = 1;
+ my $lineref = $self->_getline();
+ $. = ++ *$self->{LineNo} if defined $$lineref ;
+ *$self->{AppendOutput} = $current_append;
+ return $$lineref ;
+}
+
+sub getlines
+{
+ my $self = shift;
+ $self->croakError(*$self->{ClassName} .
+ "::getlines: called in scalar context\n") unless wantarray;
+ my($line, @lines);
+ push(@lines, $line)
+ while defined($line = $self->getline);
+ return @lines;
+}
+
+sub READLINE
+{
+ goto &getlines if wantarray;
+ goto &getline;
+}
+
+sub getc
+{
+ my $self = shift;
+ my $buf;
+ return $buf if $self->read($buf, 1);
+ return undef;
+}
+
+sub ungetc
+{
+ my $self = shift;
+ *$self->{Pending} = "" unless defined *$self->{Pending} ;
+ *$self->{Pending} = $_[0] . *$self->{Pending} ;
+}
+
+
+sub trailingData
+{
+ my $self = shift ;
+
+ if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
+ return *$self->{Prime} ;
+ }
+ else {
+ my $buf = *$self->{Buffer} ;
+ my $offset = *$self->{BufferOffset} ;
+ return substr($$buf, $offset) ;
+ }
+}
+
+
+sub eof
+{
+ my $self = shift ;
+
+ return (*$self->{Closed} ||
+ (!length *$self->{Pending}
+ && ( $self->smartEof() || *$self->{EndStream}))) ;
+}
+
+sub tell
+{
+ my $self = shift ;
+
+ my $in ;
+ if (*$self->{Plain}) {
+ $in = *$self->{PlainBytesRead} ;
+ }
+ else {
+ $in = *$self->{TotalInflatedBytesRead} ;
+ }
+
+ my $pending = length *$self->{Pending} ;
+
+ return 0 if $pending > $in ;
+ return $in - $pending ;
+}
+
+sub close
+{
+ # todo - what to do if close is called before the end of the gzip file
+ # do we remember any trailing data?
+ my $self = shift ;
+
+ return 1 if *$self->{Closed} ;
+
+ untie *$self
+ if $] >= 5.008 ;
+
+ my $status = 1 ;
+
+ if (defined *$self->{FH}) {
+ if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
+ #if ( *$self->{AutoClose}) {
+ local $.;
+ $! = 0 ;
+ $status = *$self->{FH}->close();
+ return $self->saveErrorString(0, $!, $!)
+ if !*$self->{InNew} && $self->saveStatus($!) != 0 ;
+ }
+ delete *$self->{FH} ;
+ $! = 0 ;
+ }
+ *$self->{Closed} = 1 ;
+
+ return 1;
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ local ($., $@, $!, $^E, $?);
+
+ $self->close() ;
+}
+
+sub seek
+{
+ my $self = shift ;
+ my $position = shift;
+ my $whence = shift ;
+
+ my $here = $self->tell() ;
+ my $target = 0 ;
+
+
+ if ($whence == SEEK_SET) {
+ $target = $position ;
+ }
+ elsif ($whence == SEEK_CUR) {
+ $target = $here + $position ;
+ }
+ elsif ($whence == SEEK_END) {
+ $target = $position ;
+ $self->croakError(*$self->{ClassName} . "::seek: SEEK_END not allowed") ;
+ }
+ else {
+ $self->croakError(*$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter");
+ }
+
+ # short circuit if seeking to current offset
+ if ($target == $here) {
+ # On ordinary filehandles, seeking to the current
+ # position also clears the EOF condition, so we
+ # emulate this behavior locally while simultaneously
+ # cascading it to the underlying filehandle
+ if (*$self->{Plain}) {
+ *$self->{EndStream} = 0;
+ seek(*$self->{FH},0,1) if *$self->{FH};
+ }
+ return 1;
+ }
+
+ # Outlaw any attempt to seek backwards
+ $self->croakError( *$self->{ClassName} ."::seek: cannot seek backwards")
+ if $target < $here ;
+
+ # Walk the file to the new offset
+ my $offset = $target - $here ;
+
+ my $got;
+ while (($got = $self->read(my $buffer, min($offset, *$self->{BlockSize})) ) > 0)
+ {
+ $offset -= $got;
+ last if $offset == 0 ;
+ }
+
+ $here = $self->tell() ;
+ return $offset == 0 ? 1 : 0 ;
+}
+
+sub fileno
+{
+ my $self = shift ;
+ return defined *$self->{FH}
+ ? fileno *$self->{FH}
+ : undef ;
+}
+
+sub binmode
+{
+ 1;
+# my $self = shift ;
+# return defined *$self->{FH}
+# ? binmode *$self->{FH}
+# : 1 ;
+}
+
+sub opened
+{
+ my $self = shift ;
+ return ! *$self->{Closed} ;
+}
+
+sub autoflush
+{
+ my $self = shift ;
+ return defined *$self->{FH}
+ ? *$self->{FH}->autoflush(@_)
+ : undef ;
+}
+
+sub input_line_number
+{
+ my $self = shift ;
+ my $last = *$self->{LineNo};
+ $. = *$self->{LineNo} = $_[1] if @_ ;
+ return $last;
+}
+
+
+*BINMODE = \&binmode;
+*SEEK = \&seek;
+*READ = \&read;
+*sysread = \&read;
+*TELL = \&tell;
+*EOF = \&eof;
+
+*FILENO = \&fileno;
+*CLOSE = \&close;
+
+sub _notAvailable
+{
+ my $name = shift ;
+ #return sub { croak "$name Not Available" ; } ;
+ return sub { croak "$name Not Available: File opened only for intput" ; } ;
+}
+
+
+*print = _notAvailable('print');
+*PRINT = _notAvailable('print');
+*printf = _notAvailable('printf');
+*PRINTF = _notAvailable('printf');
+*write = _notAvailable('write');
+*WRITE = _notAvailable('write');
+
+#*sysread = \&read;
+#*syswrite = \&_notAvailable;
+
+
+
+package IO::Uncompress::Base ;
+
+
+1 ;
+__END__
+
+=head1 NAME
+
+IO::Uncompress::Base - Base Class for IO::Uncompress modules
+
+=head1 SYNOPSIS
+
+ use IO::Uncompress::Base ;
+
+=head1 DESCRIPTION
+
+This module is not intended for direct use in application code. Its sole
+purpose if to to be sub-classed by IO::Unompress modules.
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm
new file mode 100755
index 00000000000..b3988c41851
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Bunzip2.pm
@@ -0,0 +1,858 @@
+package IO::Uncompress::Bunzip2 ;
+
+use strict ;
+use warnings;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+
+use IO::Uncompress::Base 2.024 ;
+use IO::Uncompress::Adapter::Bunzip2 2.024 ;
+
+require Exporter ;
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error);
+
+$VERSION = '2.024';
+$Bunzip2Error = '';
+
+@ISA = qw( Exporter IO::Uncompress::Base );
+@EXPORT_OK = qw( $Bunzip2Error bunzip2 ) ;
+#%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+#Exporter::export_ok_tags('all');
+
+
+sub new
+{
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$Bunzip2Error);
+
+ $obj->_create(undef, 0, @_);
+}
+
+sub bunzip2
+{
+ my $obj = createSelfTiedObject(undef, \$Bunzip2Error);
+ return $obj->_inf(@_);
+}
+
+sub getExtraParams
+{
+ my $self = shift ;
+
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+
+ return (
+ 'Verbosity' => [1, 1, Parse_boolean, 0],
+ 'Small' => [1, 1, Parse_boolean, 0],
+ );
+}
+
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ return 1;
+}
+
+sub mkUncomp
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ my $magic = $self->ckMagic()
+ or return 0;
+
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ my $Small = $got->value('Small');
+ my $Verbosity = $got->value('Verbosity');
+
+ my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Bunzip2::mkUncompObject(
+ $Small, $Verbosity);
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ return 1;
+
+}
+
+
+sub ckMagic
+{
+ my $self = shift;
+
+ my $magic ;
+ $self->smartReadExact(\$magic, 4);
+
+ *$self->{HeaderPending} = $magic ;
+
+ return $self->HeaderError("Header size is " .
+ 4 . " bytes")
+ if length $magic != 4;
+
+ return $self->HeaderError("Bad Magic.")
+ if ! isBzip2Magic($magic) ;
+
+
+ *$self->{Type} = 'bzip2';
+ return $magic;
+}
+
+sub readHeader
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ $self->pushBack($magic);
+ *$self->{HeaderPending} = '';
+
+
+ return {
+ 'Type' => 'bzip2',
+ 'FingerprintLength' => 4,
+ 'HeaderLength' => 4,
+ 'TrailerLength' => 0,
+ 'Header' => '$magic'
+ };
+
+}
+
+sub chkTrailer
+{
+ return STATUS_OK;
+}
+
+
+
+sub isBzip2Magic
+{
+ my $buffer = shift ;
+ return $buffer =~ /^BZh\d$/;
+}
+
+1 ;
+
+__END__
+
+
+=head1 NAME
+
+IO::Uncompress::Bunzip2 - Read bzip2 files/buffers
+
+=head1 SYNOPSIS
+
+ use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
+
+ my $status = bunzip2 $input => $output [,OPTS]
+ or die "bunzip2 failed: $Bunzip2Error\n";
+
+ my $z = new IO::Uncompress::Bunzip2 $input [OPTS]
+ or die "bunzip2 failed: $Bunzip2Error\n";
+
+ $status = $z->read($buffer)
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+ $line = $z->getline()
+ $char = $z->getc()
+ $char = $z->ungetc()
+ $char = $z->opened()
+
+ $data = $z->trailingData()
+ $status = $z->nextStream()
+ $data = $z->getHeaderInfo()
+ $z->tell()
+ $z->seek($position, $whence)
+ $z->binmode()
+ $z->fileno()
+ $z->eof()
+ $z->close()
+
+ $Bunzip2Error ;
+
+ # IO::File mode
+
+ <$z>
+ read($z, $buffer);
+ read($z, $buffer, $length);
+ read($z, $buffer, $length, $offset);
+ tell($z)
+ seek($z, $position, $whence)
+ binmode($z)
+ fileno($z)
+ eof($z)
+ close($z)
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows the reading of
+bzip2 files/buffers.
+
+For writing bzip2 files/buffers, see the companion module IO::Compress::Bzip2.
+
+=head1 Functional Interface
+
+A top-level function, C<bunzip2>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
+
+ use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
+
+ bunzip2 $input => $output [,OPTS]
+ or die "bunzip2 failed: $Bunzip2Error\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 bunzip2 $input => $output [, OPTS]
+
+C<bunzip2> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the compressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is uncompressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<bunzip2> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<bunzip2> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
+concatenation of all the uncompressed data from each of the input
+files/buffers.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<bunzip2>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<bunzip2> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<bunzip2> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeOut => 0|1 >>
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+TODO
+
+=item C<< MultiStream => 0|1 >>
+
+If the input file/buffer contains multiple compressed data streams, this
+option will uncompress the whole lot as a single data stream.
+
+Defaults to 0.
+
+=item C<< TrailingData => $scalar >>
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt.bz2> and write the
+compressed data to the file C<file1.txt>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
+
+ my $input = "file1.txt.bz2";
+ my $output = "file1.txt";
+ bunzip2 $input => $output
+ or die "bunzip2 failed: $Bunzip2Error\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+uncompressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt.bz2"
+ or die "Cannot open 'file1.txt.bz2': $!\n" ;
+ my $buffer ;
+ bunzip2 $input => \$buffer
+ or die "bunzip2 failed: $Bunzip2Error\n";
+
+To uncompress all files in the directory "/my/home" that match "*.txt.bz2" and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
+
+ bunzip2 '</my/home/*.txt.bz2>' => '</my/home/#1.txt>'
+ or die "bunzip2 failed: $Bunzip2Error\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
+
+ for my $input ( glob "/my/home/*.txt.bz2" )
+ {
+ my $output = $input;
+ $output =~ s/.bz2// ;
+ bunzip2 $input => $output
+ or die "Error compressing '$input': $Bunzip2Error\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for IO::Uncompress::Bunzip2 is shown below
+
+ my $z = new IO::Uncompress::Bunzip2 $input [OPTS]
+ or die "IO::Uncompress::Bunzip2 failed: $Bunzip2Error\n";
+
+Returns an C<IO::Uncompress::Bunzip2> object on success and undef on failure.
+The variable C<$Bunzip2Error> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::Bunzip2 can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
+
+ $line = $z->getline();
+ $line = <$z>;
+
+The mandatory parameter C<$input> is used to determine the source of the
+compressed data. This parameter can take one of three forms.
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a scalar, it is assumed to be a filename. This
+file will be opened for reading and the compressed data will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the compressed data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the compressed data will be read from
+C<$$output>.
+
+=back
+
+=head2 Constructor Options
+
+The option names defined below are case insensitive and can be optionally
+prefixed by a '-'. So all of the following are valid
+
+ -AutoClose
+ -autoclose
+ AUTOCLOSE
+ autoclose
+
+OPTS is a combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$input> parameter is a filehandle. If
+specified, and the value is true, it will result in the file being closed once
+either the C<close> method is called or the IO::Uncompress::Bunzip2 object is
+destroyed.
+
+This parameter defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+Allows multiple concatenated compressed streams to be treated as a single
+compressed stream. Decompression will stop once either the end of the
+file/buffer is reached, an error is encountered (premature eof, corrupt
+compressed data) or the end of a stream is not immediately followed by the
+start of another stream.
+
+This parameter defaults to 0.
+
+=item C<< Prime => $string >>
+
+This option will uncompress the contents of C<$string> before processing the
+input file/buffer.
+
+This option can be useful when the compressed data is embedded in another
+file/data structure and it is not possible to work out where the compressed
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
+
+=item C<< Transparent => 0|1 >>
+
+If this option is set and the input file/buffer is not compressed data,
+the module will allow reading of it anyway.
+
+In addition, if the input file/buffer does contain compressed data and
+there is non-compressed data immediately following it, setting this option
+will make this module treat the whole file/bufffer as a single data stream.
+
+This option defaults to 1.
+
+=item C<< BlockSize => $num >>
+
+When reading the compressed input data, IO::Uncompress::Bunzip2 will read it in
+blocks of C<$num> bytes.
+
+This option defaults to 4096.
+
+=item C<< InputLength => $size >>
+
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
+
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
+compressed data stream.
+
+This option defaults to off.
+
+=item C<< Append => 0|1 >>
+
+This option controls what the C<read> method does with uncompressed data.
+
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
+
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
+
+Defaults to 0.
+
+=item C<< Strict => 0|1 >>
+
+This option is a no-op.
+
+=item C<< Small => 0|1 >>
+
+When non-zero this options will make bzip2 use a decompression algorithm
+that uses less memory at the expense of increasing the amount of time
+taken for decompression.
+
+Default is 0.
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer)
+
+Reads a block of compressed data (the size the the compressed block is
+determined by the C<Buffer> option in the constructor), uncompresses it and
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+
+ $status = read($z, $buffer, $length)
+ $status = read($z, $buffer, $length, $offset)
+
+Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
+
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 getline
+
+Usage is
+
+ $line = $z->getline()
+ $line = <$z>
+
+Reads a single line.
+
+This method fully supports the use of of the variable C<$/> (or
+C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
+determine what constitutes an end of line. Paragraph mode, record mode and
+file slurp mode are all supported.
+
+=head2 getc
+
+Usage is
+
+ $char = $z->getc()
+
+Read a single character.
+
+=head2 ungetc
+
+Usage is
+
+ $char = $z->ungetc($string)
+
+=head2 getHeaderInfo
+
+Usage is
+
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the end of the compressed input stream has been reached.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the input file/buffer.
+It is a fatal error to attempt to seek backward.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+Returns the current uncompressed line number. If C<EXPR> is present it has
+the effect of setting the line number. Note that setting the line number
+does not change the current position within the file/buffer being read.
+
+The contents of C<$/> are used to to determine what constitutes a line
+terminator.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Uncompress::Bunzip2 object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Uncompress::Bunzip2
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 nextStream
+
+Usage is
+
+ my $status = $z->nextStream();
+
+Skips to the next compressed data stream in the input file/buffer. If a new
+compressed data stream is found, the eof marker will be cleared and C<$.>
+will be reset to 0.
+
+Returns 1 if a new stream was found, 0 if none was found, and -1 if an
+error was encountered.
+
+=head2 trailingData
+
+Usage is
+
+ my $data = $z->trailingData();
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete. It only makes sense to call
+this method once the end of the compressed data stream has been
+encountered.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option in the constructor.
+
+=head1 Importing
+
+No symbolic constants are required by this IO::Uncompress::Bunzip2 at present.
+
+=over 5
+
+=item :all
+
+Imports C<bunzip2> and C<$Bunzip2Error>.
+Same as doing this
+
+ use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Working with Net::FTP
+
+See L<IO::Uncompress::Bunzip2::FAQ|IO::Uncompress::Bunzip2::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+The primary site for the bzip2 program is F<http://www.bzip.org>.
+
+See the module L<Compress::Bzip2|Compress::Bzip2>
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2008 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm
new file mode 100755
index 00000000000..f3e4e6561f0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Gunzip.pm
@@ -0,0 +1,1111 @@
+
+package IO::Uncompress::Gunzip ;
+
+require 5.004 ;
+
+# for RFC1952
+
+use strict ;
+use warnings;
+use bytes;
+
+use IO::Uncompress::RawInflate 2.024 ;
+
+use Compress::Raw::Zlib 2.024 qw( crc32 ) ;
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+use IO::Compress::Gzip::Constants 2.024 ;
+use IO::Compress::Zlib::Extra 2.024 ;
+
+require Exporter ;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GunzipError);
+
+@ISA = qw( Exporter IO::Uncompress::RawInflate );
+@EXPORT_OK = qw( $GunzipError gunzip );
+%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+$GunzipError = '';
+
+$VERSION = '2.024';
+
+sub new
+{
+ my $class = shift ;
+ $GunzipError = '';
+ my $obj = createSelfTiedObject($class, \$GunzipError);
+
+ $obj->_create(undef, 0, @_);
+}
+
+sub gunzip
+{
+ my $obj = createSelfTiedObject(undef, \$GunzipError);
+ return $obj->_inf(@_) ;
+}
+
+sub getExtraParams
+{
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+ return ( 'ParseExtra' => [1, 1, Parse_boolean, 0] ) ;
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ # gunzip always needs crc32
+ $got->value('CRC32' => 1);
+
+ return 1;
+}
+
+sub ckMagic
+{
+ my $self = shift;
+
+ my $magic ;
+ $self->smartReadExact(\$magic, GZIP_ID_SIZE);
+
+ *$self->{HeaderPending} = $magic ;
+
+ return $self->HeaderError("Minimum header size is " .
+ GZIP_MIN_HEADER_SIZE . " bytes")
+ if length $magic != GZIP_ID_SIZE ;
+
+ return $self->HeaderError("Bad Magic")
+ if ! isGzipMagic($magic) ;
+
+ *$self->{Type} = 'rfc1952';
+
+ return $magic ;
+}
+
+sub readHeader
+{
+ my $self = shift;
+ my $magic = shift;
+
+ return $self->_readGzipHeader($magic);
+}
+
+sub chkTrailer
+{
+ my $self = shift;
+ my $trailer = shift;
+
+ # Check CRC & ISIZE
+ my ($CRC32, $ISIZE) = unpack("V V", $trailer) ;
+ *$self->{Info}{CRC32} = $CRC32;
+ *$self->{Info}{ISIZE} = $ISIZE;
+
+ if (*$self->{Strict}) {
+ return $self->TrailerError("CRC mismatch")
+ if $CRC32 != *$self->{Uncomp}->crc32() ;
+
+ my $exp_isize = *$self->{UnCompSize}->get32bit();
+ return $self->TrailerError("ISIZE mismatch. Got $ISIZE"
+ . ", expected $exp_isize")
+ if $ISIZE != $exp_isize ;
+ }
+
+ return STATUS_OK;
+}
+
+sub isGzipMagic
+{
+ my $buffer = shift ;
+ return 0 if length $buffer < GZIP_ID_SIZE ;
+ my ($id1, $id2) = unpack("C C", $buffer) ;
+ return $id1 == GZIP_ID1 && $id2 == GZIP_ID2 ;
+}
+
+sub _readFullGzipHeader($)
+{
+ my ($self) = @_ ;
+ my $magic = '' ;
+
+ $self->smartReadExact(\$magic, GZIP_ID_SIZE);
+
+ *$self->{HeaderPending} = $magic ;
+
+ return $self->HeaderError("Minimum header size is " .
+ GZIP_MIN_HEADER_SIZE . " bytes")
+ if length $magic != GZIP_ID_SIZE ;
+
+
+ return $self->HeaderError("Bad Magic")
+ if ! isGzipMagic($magic) ;
+
+ my $status = $self->_readGzipHeader($magic);
+ delete *$self->{Transparent} if ! defined $status ;
+ return $status ;
+}
+
+sub _readGzipHeader($)
+{
+ my ($self, $magic) = @_ ;
+ my ($HeaderCRC) ;
+ my ($buffer) = '' ;
+
+ $self->smartReadExact(\$buffer, GZIP_MIN_HEADER_SIZE - GZIP_ID_SIZE)
+ or return $self->HeaderError("Minimum header size is " .
+ GZIP_MIN_HEADER_SIZE . " bytes") ;
+
+ my $keep = $magic . $buffer ;
+ *$self->{HeaderPending} = $keep ;
+
+ # now split out the various parts
+ my ($cm, $flag, $mtime, $xfl, $os) = unpack("C C V C C", $buffer) ;
+
+ $cm == GZIP_CM_DEFLATED
+ or return $self->HeaderError("Not Deflate (CM is $cm)") ;
+
+ # check for use of reserved bits
+ return $self->HeaderError("Use of Reserved Bits in FLG field.")
+ if $flag & GZIP_FLG_RESERVED ;
+
+ my $EXTRA ;
+ my @EXTRA = () ;
+ if ($flag & GZIP_FLG_FEXTRA) {
+ $EXTRA = "" ;
+ $self->smartReadExact(\$buffer, GZIP_FEXTRA_HEADER_SIZE)
+ or return $self->TruncatedHeader("FEXTRA Length") ;
+
+ my ($XLEN) = unpack("v", $buffer) ;
+ $self->smartReadExact(\$EXTRA, $XLEN)
+ or return $self->TruncatedHeader("FEXTRA Body");
+ $keep .= $buffer . $EXTRA ;
+
+ if ($XLEN && *$self->{'ParseExtra'}) {
+ my $bad = IO::Compress::Zlib::Extra::parseRawExtra($EXTRA,
+ \@EXTRA, 1, 1);
+ return $self->HeaderError($bad)
+ if defined $bad;
+ }
+ }
+
+ my $origname ;
+ if ($flag & GZIP_FLG_FNAME) {
+ $origname = "" ;
+ while (1) {
+ $self->smartReadExact(\$buffer, 1)
+ or return $self->TruncatedHeader("FNAME");
+ last if $buffer eq GZIP_NULL_BYTE ;
+ $origname .= $buffer
+ }
+ $keep .= $origname . GZIP_NULL_BYTE ;
+
+ return $self->HeaderError("Non ISO 8859-1 Character found in Name")
+ if *$self->{Strict} && $origname =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ;
+ }
+
+ my $comment ;
+ if ($flag & GZIP_FLG_FCOMMENT) {
+ $comment = "";
+ while (1) {
+ $self->smartReadExact(\$buffer, 1)
+ or return $self->TruncatedHeader("FCOMMENT");
+ last if $buffer eq GZIP_NULL_BYTE ;
+ $comment .= $buffer
+ }
+ $keep .= $comment . GZIP_NULL_BYTE ;
+
+ return $self->HeaderError("Non ISO 8859-1 Character found in Comment")
+ if *$self->{Strict} && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o ;
+ }
+
+ if ($flag & GZIP_FLG_FHCRC) {
+ $self->smartReadExact(\$buffer, GZIP_FHCRC_SIZE)
+ or return $self->TruncatedHeader("FHCRC");
+
+ $HeaderCRC = unpack("v", $buffer) ;
+ my $crc16 = crc32($keep) & 0xFF ;
+
+ return $self->HeaderError("CRC16 mismatch.")
+ if *$self->{Strict} && $crc16 != $HeaderCRC;
+
+ $keep .= $buffer ;
+ }
+
+ # Assume compression method is deflated for xfl tests
+ #if ($xfl) {
+ #}
+
+ *$self->{Type} = 'rfc1952';
+
+ return {
+ 'Type' => 'rfc1952',
+ 'FingerprintLength' => 2,
+ 'HeaderLength' => length $keep,
+ 'TrailerLength' => GZIP_TRAILER_SIZE,
+ 'Header' => $keep,
+ 'isMinimalHeader' => $keep eq GZIP_MINIMUM_HEADER ? 1 : 0,
+
+ 'MethodID' => $cm,
+ 'MethodName' => $cm == GZIP_CM_DEFLATED ? "Deflated" : "Unknown" ,
+ 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0,
+ 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0,
+ 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0,
+ 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0,
+ 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0,
+ 'Name' => $origname,
+ 'Comment' => $comment,
+ 'Time' => $mtime,
+ 'OsID' => $os,
+ 'OsName' => defined $GZIP_OS_Names{$os}
+ ? $GZIP_OS_Names{$os} : "Unknown",
+ 'HeaderCRC' => $HeaderCRC,
+ 'Flags' => $flag,
+ 'ExtraFlags' => $xfl,
+ 'ExtraFieldRaw' => $EXTRA,
+ 'ExtraField' => [ @EXTRA ],
+
+
+ #'CompSize'=> $compsize,
+ #'CRC32'=> $CRC32,
+ #'OrigSize'=> $ISIZE,
+ }
+}
+
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+IO::Uncompress::Gunzip - Read RFC 1952 files/buffers
+
+=head1 SYNOPSIS
+
+ use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;
+
+ my $status = gunzip $input => $output [,OPTS]
+ or die "gunzip failed: $GunzipError\n";
+
+ my $z = new IO::Uncompress::Gunzip $input [OPTS]
+ or die "gunzip failed: $GunzipError\n";
+
+ $status = $z->read($buffer)
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+ $line = $z->getline()
+ $char = $z->getc()
+ $char = $z->ungetc()
+ $char = $z->opened()
+
+ $status = $z->inflateSync()
+
+ $data = $z->trailingData()
+ $status = $z->nextStream()
+ $data = $z->getHeaderInfo()
+ $z->tell()
+ $z->seek($position, $whence)
+ $z->binmode()
+ $z->fileno()
+ $z->eof()
+ $z->close()
+
+ $GunzipError ;
+
+ # IO::File mode
+
+ <$z>
+ read($z, $buffer);
+ read($z, $buffer, $length);
+ read($z, $buffer, $length, $offset);
+ tell($z)
+ seek($z, $position, $whence)
+ binmode($z)
+ fileno($z)
+ eof($z)
+ close($z)
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows the reading of
+files/buffers that conform to RFC 1952.
+
+For writing RFC 1952 files/buffers, see the companion module IO::Compress::Gzip.
+
+=head1 Functional Interface
+
+A top-level function, C<gunzip>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
+
+ use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;
+
+ gunzip $input => $output [,OPTS]
+ or die "gunzip failed: $GunzipError\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 gunzip $input => $output [, OPTS]
+
+C<gunzip> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the compressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is uncompressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<gunzip> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<gunzip> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
+concatenation of all the uncompressed data from each of the input
+files/buffers.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<gunzip>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<gunzip> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<gunzip> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeOut => 0|1 >>
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+The behaviour of this option is dependent on the type of output data
+stream.
+
+=over 5
+
+=item * A Buffer
+
+If C<Append> is enabled, all uncompressed data will be append to the end of
+the output buffer. Otherwise the output buffer will be cleared before any
+uncompressed data is written to it.
+
+=item * A Filename
+
+If C<Append> is enabled, the file will be opened in append mode. Otherwise
+the contents of the file, if any, will be truncated before any uncompressed
+data is written to it.
+
+=item * A Filehandle
+
+If C<Append> is enabled, the filehandle will be positioned to the end of
+the file via a call to C<seek> before any uncompressed data is
+written to it. Otherwise the file pointer will not be moved.
+
+=back
+
+When C<Append> is specified, and set to true, it will I<append> all uncompressed
+data to the output data stream.
+
+So when the output is a filehandle it will carry out a seek to the eof
+before writing any uncompressed data. If the output is a filename, it will be opened for
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
+
+Conversely when C<Append> is not specified, or it is present and is set to
+false, it will operate as follows.
+
+When the output is a filename, it will truncate the contents of the file
+before writing any uncompressed data. If the output is a filehandle
+its position will not be changed. If the output is a buffer, it will be
+wiped before any uncompressed data is output.
+
+Defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+If the input file/buffer contains multiple compressed data streams, this
+option will uncompress the whole lot as a single data stream.
+
+Defaults to 0.
+
+=item C<< TrailingData => $scalar >>
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt.gz> and write the
+uncompressed data to the file C<file1.txt>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;
+
+ my $input = "file1.txt.gz";
+ my $output = "file1.txt";
+ gunzip $input => $output
+ or die "gunzip failed: $GunzipError\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+uncompressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt.gz"
+ or die "Cannot open 'file1.txt.gz': $!\n" ;
+ my $buffer ;
+ gunzip $input => \$buffer
+ or die "gunzip failed: $GunzipError\n";
+
+To uncompress all files in the directory "/my/home" that match "*.txt.gz" and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;
+
+ gunzip '</my/home/*.txt.gz>' => '</my/home/#1.txt>'
+ or die "gunzip failed: $GunzipError\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;
+
+ for my $input ( glob "/my/home/*.txt.gz" )
+ {
+ my $output = $input;
+ $output =~ s/.gz// ;
+ gunzip $input => $output
+ or die "Error compressing '$input': $GunzipError\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for IO::Uncompress::Gunzip is shown below
+
+ my $z = new IO::Uncompress::Gunzip $input [OPTS]
+ or die "IO::Uncompress::Gunzip failed: $GunzipError\n";
+
+Returns an C<IO::Uncompress::Gunzip> object on success and undef on failure.
+The variable C<$GunzipError> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::Gunzip can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
+
+ $line = $z->getline();
+ $line = <$z>;
+
+The mandatory parameter C<$input> is used to determine the source of the
+compressed data. This parameter can take one of three forms.
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a scalar, it is assumed to be a filename. This
+file will be opened for reading and the compressed data will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the compressed data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the compressed data will be read from
+C<$$output>.
+
+=back
+
+=head2 Constructor Options
+
+The option names defined below are case insensitive and can be optionally
+prefixed by a '-'. So all of the following are valid
+
+ -AutoClose
+ -autoclose
+ AUTOCLOSE
+ autoclose
+
+OPTS is a combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$input> parameter is a filehandle. If
+specified, and the value is true, it will result in the file being closed once
+either the C<close> method is called or the IO::Uncompress::Gunzip object is
+destroyed.
+
+This parameter defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+Allows multiple concatenated compressed streams to be treated as a single
+compressed stream. Decompression will stop once either the end of the
+file/buffer is reached, an error is encountered (premature eof, corrupt
+compressed data) or the end of a stream is not immediately followed by the
+start of another stream.
+
+This parameter defaults to 0.
+
+=item C<< Prime => $string >>
+
+This option will uncompress the contents of C<$string> before processing the
+input file/buffer.
+
+This option can be useful when the compressed data is embedded in another
+file/data structure and it is not possible to work out where the compressed
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
+
+=item C<< Transparent => 0|1 >>
+
+If this option is set and the input file/buffer is not compressed data,
+the module will allow reading of it anyway.
+
+In addition, if the input file/buffer does contain compressed data and
+there is non-compressed data immediately following it, setting this option
+will make this module treat the whole file/bufffer as a single data stream.
+
+This option defaults to 1.
+
+=item C<< BlockSize => $num >>
+
+When reading the compressed input data, IO::Uncompress::Gunzip will read it in
+blocks of C<$num> bytes.
+
+This option defaults to 4096.
+
+=item C<< InputLength => $size >>
+
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
+
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
+compressed data stream.
+
+This option defaults to off.
+
+=item C<< Append => 0|1 >>
+
+This option controls what the C<read> method does with uncompressed data.
+
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
+
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
+
+Defaults to 0.
+
+=item C<< Strict => 0|1 >>
+
+This option controls whether the extra checks defined below are used when
+carrying out the decompression. When Strict is on, the extra tests are
+carried out, when Strict is off they are not.
+
+The default for this option is off.
+
+=over 5
+
+=item 1
+
+If the FHCRC bit is set in the gzip FLG header byte, the CRC16 bytes in the
+header must match the crc16 value of the gzip header actually read.
+
+=item 2
+
+If the gzip header contains a name field (FNAME) it consists solely of ISO
+8859-1 characters.
+
+=item 3
+
+If the gzip header contains a comment field (FCOMMENT) it consists solely
+of ISO 8859-1 characters plus line-feed.
+
+=item 4
+
+If the gzip FEXTRA header field is present it must conform to the sub-field
+structure as defined in RFC 1952.
+
+=item 5
+
+The CRC32 and ISIZE trailer fields must be present.
+
+=item 6
+
+The value of the CRC32 field read must match the crc32 value of the
+uncompressed data actually contained in the gzip file.
+
+=item 7
+
+The value of the ISIZE fields read must match the length of the
+uncompressed data actually read from the file.
+
+=back
+
+=item C<< ParseExtra => 0|1 >>
+If the gzip FEXTRA header field is present and this option is set, it will
+force the module to check that it conforms to the sub-field structure as
+defined in RFC 1952.
+
+If the C<Strict> is on it will automatically enable this option.
+
+Defaults to 0.
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer)
+
+Reads a block of compressed data (the size the the compressed block is
+determined by the C<Buffer> option in the constructor), uncompresses it and
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+
+ $status = read($z, $buffer, $length)
+ $status = read($z, $buffer, $length, $offset)
+
+Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
+
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 getline
+
+Usage is
+
+ $line = $z->getline()
+ $line = <$z>
+
+Reads a single line.
+
+This method fully supports the use of of the variable C<$/> (or
+C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
+determine what constitutes an end of line. Paragraph mode, record mode and
+file slurp mode are all supported.
+
+=head2 getc
+
+Usage is
+
+ $char = $z->getc()
+
+Read a single character.
+
+=head2 ungetc
+
+Usage is
+
+ $char = $z->ungetc($string)
+
+=head2 inflateSync
+
+Usage is
+
+ $status = $z->inflateSync()
+
+TODO
+
+=head2 getHeaderInfo
+
+Usage is
+
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
+
+=over 5
+
+=item Name
+
+The contents of the Name header field, if present. If no name is
+present, the value will be undef. Note this is different from a zero length
+name, which will return an empty string.
+
+=item Comment
+
+The contents of the Comment header field, if present. If no comment is
+present, the value will be undef. Note this is different from a zero length
+comment, which will return an empty string.
+
+=back
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the end of the compressed input stream has been reached.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the input file/buffer.
+It is a fatal error to attempt to seek backward.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+Returns the current uncompressed line number. If C<EXPR> is present it has
+the effect of setting the line number. Note that setting the line number
+does not change the current position within the file/buffer being read.
+
+The contents of C<$/> are used to to determine what constitutes a line
+terminator.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Uncompress::Gunzip object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Uncompress::Gunzip
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 nextStream
+
+Usage is
+
+ my $status = $z->nextStream();
+
+Skips to the next compressed data stream in the input file/buffer. If a new
+compressed data stream is found, the eof marker will be cleared and C<$.>
+will be reset to 0.
+
+Returns 1 if a new stream was found, 0 if none was found, and -1 if an
+error was encountered.
+
+=head2 trailingData
+
+Usage is
+
+ my $data = $z->trailingData();
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete. It only makes sense to call
+this method once the end of the compressed data stream has been
+encountered.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option in the constructor.
+
+=head1 Importing
+
+No symbolic constants are required by this IO::Uncompress::Gunzip at present.
+
+=over 5
+
+=item :all
+
+Imports C<gunzip> and C<$GunzipError>.
+Same as doing this
+
+ use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Working with Net::FTP
+
+See L<IO::Uncompress::Gunzip::FAQ|IO::Uncompress::Gunzip::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm
new file mode 100755
index 00000000000..956f62e0835
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Inflate.pm
@@ -0,0 +1,982 @@
+package IO::Uncompress::Inflate ;
+# for RFC1950
+
+use strict ;
+use warnings;
+use bytes;
+
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+use IO::Compress::Zlib::Constants 2.024 ;
+
+use IO::Uncompress::RawInflate 2.024 ;
+
+require Exporter ;
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError);
+
+$VERSION = '2.024';
+$InflateError = '';
+
+@ISA = qw( Exporter IO::Uncompress::RawInflate );
+@EXPORT_OK = qw( $InflateError inflate ) ;
+%EXPORT_TAGS = %IO::Uncompress::RawInflate::DEFLATE_CONSTANTS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+
+sub new
+{
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$InflateError);
+
+ $obj->_create(undef, 0, @_);
+}
+
+sub inflate
+{
+ my $obj = createSelfTiedObject(undef, \$InflateError);
+ return $obj->_inf(@_);
+}
+
+sub getExtraParams
+{
+ return ();
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ # gunzip always needs adler32
+ $got->value('ADLER32' => 1);
+
+ return 1;
+}
+
+sub ckMagic
+{
+ my $self = shift;
+
+ my $magic ;
+ $self->smartReadExact(\$magic, ZLIB_HEADER_SIZE);
+
+ *$self->{HeaderPending} = $magic ;
+
+ return $self->HeaderError("Header size is " .
+ ZLIB_HEADER_SIZE . " bytes")
+ if length $magic != ZLIB_HEADER_SIZE;
+
+ #return $self->HeaderError("CRC mismatch.")
+ return undef
+ if ! $self->isZlibMagic($magic) ;
+
+ *$self->{Type} = 'rfc1950';
+ return $magic;
+}
+
+sub readHeader
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ return $self->_readDeflateHeader($magic) ;
+}
+
+sub chkTrailer
+{
+ my $self = shift;
+ my $trailer = shift;
+
+ my $ADLER32 = unpack("N", $trailer) ;
+ *$self->{Info}{ADLER32} = $ADLER32;
+ return $self->TrailerError("CRC mismatch")
+ if *$self->{Strict} && $ADLER32 != *$self->{Uncomp}->adler32() ;
+
+ return STATUS_OK;
+}
+
+
+
+sub isZlibMagic
+{
+ my $self = shift;
+ my $buffer = shift ;
+
+ return 0
+ if length $buffer < ZLIB_HEADER_SIZE ;
+
+ my $hdr = unpack("n", $buffer) ;
+ #return 0 if $hdr % 31 != 0 ;
+ return $self->HeaderError("CRC mismatch.")
+ if $hdr % 31 != 0 ;
+
+ my ($CMF, $FLG) = unpack "C C", $buffer;
+ my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ;
+
+ # Only Deflate supported
+ return $self->HeaderError("Not Deflate (CM is $cm)")
+ if $cm != ZLIB_CMF_CM_DEFLATED ;
+
+ # Max window value is 7 for Deflate.
+ my $cinfo = bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS) ;
+ return $self->HeaderError("CINFO > " . ZLIB_CMF_CINFO_MAX .
+ " (CINFO is $cinfo)")
+ if $cinfo > ZLIB_CMF_CINFO_MAX ;
+
+ return 1;
+}
+
+sub bits
+{
+ my $data = shift ;
+ my $offset = shift ;
+ my $mask = shift ;
+
+ ($data >> $offset ) & $mask & 0xFF ;
+}
+
+
+sub _readDeflateHeader
+{
+ my ($self, $buffer) = @_ ;
+
+# if (! $buffer) {
+# $self->smartReadExact(\$buffer, ZLIB_HEADER_SIZE);
+#
+# *$self->{HeaderPending} = $buffer ;
+#
+# return $self->HeaderError("Header size is " .
+# ZLIB_HEADER_SIZE . " bytes")
+# if length $buffer != ZLIB_HEADER_SIZE;
+#
+# return $self->HeaderError("CRC mismatch.")
+# if ! isZlibMagic($buffer) ;
+# }
+
+ my ($CMF, $FLG) = unpack "C C", $buffer;
+ my $FDICT = bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ),
+
+ my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ;
+ $cm == ZLIB_CMF_CM_DEFLATED
+ or return $self->HeaderError("Not Deflate (CM is $cm)") ;
+
+ my $DICTID;
+ if ($FDICT) {
+ $self->smartReadExact(\$buffer, ZLIB_FDICT_SIZE)
+ or return $self->TruncatedHeader("FDICT");
+
+ $DICTID = unpack("N", $buffer) ;
+ }
+
+ *$self->{Type} = 'rfc1950';
+
+ return {
+ 'Type' => 'rfc1950',
+ 'FingerprintLength' => ZLIB_HEADER_SIZE,
+ 'HeaderLength' => ZLIB_HEADER_SIZE,
+ 'TrailerLength' => ZLIB_TRAILER_SIZE,
+ 'Header' => $buffer,
+
+ CMF => $CMF ,
+ CM => bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS ),
+ CINFO => bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS ),
+ FLG => $FLG ,
+ FCHECK => bits($FLG, ZLIB_FLG_FCHECK_OFFSET, ZLIB_FLG_FCHECK_BITS),
+ FDICT => bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ),
+ FLEVEL => bits($FLG, ZLIB_FLG_LEVEL_OFFSET, ZLIB_FLG_LEVEL_BITS ),
+ DICTID => $DICTID ,
+
+ };
+}
+
+
+
+
+1 ;
+
+__END__
+
+
+=head1 NAME
+
+IO::Uncompress::Inflate - Read RFC 1950 files/buffers
+
+=head1 SYNOPSIS
+
+ use IO::Uncompress::Inflate qw(inflate $InflateError) ;
+
+ my $status = inflate $input => $output [,OPTS]
+ or die "inflate failed: $InflateError\n";
+
+ my $z = new IO::Uncompress::Inflate $input [OPTS]
+ or die "inflate failed: $InflateError\n";
+
+ $status = $z->read($buffer)
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+ $line = $z->getline()
+ $char = $z->getc()
+ $char = $z->ungetc()
+ $char = $z->opened()
+
+ $status = $z->inflateSync()
+
+ $data = $z->trailingData()
+ $status = $z->nextStream()
+ $data = $z->getHeaderInfo()
+ $z->tell()
+ $z->seek($position, $whence)
+ $z->binmode()
+ $z->fileno()
+ $z->eof()
+ $z->close()
+
+ $InflateError ;
+
+ # IO::File mode
+
+ <$z>
+ read($z, $buffer);
+ read($z, $buffer, $length);
+ read($z, $buffer, $length, $offset);
+ tell($z)
+ seek($z, $position, $whence)
+ binmode($z)
+ fileno($z)
+ eof($z)
+ close($z)
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows the reading of
+files/buffers that conform to RFC 1950.
+
+For writing RFC 1950 files/buffers, see the companion module IO::Compress::Deflate.
+
+=head1 Functional Interface
+
+A top-level function, C<inflate>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
+
+ use IO::Uncompress::Inflate qw(inflate $InflateError) ;
+
+ inflate $input => $output [,OPTS]
+ or die "inflate failed: $InflateError\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 inflate $input => $output [, OPTS]
+
+C<inflate> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the compressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is uncompressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<inflate> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<inflate> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
+concatenation of all the uncompressed data from each of the input
+files/buffers.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<inflate>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<inflate> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<inflate> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeOut => 0|1 >>
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+The behaviour of this option is dependent on the type of output data
+stream.
+
+=over 5
+
+=item * A Buffer
+
+If C<Append> is enabled, all uncompressed data will be append to the end of
+the output buffer. Otherwise the output buffer will be cleared before any
+uncompressed data is written to it.
+
+=item * A Filename
+
+If C<Append> is enabled, the file will be opened in append mode. Otherwise
+the contents of the file, if any, will be truncated before any uncompressed
+data is written to it.
+
+=item * A Filehandle
+
+If C<Append> is enabled, the filehandle will be positioned to the end of
+the file via a call to C<seek> before any uncompressed data is
+written to it. Otherwise the file pointer will not be moved.
+
+=back
+
+When C<Append> is specified, and set to true, it will I<append> all uncompressed
+data to the output data stream.
+
+So when the output is a filehandle it will carry out a seek to the eof
+before writing any uncompressed data. If the output is a filename, it will be opened for
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
+
+Conversely when C<Append> is not specified, or it is present and is set to
+false, it will operate as follows.
+
+When the output is a filename, it will truncate the contents of the file
+before writing any uncompressed data. If the output is a filehandle
+its position will not be changed. If the output is a buffer, it will be
+wiped before any uncompressed data is output.
+
+Defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+If the input file/buffer contains multiple compressed data streams, this
+option will uncompress the whole lot as a single data stream.
+
+Defaults to 0.
+
+=item C<< TrailingData => $scalar >>
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt.1950> and write the
+uncompressed data to the file C<file1.txt>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Inflate qw(inflate $InflateError) ;
+
+ my $input = "file1.txt.1950";
+ my $output = "file1.txt";
+ inflate $input => $output
+ or die "inflate failed: $InflateError\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+uncompressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Inflate qw(inflate $InflateError) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt.1950"
+ or die "Cannot open 'file1.txt.1950': $!\n" ;
+ my $buffer ;
+ inflate $input => \$buffer
+ or die "inflate failed: $InflateError\n";
+
+To uncompress all files in the directory "/my/home" that match "*.txt.1950" and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Inflate qw(inflate $InflateError) ;
+
+ inflate '</my/home/*.txt.1950>' => '</my/home/#1.txt>'
+ or die "inflate failed: $InflateError\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Inflate qw(inflate $InflateError) ;
+
+ for my $input ( glob "/my/home/*.txt.1950" )
+ {
+ my $output = $input;
+ $output =~ s/.1950// ;
+ inflate $input => $output
+ or die "Error compressing '$input': $InflateError\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for IO::Uncompress::Inflate is shown below
+
+ my $z = new IO::Uncompress::Inflate $input [OPTS]
+ or die "IO::Uncompress::Inflate failed: $InflateError\n";
+
+Returns an C<IO::Uncompress::Inflate> object on success and undef on failure.
+The variable C<$InflateError> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::Inflate can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
+
+ $line = $z->getline();
+ $line = <$z>;
+
+The mandatory parameter C<$input> is used to determine the source of the
+compressed data. This parameter can take one of three forms.
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a scalar, it is assumed to be a filename. This
+file will be opened for reading and the compressed data will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the compressed data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the compressed data will be read from
+C<$$output>.
+
+=back
+
+=head2 Constructor Options
+
+The option names defined below are case insensitive and can be optionally
+prefixed by a '-'. So all of the following are valid
+
+ -AutoClose
+ -autoclose
+ AUTOCLOSE
+ autoclose
+
+OPTS is a combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$input> parameter is a filehandle. If
+specified, and the value is true, it will result in the file being closed once
+either the C<close> method is called or the IO::Uncompress::Inflate object is
+destroyed.
+
+This parameter defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+Allows multiple concatenated compressed streams to be treated as a single
+compressed stream. Decompression will stop once either the end of the
+file/buffer is reached, an error is encountered (premature eof, corrupt
+compressed data) or the end of a stream is not immediately followed by the
+start of another stream.
+
+This parameter defaults to 0.
+
+=item C<< Prime => $string >>
+
+This option will uncompress the contents of C<$string> before processing the
+input file/buffer.
+
+This option can be useful when the compressed data is embedded in another
+file/data structure and it is not possible to work out where the compressed
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
+
+=item C<< Transparent => 0|1 >>
+
+If this option is set and the input file/buffer is not compressed data,
+the module will allow reading of it anyway.
+
+In addition, if the input file/buffer does contain compressed data and
+there is non-compressed data immediately following it, setting this option
+will make this module treat the whole file/bufffer as a single data stream.
+
+This option defaults to 1.
+
+=item C<< BlockSize => $num >>
+
+When reading the compressed input data, IO::Uncompress::Inflate will read it in
+blocks of C<$num> bytes.
+
+This option defaults to 4096.
+
+=item C<< InputLength => $size >>
+
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
+
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
+compressed data stream.
+
+This option defaults to off.
+
+=item C<< Append => 0|1 >>
+
+This option controls what the C<read> method does with uncompressed data.
+
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
+
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
+
+Defaults to 0.
+
+=item C<< Strict => 0|1 >>
+
+This option controls whether the extra checks defined below are used when
+carrying out the decompression. When Strict is on, the extra tests are
+carried out, when Strict is off they are not.
+
+The default for this option is off.
+
+=over 5
+
+=item 1
+
+The ADLER32 checksum field must be present.
+
+=item 2
+
+The value of the ADLER32 field read must match the adler32 value of the
+uncompressed data actually contained in the file.
+
+=back
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer)
+
+Reads a block of compressed data (the size the the compressed block is
+determined by the C<Buffer> option in the constructor), uncompresses it and
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+
+ $status = read($z, $buffer, $length)
+ $status = read($z, $buffer, $length, $offset)
+
+Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
+
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 getline
+
+Usage is
+
+ $line = $z->getline()
+ $line = <$z>
+
+Reads a single line.
+
+This method fully supports the use of of the variable C<$/> (or
+C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
+determine what constitutes an end of line. Paragraph mode, record mode and
+file slurp mode are all supported.
+
+=head2 getc
+
+Usage is
+
+ $char = $z->getc()
+
+Read a single character.
+
+=head2 ungetc
+
+Usage is
+
+ $char = $z->ungetc($string)
+
+=head2 inflateSync
+
+Usage is
+
+ $status = $z->inflateSync()
+
+TODO
+
+=head2 getHeaderInfo
+
+Usage is
+
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the end of the compressed input stream has been reached.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the input file/buffer.
+It is a fatal error to attempt to seek backward.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+Returns the current uncompressed line number. If C<EXPR> is present it has
+the effect of setting the line number. Note that setting the line number
+does not change the current position within the file/buffer being read.
+
+The contents of C<$/> are used to to determine what constitutes a line
+terminator.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Uncompress::Inflate object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Uncompress::Inflate
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 nextStream
+
+Usage is
+
+ my $status = $z->nextStream();
+
+Skips to the next compressed data stream in the input file/buffer. If a new
+compressed data stream is found, the eof marker will be cleared and C<$.>
+will be reset to 0.
+
+Returns 1 if a new stream was found, 0 if none was found, and -1 if an
+error was encountered.
+
+=head2 trailingData
+
+Usage is
+
+ my $data = $z->trailingData();
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete. It only makes sense to call
+this method once the end of the compressed data stream has been
+encountered.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option in the constructor.
+
+=head1 Importing
+
+No symbolic constants are required by this IO::Uncompress::Inflate at present.
+
+=over 5
+
+=item :all
+
+Imports C<inflate> and C<$InflateError>.
+Same as doing this
+
+ use IO::Uncompress::Inflate qw(inflate $InflateError) ;
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Working with Net::FTP
+
+See L<IO::Uncompress::Inflate::FAQ|IO::Uncompress::Inflate::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm
new file mode 100755
index 00000000000..f017fa0f599
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/RawInflate.pm
@@ -0,0 +1,1110 @@
+package IO::Uncompress::RawInflate ;
+# for RFC1951
+
+use strict ;
+use warnings;
+use bytes;
+
+use Compress::Raw::Zlib 2.024 ;
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+
+use IO::Uncompress::Base 2.024 ;
+use IO::Uncompress::Adapter::Inflate 2.024 ;
+
+require Exporter ;
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError);
+
+$VERSION = '2.024';
+$RawInflateError = '';
+
+@ISA = qw( Exporter IO::Uncompress::Base );
+@EXPORT_OK = qw( $RawInflateError rawinflate ) ;
+%DEFLATE_CONSTANTS = ();
+%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+#{
+# # Execute at runtime
+# my %bad;
+# for my $module (qw(Compress::Raw::Zlib IO::Compress::Base::Common IO::Uncompress::Base IO::Uncompress::Adapter::Inflate))
+# {
+# my $ver = ${ $module . "::VERSION"} ;
+#
+# $bad{$module} = $ver
+# if $ver ne $VERSION;
+# }
+#
+# if (keys %bad)
+# {
+# my $string = join "\n", map { "$_ $bad{$_}" } keys %bad;
+# die caller(0)[0] . "needs version $VERSION mismatch\n$string\n";
+# }
+#}
+
+sub new
+{
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$RawInflateError);
+ $obj->_create(undef, 0, @_);
+}
+
+sub rawinflate
+{
+ my $obj = createSelfTiedObject(undef, \$RawInflateError);
+ return $obj->_inf(@_);
+}
+
+sub getExtraParams
+{
+ return ();
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ return 1;
+}
+
+sub mkUncomp
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject(
+ $got->value('CRC32'),
+ $got->value('ADLER32'),
+ $got->value('Scan'),
+ );
+
+ return $self->saveErrorString(undef, $errstr, $errno)
+ if ! defined $obj;
+
+ *$self->{Uncomp} = $obj;
+
+ my $magic = $self->ckMagic()
+ or return 0;
+
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ return 1;
+
+}
+
+
+sub ckMagic
+{
+ my $self = shift;
+
+ return $self->_isRaw() ;
+}
+
+sub readHeader
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ return {
+ 'Type' => 'rfc1951',
+ 'FingerprintLength' => 0,
+ 'HeaderLength' => 0,
+ 'TrailerLength' => 0,
+ 'Header' => ''
+ };
+}
+
+sub chkTrailer
+{
+ return STATUS_OK ;
+}
+
+sub _isRaw
+{
+ my $self = shift ;
+
+ my $got = $self->_isRawx(@_);
+
+ if ($got) {
+ *$self->{Pending} = *$self->{HeaderPending} ;
+ }
+ else {
+ $self->pushBack(*$self->{HeaderPending});
+ *$self->{Uncomp}->reset();
+ }
+ *$self->{HeaderPending} = '';
+
+ return $got ;
+}
+
+sub _isRawx
+{
+ my $self = shift ;
+ my $magic = shift ;
+
+ $magic = '' unless defined $magic ;
+
+ my $buffer = '';
+
+ $self->smartRead(\$buffer, *$self->{BlockSize}) >= 0
+ or return $self->saveErrorString(undef, "No data to read");
+
+ my $temp_buf = $magic . $buffer ;
+ *$self->{HeaderPending} = $temp_buf ;
+ $buffer = '';
+ my $status = *$self->{Uncomp}->uncompr(\$temp_buf, \$buffer, $self->smartEof()) ;
+
+ return $self->saveErrorString(undef, *$self->{Uncomp}{Error}, STATUS_ERROR)
+ if $status == STATUS_ERROR;
+
+ $self->pushBack($temp_buf) ;
+
+ return $self->saveErrorString(undef, "unexpected end of file", STATUS_ERROR)
+ if $self->smartEof() && $status != STATUS_ENDSTREAM;
+
+ #my $buf_len = *$self->{Uncomp}->uncompressedBytes();
+ my $buf_len = length $buffer;
+
+ if ($status == STATUS_ENDSTREAM) {
+ if (*$self->{MultiStream}
+ && (length $temp_buf || ! $self->smartEof())){
+ *$self->{NewStream} = 1 ;
+ *$self->{EndStream} = 0 ;
+ }
+ else {
+ *$self->{EndStream} = 1 ;
+ }
+ }
+ *$self->{HeaderPending} = $buffer ;
+ *$self->{InflatedBytesRead} = $buf_len ;
+ *$self->{TotalInflatedBytesRead} += $buf_len ;
+ *$self->{Type} = 'rfc1951';
+
+ $self->saveStatus(STATUS_OK);
+
+ return {
+ 'Type' => 'rfc1951',
+ 'HeaderLength' => 0,
+ 'TrailerLength' => 0,
+ 'Header' => ''
+ };
+}
+
+
+sub inflateSync
+{
+ my $self = shift ;
+
+ # inflateSync is a no-op in Plain mode
+ return 1
+ if *$self->{Plain} ;
+
+ return 0 if *$self->{Closed} ;
+ #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
+ return 0 if ! length *$self->{Pending} && *$self->{EndStream} ;
+
+ # Disable CRC check
+ *$self->{Strict} = 0 ;
+
+ my $status ;
+ while (1)
+ {
+ my $temp_buf ;
+
+ if (length *$self->{Pending} )
+ {
+ $temp_buf = *$self->{Pending} ;
+ *$self->{Pending} = '';
+ }
+ else
+ {
+ $status = $self->smartRead(\$temp_buf, *$self->{BlockSize}) ;
+ return $self->saveErrorString(0, "Error Reading Data")
+ if $status < 0 ;
+
+ if ($status == 0 ) {
+ *$self->{EndStream} = 1 ;
+ return $self->saveErrorString(0, "unexpected end of file", STATUS_ERROR);
+ }
+ }
+
+ $status = *$self->{Uncomp}->sync($temp_buf) ;
+
+ if ($status == STATUS_OK)
+ {
+ *$self->{Pending} .= $temp_buf ;
+ return 1 ;
+ }
+
+ last unless $status == STATUS_ERROR ;
+ }
+
+ return 0;
+}
+
+#sub performScan
+#{
+# my $self = shift ;
+#
+# my $status ;
+# my $end_offset = 0;
+#
+# $status = $self->scan()
+# #or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $self->errorNo) ;
+# or return $self->saveErrorString(G_ERR, "Error Scanning: $status")
+#
+# $status = $self->zap($end_offset)
+# or return $self->saveErrorString(G_ERR, "Error Zapping: $status");
+# #or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $self->errorNo) ;
+#
+# #(*$obj->{Deflate}, $status) = $inf->createDeflate();
+#
+## *$obj->{Header} = *$inf->{Info}{Header};
+## *$obj->{UnCompSize_32bit} =
+## *$obj->{BytesWritten} = *$inf->{UnCompSize_32bit} ;
+## *$obj->{CompSize_32bit} = *$inf->{CompSize_32bit} ;
+#
+#
+## if ( $outType eq 'buffer')
+## { substr( ${ *$self->{Buffer} }, $end_offset) = '' }
+## elsif ($outType eq 'handle' || $outType eq 'filename') {
+## *$self->{FH} = *$inf->{FH} ;
+## delete *$inf->{FH};
+## *$obj->{FH}->flush() ;
+## *$obj->{Handle} = 1 if $outType eq 'handle';
+##
+## #seek(*$obj->{FH}, $end_offset, SEEK_SET)
+## *$obj->{FH}->seek($end_offset, SEEK_SET)
+## or return $obj->saveErrorString(undef, $!, $!) ;
+## }
+#
+#}
+
+sub scan
+{
+ my $self = shift ;
+
+ return 1 if *$self->{Closed} ;
+ return 1 if !length *$self->{Pending} && *$self->{EndStream} ;
+
+ my $buffer = '' ;
+ my $len = 0;
+
+ $len = $self->_raw_read(\$buffer, 1)
+ while ! *$self->{EndStream} && $len >= 0 ;
+
+ #return $len if $len < 0 ? $len : 0 ;
+ return $len < 0 ? 0 : 1 ;
+}
+
+sub zap
+{
+ my $self = shift ;
+
+ my $headerLength = *$self->{Info}{HeaderLength};
+ my $block_offset = $headerLength + *$self->{Uncomp}->getLastBlockOffset();
+ $_[0] = $headerLength + *$self->{Uncomp}->getEndOffset();
+ #printf "# End $_[0], headerlen $headerLength \n";;
+ #printf "# block_offset $block_offset %x\n", $block_offset;
+ my $byte ;
+ ( $self->smartSeek($block_offset) &&
+ $self->smartRead(\$byte, 1) )
+ or return $self->saveErrorString(0, $!, $!);
+
+ #printf "#byte is %x\n", unpack('C*',$byte);
+ *$self->{Uncomp}->resetLastBlockByte($byte);
+ #printf "#to byte is %x\n", unpack('C*',$byte);
+
+ ( $self->smartSeek($block_offset) &&
+ $self->smartWrite($byte) )
+ or return $self->saveErrorString(0, $!, $!);
+
+ #$self->smartSeek($end_offset, 1);
+
+ return 1 ;
+}
+
+sub createDeflate
+{
+ my $self = shift ;
+ my ($def, $status) = *$self->{Uncomp}->createDeflateStream(
+ -AppendOutput => 1,
+ -WindowBits => - MAX_WBITS,
+ -CRC32 => *$self->{Params}->value('CRC32'),
+ -ADLER32 => *$self->{Params}->value('ADLER32'),
+ );
+
+ return wantarray ? ($status, $def) : $def ;
+}
+
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+IO::Uncompress::RawInflate - Read RFC 1951 files/buffers
+
+=head1 SYNOPSIS
+
+ use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ;
+
+ my $status = rawinflate $input => $output [,OPTS]
+ or die "rawinflate failed: $RawInflateError\n";
+
+ my $z = new IO::Uncompress::RawInflate $input [OPTS]
+ or die "rawinflate failed: $RawInflateError\n";
+
+ $status = $z->read($buffer)
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+ $line = $z->getline()
+ $char = $z->getc()
+ $char = $z->ungetc()
+ $char = $z->opened()
+
+ $status = $z->inflateSync()
+
+ $data = $z->trailingData()
+ $status = $z->nextStream()
+ $data = $z->getHeaderInfo()
+ $z->tell()
+ $z->seek($position, $whence)
+ $z->binmode()
+ $z->fileno()
+ $z->eof()
+ $z->close()
+
+ $RawInflateError ;
+
+ # IO::File mode
+
+ <$z>
+ read($z, $buffer);
+ read($z, $buffer, $length);
+ read($z, $buffer, $length, $offset);
+ tell($z)
+ seek($z, $position, $whence)
+ binmode($z)
+ fileno($z)
+ eof($z)
+ close($z)
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows the reading of
+files/buffers that conform to RFC 1951.
+
+For writing RFC 1951 files/buffers, see the companion module IO::Compress::RawDeflate.
+
+=head1 Functional Interface
+
+A top-level function, C<rawinflate>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
+
+ use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ;
+
+ rawinflate $input => $output [,OPTS]
+ or die "rawinflate failed: $RawInflateError\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 rawinflate $input => $output [, OPTS]
+
+C<rawinflate> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the compressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is uncompressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<rawinflate> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<rawinflate> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
+concatenation of all the uncompressed data from each of the input
+files/buffers.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<rawinflate>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<rawinflate> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<rawinflate> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeOut => 0|1 >>
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+The behaviour of this option is dependent on the type of output data
+stream.
+
+=over 5
+
+=item * A Buffer
+
+If C<Append> is enabled, all uncompressed data will be append to the end of
+the output buffer. Otherwise the output buffer will be cleared before any
+uncompressed data is written to it.
+
+=item * A Filename
+
+If C<Append> is enabled, the file will be opened in append mode. Otherwise
+the contents of the file, if any, will be truncated before any uncompressed
+data is written to it.
+
+=item * A Filehandle
+
+If C<Append> is enabled, the filehandle will be positioned to the end of
+the file via a call to C<seek> before any uncompressed data is
+written to it. Otherwise the file pointer will not be moved.
+
+=back
+
+When C<Append> is specified, and set to true, it will I<append> all uncompressed
+data to the output data stream.
+
+So when the output is a filehandle it will carry out a seek to the eof
+before writing any uncompressed data. If the output is a filename, it will be opened for
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
+
+Conversely when C<Append> is not specified, or it is present and is set to
+false, it will operate as follows.
+
+When the output is a filename, it will truncate the contents of the file
+before writing any uncompressed data. If the output is a filehandle
+its position will not be changed. If the output is a buffer, it will be
+wiped before any uncompressed data is output.
+
+Defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+This option is a no-op.
+
+=item C<< TrailingData => $scalar >>
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt.1951> and write the
+uncompressed data to the file C<file1.txt>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ;
+
+ my $input = "file1.txt.1951";
+ my $output = "file1.txt";
+ rawinflate $input => $output
+ or die "rawinflate failed: $RawInflateError\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+uncompressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt.1951"
+ or die "Cannot open 'file1.txt.1951': $!\n" ;
+ my $buffer ;
+ rawinflate $input => \$buffer
+ or die "rawinflate failed: $RawInflateError\n";
+
+To uncompress all files in the directory "/my/home" that match "*.txt.1951" and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ;
+
+ rawinflate '</my/home/*.txt.1951>' => '</my/home/#1.txt>'
+ or die "rawinflate failed: $RawInflateError\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ;
+
+ for my $input ( glob "/my/home/*.txt.1951" )
+ {
+ my $output = $input;
+ $output =~ s/.1951// ;
+ rawinflate $input => $output
+ or die "Error compressing '$input': $RawInflateError\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for IO::Uncompress::RawInflate is shown below
+
+ my $z = new IO::Uncompress::RawInflate $input [OPTS]
+ or die "IO::Uncompress::RawInflate failed: $RawInflateError\n";
+
+Returns an C<IO::Uncompress::RawInflate> object on success and undef on failure.
+The variable C<$RawInflateError> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::RawInflate can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
+
+ $line = $z->getline();
+ $line = <$z>;
+
+The mandatory parameter C<$input> is used to determine the source of the
+compressed data. This parameter can take one of three forms.
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a scalar, it is assumed to be a filename. This
+file will be opened for reading and the compressed data will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the compressed data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the compressed data will be read from
+C<$$output>.
+
+=back
+
+=head2 Constructor Options
+
+The option names defined below are case insensitive and can be optionally
+prefixed by a '-'. So all of the following are valid
+
+ -AutoClose
+ -autoclose
+ AUTOCLOSE
+ autoclose
+
+OPTS is a combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$input> parameter is a filehandle. If
+specified, and the value is true, it will result in the file being closed once
+either the C<close> method is called or the IO::Uncompress::RawInflate object is
+destroyed.
+
+This parameter defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+Allows multiple concatenated compressed streams to be treated as a single
+compressed stream. Decompression will stop once either the end of the
+file/buffer is reached, an error is encountered (premature eof, corrupt
+compressed data) or the end of a stream is not immediately followed by the
+start of another stream.
+
+This parameter defaults to 0.
+
+=item C<< Prime => $string >>
+
+This option will uncompress the contents of C<$string> before processing the
+input file/buffer.
+
+This option can be useful when the compressed data is embedded in another
+file/data structure and it is not possible to work out where the compressed
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
+
+=item C<< Transparent => 0|1 >>
+
+If this option is set and the input file/buffer is not compressed data,
+the module will allow reading of it anyway.
+
+In addition, if the input file/buffer does contain compressed data and
+there is non-compressed data immediately following it, setting this option
+will make this module treat the whole file/bufffer as a single data stream.
+
+This option defaults to 1.
+
+=item C<< BlockSize => $num >>
+
+When reading the compressed input data, IO::Uncompress::RawInflate will read it in
+blocks of C<$num> bytes.
+
+This option defaults to 4096.
+
+=item C<< InputLength => $size >>
+
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
+
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
+compressed data stream.
+
+This option defaults to off.
+
+=item C<< Append => 0|1 >>
+
+This option controls what the C<read> method does with uncompressed data.
+
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
+
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
+
+Defaults to 0.
+
+=item C<< Strict => 0|1 >>
+
+This option is a no-op.
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer)
+
+Reads a block of compressed data (the size the the compressed block is
+determined by the C<Buffer> option in the constructor), uncompresses it and
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+
+ $status = read($z, $buffer, $length)
+ $status = read($z, $buffer, $length, $offset)
+
+Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
+
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 getline
+
+Usage is
+
+ $line = $z->getline()
+ $line = <$z>
+
+Reads a single line.
+
+This method fully supports the use of of the variable C<$/> (or
+C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
+determine what constitutes an end of line. Paragraph mode, record mode and
+file slurp mode are all supported.
+
+=head2 getc
+
+Usage is
+
+ $char = $z->getc()
+
+Read a single character.
+
+=head2 ungetc
+
+Usage is
+
+ $char = $z->ungetc($string)
+
+=head2 inflateSync
+
+Usage is
+
+ $status = $z->inflateSync()
+
+TODO
+
+=head2 getHeaderInfo
+
+Usage is
+
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the end of the compressed input stream has been reached.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the input file/buffer.
+It is a fatal error to attempt to seek backward.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+Returns the current uncompressed line number. If C<EXPR> is present it has
+the effect of setting the line number. Note that setting the line number
+does not change the current position within the file/buffer being read.
+
+The contents of C<$/> are used to to determine what constitutes a line
+terminator.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Uncompress::RawInflate object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Uncompress::RawInflate
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 nextStream
+
+Usage is
+
+ my $status = $z->nextStream();
+
+Skips to the next compressed data stream in the input file/buffer. If a new
+compressed data stream is found, the eof marker will be cleared and C<$.>
+will be reset to 0.
+
+Returns 1 if a new stream was found, 0 if none was found, and -1 if an
+error was encountered.
+
+=head2 trailingData
+
+Usage is
+
+ my $data = $z->trailingData();
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete. It only makes sense to call
+this method once the end of the compressed data stream has been
+encountered.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option in the constructor.
+
+=head1 Importing
+
+No symbolic constants are required by this IO::Uncompress::RawInflate at present.
+
+=over 5
+
+=item :all
+
+Imports C<rawinflate> and C<$RawInflateError>.
+Same as doing this
+
+ use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ;
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Working with Net::FTP
+
+See L<IO::Uncompress::RawInflate::FAQ|IO::Uncompress::RawInflate::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm b/Master/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm
new file mode 100755
index 00000000000..e7d6849f66b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Uncompress/Unzip.pm
@@ -0,0 +1,1549 @@
+package IO::Uncompress::Unzip;
+
+require 5.004 ;
+
+# for RFC1952
+
+use strict ;
+use warnings;
+use bytes;
+
+use IO::Uncompress::RawInflate 2.024 ;
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+use IO::Uncompress::Adapter::Inflate 2.024 ;
+use IO::Uncompress::Adapter::Identity 2.024 ;
+use IO::Compress::Zlib::Extra 2.024 ;
+use IO::Compress::Zip::Constants 2.024 ;
+
+use Compress::Raw::Zlib 2.024 qw(crc32) ;
+
+BEGIN
+{
+ eval { require IO::Uncompress::Adapter::Bunzip2 ;
+ import IO::Uncompress::Adapter::Bunzip2 } ;
+# eval { require IO::Uncompress::Adapter::UnLzma ;
+# import IO::Uncompress::Adapter::UnLzma } ;
+}
+
+
+require Exporter ;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError, %headerLookup);
+
+$VERSION = '2.024';
+$UnzipError = '';
+
+@ISA = qw(Exporter IO::Uncompress::RawInflate);
+@EXPORT_OK = qw( $UnzipError unzip );
+%EXPORT_TAGS = %IO::Uncompress::RawInflate::EXPORT_TAGS ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+Exporter::export_ok_tags('all');
+
+%headerLookup = (
+ ZIP_CENTRAL_HDR_SIG, \&skipCentralDirectory,
+ ZIP_END_CENTRAL_HDR_SIG, \&skipEndCentralDirectory,
+ ZIP64_END_CENTRAL_REC_HDR_SIG, \&skipCentralDirectory64Rec,
+ ZIP64_END_CENTRAL_LOC_HDR_SIG, \&skipCentralDirectory64Loc,
+ ZIP64_ARCHIVE_EXTRA_SIG, \&skipArchiveExtra,
+ ZIP64_DIGITAL_SIGNATURE_SIG, \&skipDigitalSignature,
+ );
+
+sub new
+{
+ my $class = shift ;
+ my $obj = createSelfTiedObject($class, \$UnzipError);
+ $obj->_create(undef, 0, @_);
+}
+
+sub unzip
+{
+ my $obj = createSelfTiedObject(undef, \$UnzipError);
+ return $obj->_inf(@_) ;
+}
+
+sub getExtraParams
+{
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+
+
+ return (
+# # Zip header fields
+ 'Name' => [1, 1, Parse_any, undef],
+
+# 'Stream' => [1, 1, Parse_boolean, 1],
+ # This means reading the central directory to get
+ # 1. the local header offsets
+ # 2. The compressed data length
+ );
+}
+
+sub ckParams
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ # unzip always needs crc32
+ $got->value('CRC32' => 1);
+
+ *$self->{UnzipData}{Name} = $got->value('Name');
+
+ return 1;
+}
+
+sub mkUncomp
+{
+ my $self = shift ;
+ my $got = shift ;
+
+ my $magic = $self->ckMagic()
+ or return 0;
+
+ *$self->{Info} = $self->readHeader($magic)
+ or return undef ;
+
+ return 1;
+
+}
+
+sub ckMagic
+{
+ my $self = shift;
+
+ my $magic ;
+ $self->smartReadExact(\$magic, 4);
+
+ *$self->{HeaderPending} = $magic ;
+
+ return $self->HeaderError("Minimum header size is " .
+ 4 . " bytes")
+ if length $magic != 4 ;
+
+ return $self->HeaderError("Bad Magic")
+ if ! _isZipMagic($magic) ;
+
+ *$self->{Type} = 'zip';
+
+ return $magic ;
+}
+
+
+sub fastForward
+{
+ my $self = shift;
+ my $offset = shift;
+
+ # TODO - if Stream isn't enabled & reading from file, use seek
+
+ my $buffer = '';
+ my $c = 1024 * 16;
+
+ while ($offset > 0)
+ {
+ $c = length $offset
+ if length $offset < $c ;
+
+ $offset -= $c;
+
+ $self->smartReadExact(\$buffer, $c)
+ or return 0;
+ }
+
+ return 1;
+}
+
+
+sub readHeader
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ my $name = *$self->{UnzipData}{Name} ;
+ my $hdr = $self->_readZipHeader($magic) ;
+
+ while (defined $hdr)
+ {
+ if (! defined $name || $hdr->{Name} eq $name)
+ {
+ return $hdr ;
+ }
+
+ # skip the data
+ # TODO - when Stream is off, use seek
+ my $buffer;
+ if (*$self->{ZipData}{Streaming}) {
+
+ while (1) {
+
+ my $b;
+ my $status = $self->smartRead(\$b, 1024 * 16);
+ return undef
+ if $status <= 0 ;
+
+ my $temp_buf;
+ my $out;
+ $status = *$self->{Uncomp}->uncompr(\$b, \$temp_buf, 0, $out);
+
+ return $self->saveErrorString(undef, *$self->{Uncomp}{Error},
+ *$self->{Uncomp}{ErrorNo})
+ if $self->saveStatus($status) == STATUS_ERROR;
+
+ if ($status == STATUS_ENDSTREAM) {
+ *$self->{Uncomp}->reset();
+ $self->pushBack($b) ;
+ last;
+ }
+ }
+
+ # skip the trailer
+ $self->smartReadExact(\$buffer, $hdr->{TrailerLength})
+ or return $self->saveErrorString(undef, "Truncated file");
+ }
+ else {
+ my $c = $hdr->{CompressedLength}->get64bit();
+ $self->fastForward($c)
+ or return $self->saveErrorString(undef, "Truncated file");
+ $buffer = '';
+ }
+
+ $self->chkTrailer($buffer) == STATUS_OK
+ or return $self->saveErrorString(undef, "Truncated file");
+
+ $hdr = $self->_readFullZipHeader();
+
+ return $self->saveErrorString(undef, "Cannot find '$name'")
+ if $self->smartEof();
+ }
+
+ return undef;
+}
+
+sub chkTrailer
+{
+ my $self = shift;
+ my $trailer = shift;
+
+ my ($sig, $CRC32, $cSize, $uSize) ;
+ my ($cSizeHi, $uSizeHi) = (0, 0);
+ if (*$self->{ZipData}{Streaming}) {
+ $sig = unpack ("V", substr($trailer, 0, 4));
+ $CRC32 = unpack ("V", substr($trailer, 4, 4));
+
+ if (*$self->{ZipData}{Zip64} ) {
+ $cSize = U64::newUnpack_V64 substr($trailer, 8, 8);
+ $uSize = U64::newUnpack_V64 substr($trailer, 16, 8);
+ }
+ else {
+ $cSize = U64::newUnpack_V32 substr($trailer, 8, 4);
+ $uSize = U64::newUnpack_V32 substr($trailer, 12, 4);
+ }
+
+ return $self->TrailerError("Data Descriptor signature, got $sig")
+ if $sig != ZIP_DATA_HDR_SIG;
+ }
+ else {
+ ($CRC32, $cSize, $uSize) =
+ (*$self->{ZipData}{Crc32},
+ *$self->{ZipData}{CompressedLen},
+ *$self->{ZipData}{UnCompressedLen});
+ }
+
+ *$self->{Info}{CRC32} = *$self->{ZipData}{CRC32} ;
+ *$self->{Info}{CompressedLength} = $cSize->get64bit();
+ *$self->{Info}{UncompressedLength} = $uSize->get64bit();
+
+ if (*$self->{Strict}) {
+ return $self->TrailerError("CRC mismatch")
+ if $CRC32 != *$self->{ZipData}{CRC32} ;
+
+ return $self->TrailerError("CSIZE mismatch.")
+ if ! $cSize->equal(*$self->{CompSize});
+
+ return $self->TrailerError("USIZE mismatch.")
+ if ! $uSize->equal(*$self->{UnCompSize});
+ }
+
+ my $reachedEnd = STATUS_ERROR ;
+ # check for central directory or end of central directory
+ while (1)
+ {
+ my $magic ;
+ my $got = $self->smartRead(\$magic, 4);
+
+ return $self->saveErrorString(STATUS_ERROR, "Truncated file")
+ if $got != 4 && *$self->{Strict};
+
+ if ($got == 0) {
+ return STATUS_EOF ;
+ }
+ elsif ($got < 0) {
+ return STATUS_ERROR ;
+ }
+ elsif ($got < 4) {
+ $self->pushBack($magic) ;
+ return STATUS_OK ;
+ }
+
+ my $sig = unpack("V", $magic) ;
+
+ my $hdr;
+ if ($hdr = $headerLookup{$sig})
+ {
+ if (&$hdr($self, $magic) != STATUS_OK ) {
+ if (*$self->{Strict}) {
+ return STATUS_ERROR ;
+ }
+ else {
+ $self->clearError();
+ return STATUS_OK ;
+ }
+ }
+
+ if ($sig == ZIP_END_CENTRAL_HDR_SIG)
+ {
+ return STATUS_OK ;
+ last;
+ }
+ }
+ elsif ($sig == ZIP_LOCAL_HDR_SIG)
+ {
+ $self->pushBack($magic) ;
+ return STATUS_OK ;
+ }
+ else
+ {
+ # put the data back
+ $self->pushBack($magic) ;
+ last;
+ }
+ }
+
+ return $reachedEnd ;
+}
+
+sub skipCentralDirectory
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ my $buffer;
+ $self->smartReadExact(\$buffer, 46 - 4)
+ or return $self->TrailerError("Minimum header size is " .
+ 46 . " bytes") ;
+
+ my $keep = $magic . $buffer ;
+ *$self->{HeaderPending} = $keep ;
+
+ #my $versionMadeBy = unpack ("v", substr($buffer, 4-4, 2));
+ #my $extractVersion = unpack ("v", substr($buffer, 6-4, 2));
+ #my $gpFlag = unpack ("v", substr($buffer, 8-4, 2));
+ #my $compressedMethod = unpack ("v", substr($buffer, 10-4, 2));
+ #my $lastModTime = unpack ("V", substr($buffer, 12-4, 4));
+ #my $crc32 = unpack ("V", substr($buffer, 16-4, 4));
+ my $compressedLength = unpack ("V", substr($buffer, 20-4, 4));
+ my $uncompressedLength = unpack ("V", substr($buffer, 24-4, 4));
+ my $filename_length = unpack ("v", substr($buffer, 28-4, 2));
+ my $extra_length = unpack ("v", substr($buffer, 30-4, 2));
+ my $comment_length = unpack ("v", substr($buffer, 32-4, 2));
+ #my $disk_start = unpack ("v", substr($buffer, 34-4, 2));
+ #my $int_file_attrib = unpack ("v", substr($buffer, 36-4, 2));
+ #my $ext_file_attrib = unpack ("V", substr($buffer, 38-4, 2));
+ #my $lcl_hdr_offset = unpack ("V", substr($buffer, 42-4, 2));
+
+
+ my $filename;
+ my $extraField;
+ my $comment ;
+ if ($filename_length)
+ {
+ $self->smartReadExact(\$filename, $filename_length)
+ or return $self->TruncatedTrailer("filename");
+ $keep .= $filename ;
+ }
+
+ if ($extra_length)
+ {
+ $self->smartReadExact(\$extraField, $extra_length)
+ or return $self->TruncatedTrailer("extra");
+ $keep .= $extraField ;
+ }
+
+ if ($comment_length)
+ {
+ $self->smartReadExact(\$comment, $comment_length)
+ or return $self->TruncatedTrailer("comment");
+ $keep .= $comment ;
+ }
+
+ return STATUS_OK ;
+}
+
+sub skipArchiveExtra
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ my $buffer;
+ $self->smartReadExact(\$buffer, 4)
+ or return $self->TrailerError("Minimum header size is " .
+ 4 . " bytes") ;
+
+ my $keep = $magic . $buffer ;
+
+ my $size = unpack ("V", $buffer);
+
+ $self->smartReadExact(\$buffer, $size)
+ or return $self->TrailerError("Minimum header size is " .
+ $size . " bytes") ;
+
+ $keep .= $buffer ;
+ *$self->{HeaderPending} = $keep ;
+
+ return STATUS_OK ;
+}
+
+
+sub skipCentralDirectory64Rec
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ my $buffer;
+ $self->smartReadExact(\$buffer, 8)
+ or return $self->TrailerError("Minimum header size is " .
+ 8 . " bytes") ;
+
+ my $keep = $magic . $buffer ;
+
+ my ($sizeLo, $sizeHi) = unpack ("V V", $buffer);
+ my $size = $sizeHi * 0xFFFFFFFF + $sizeLo;
+
+ $self->fastForward($size)
+ or return $self->TrailerError("Minimum header size is " .
+ $size . " bytes") ;
+
+ #$keep .= $buffer ;
+ #*$self->{HeaderPending} = $keep ;
+
+ #my $versionMadeBy = unpack ("v", substr($buffer, 0, 2));
+ #my $extractVersion = unpack ("v", substr($buffer, 2, 2));
+ #my $diskNumber = unpack ("V", substr($buffer, 4, 4));
+ #my $cntrlDirDiskNo = unpack ("V", substr($buffer, 8, 4));
+ #my $entriesInThisCD = unpack ("V V", substr($buffer, 12, 8));
+ #my $entriesInCD = unpack ("V V", substr($buffer, 20, 8));
+ #my $sizeOfCD = unpack ("V V", substr($buffer, 28, 8));
+ #my $offsetToCD = unpack ("V V", substr($buffer, 36, 8));
+
+ return STATUS_OK ;
+}
+
+sub skipCentralDirectory64Loc
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ my $buffer;
+ $self->smartReadExact(\$buffer, 20 - 4)
+ or return $self->TrailerError("Minimum header size is " .
+ 20 . " bytes") ;
+
+ my $keep = $magic . $buffer ;
+ *$self->{HeaderPending} = $keep ;
+
+ #my $startCdDisk = unpack ("V", substr($buffer, 4-4, 4));
+ #my $offsetToCD = unpack ("V V", substr($buffer, 8-4, 8));
+ #my $diskCount = unpack ("V", substr($buffer, 16-4, 4));
+
+ return STATUS_OK ;
+}
+
+sub skipEndCentralDirectory
+{
+ my $self = shift;
+ my $magic = shift ;
+
+ my $buffer;
+ $self->smartReadExact(\$buffer, 22 - 4)
+ or return $self->TrailerError("Minimum header size is " .
+ 22 . " bytes") ;
+
+ my $keep = $magic . $buffer ;
+ *$self->{HeaderPending} = $keep ;
+
+ #my $diskNumber = unpack ("v", substr($buffer, 4-4, 2));
+ #my $cntrlDirDiskNo = unpack ("v", substr($buffer, 6-4, 2));
+ #my $entriesInThisCD = unpack ("v", substr($buffer, 8-4, 2));
+ #my $entriesInCD = unpack ("v", substr($buffer, 10-4, 2));
+ #my $sizeOfCD = unpack ("V", substr($buffer, 12-4, 2));
+ #my $offsetToCD = unpack ("V", substr($buffer, 16-4, 2));
+ my $comment_length = unpack ("v", substr($buffer, 20-4, 2));
+
+
+ my $comment ;
+ if ($comment_length)
+ {
+ $self->smartReadExact(\$comment, $comment_length)
+ or return $self->TruncatedTrailer("comment");
+ $keep .= $comment ;
+ }
+
+ return STATUS_OK ;
+}
+
+
+sub _isZipMagic
+{
+ my $buffer = shift ;
+ return 0 if length $buffer < 4 ;
+ my $sig = unpack("V", $buffer) ;
+ return $sig == ZIP_LOCAL_HDR_SIG ;
+}
+
+
+sub _readFullZipHeader($)
+{
+ my ($self) = @_ ;
+ my $magic = '' ;
+
+ $self->smartReadExact(\$magic, 4);
+
+ *$self->{HeaderPending} = $magic ;
+
+ return $self->HeaderError("Minimum header size is " .
+ 30 . " bytes")
+ if length $magic != 4 ;
+
+
+ return $self->HeaderError("Bad Magic")
+ if ! _isZipMagic($magic) ;
+
+ my $status = $self->_readZipHeader($magic);
+ delete *$self->{Transparent} if ! defined $status ;
+ return $status ;
+}
+
+sub _readZipHeader($)
+{
+ my ($self, $magic) = @_ ;
+ my ($HeaderCRC) ;
+ my ($buffer) = '' ;
+
+ $self->smartReadExact(\$buffer, 30 - 4)
+ or return $self->HeaderError("Minimum header size is " .
+ 30 . " bytes") ;
+
+ my $keep = $magic . $buffer ;
+ *$self->{HeaderPending} = $keep ;
+
+ my $extractVersion = unpack ("v", substr($buffer, 4-4, 2));
+ my $gpFlag = unpack ("v", substr($buffer, 6-4, 2));
+ my $compressedMethod = unpack ("v", substr($buffer, 8-4, 2));
+ my $lastModTime = unpack ("V", substr($buffer, 10-4, 4));
+ my $crc32 = unpack ("V", substr($buffer, 14-4, 4));
+ my $compressedLength = U64::newUnpack_V32 substr($buffer, 18-4, 4);
+ my $uncompressedLength = U64::newUnpack_V32 substr($buffer, 22-4, 4);
+ my $filename_length = unpack ("v", substr($buffer, 26-4, 2));
+ my $extra_length = unpack ("v", substr($buffer, 28-4, 2));
+
+ my $filename;
+ my $extraField;
+ my @EXTRA = ();
+ my $streamingMode = ($gpFlag & ZIP_GP_FLAG_STREAMING_MASK) ? 1 : 0 ;
+
+ return $self->HeaderError("Streamed Stored content not supported")
+ if $streamingMode && $compressedMethod == 0 ;
+
+ return $self->HeaderError("Encrypted content not supported")
+ if $gpFlag & (ZIP_GP_FLAG_ENCRYPTED_MASK|ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK);
+
+ return $self->HeaderError("Patch content not supported")
+ if $gpFlag & ZIP_GP_FLAG_PATCHED_MASK;
+
+ *$self->{ZipData}{Streaming} = $streamingMode;
+
+
+ if ($filename_length)
+ {
+ $self->smartReadExact(\$filename, $filename_length)
+ or return $self->TruncatedHeader("Filename");
+ $keep .= $filename ;
+ }
+
+ my $zip64 = 0 ;
+
+ if ($extra_length)
+ {
+ $self->smartReadExact(\$extraField, $extra_length)
+ or return $self->TruncatedHeader("Extra Field");
+
+ my $bad = IO::Compress::Zlib::Extra::parseRawExtra($extraField,
+ \@EXTRA, 1, 0);
+ return $self->HeaderError($bad)
+ if defined $bad;
+
+ $keep .= $extraField ;
+
+ my %Extra ;
+ for (@EXTRA)
+ {
+ $Extra{$_->[0]} = \$_->[1];
+ }
+
+ if (defined $Extra{ZIP_EXTRA_ID_ZIP64()})
+ {
+ $zip64 = 1 ;
+
+ my $buff = ${ $Extra{ZIP_EXTRA_ID_ZIP64()} };
+
+ # This code assumes that all the fields in the Zip64
+ # extra field aren't necessarily present. The spec says that
+ # they only exist if the equivalent local headers are -1.
+
+ if (! $streamingMode) {
+ my $offset = 0 ;
+
+ if ($uncompressedLength->get32bit() == 0xFFFFFFFF ) {
+ $uncompressedLength
+ = U64::newUnpack_V64 substr($buff, 0, 8);
+
+ $offset += 8 ;
+ }
+
+ if ($compressedLength->get32bit() == 0xFFFFFFFF) {
+
+ $compressedLength
+ = U64::newUnpack_V64 substr($buff, $offset, 8);
+
+ $offset += 8 ;
+ }
+ }
+ }
+ }
+
+ *$self->{ZipData}{Zip64} = $zip64;
+
+ if (! $streamingMode) {
+ *$self->{ZipData}{Streaming} = 0;
+ *$self->{ZipData}{Crc32} = $crc32;
+ *$self->{ZipData}{CompressedLen} = $compressedLength;
+ *$self->{ZipData}{UnCompressedLen} = $uncompressedLength;
+ *$self->{CompressedInputLengthRemaining} =
+ *$self->{CompressedInputLength} = $compressedLength->get64bit();
+ }
+
+ *$self->{ZipData}{CRC32} = crc32(undef);
+ *$self->{ZipData}{Method} = $compressedMethod;
+ if ($compressedMethod == ZIP_CM_DEFLATE)
+ {
+ *$self->{Type} = 'zip-deflate';
+ my $obj = IO::Uncompress::Adapter::Inflate::mkUncompObject(1,0,0);
+
+ *$self->{Uncomp} = $obj;
+ }
+ elsif ($compressedMethod == ZIP_CM_BZIP2)
+ {
+ return $self->HeaderError("Unsupported Compression format $compressedMethod")
+ if ! defined $IO::Uncompress::Adapter::Bunzip2::VERSION ;
+
+ *$self->{Type} = 'zip-bzip2';
+
+ my $obj = IO::Uncompress::Adapter::Bunzip2::mkUncompObject();
+
+ *$self->{Uncomp} = $obj;
+ }
+# elsif ($compressedMethod == ZIP_CM_LZMA)
+# {
+# return $self->HeaderError("Unsupported Compression format $compressedMethod")
+# if ! defined $IO::Uncompress::Adapter::UnLzma::VERSION ;
+#
+# *$self->{Type} = 'zip-lzma';
+# my $LzmaHeader;
+# $self->smartReadExact(\$LzmaHeader, 4)
+# or return $self->saveErrorString(undef, "Truncated file");
+# my ($verHi, $verLo) = unpack ("CC", substr($LzmaHeader, 0, 2));
+# my $LzmaPropertiesSize = unpack ("v", substr($LzmaHeader, 2, 2));
+#
+#
+# my $LzmaPropertyData;
+# $self->smartReadExact(\$LzmaPropertyData, $LzmaPropertiesSize)
+# or return $self->saveErrorString(undef, "Truncated file");
+# #my $LzmaInfo = unpack ("C", substr($LzmaPropertyData, 0, 1));
+# #my $LzmaDictSize = unpack ("V", substr($LzmaPropertyData, 1, 4));
+#
+# # Create an LZMA_Alone header
+# $self->pushBack($LzmaPropertyData .
+# $uncompressedLength->getPacked_V64());
+#
+# my $obj =
+# IO::Uncompress::Adapter::UnLzma::mkUncompObject();
+#
+# *$self->{Uncomp} = $obj;
+# }
+ elsif ($compressedMethod == ZIP_CM_STORE)
+ {
+ # TODO -- add support for reading uncompressed
+
+ *$self->{Type} = 'zip-stored';
+
+ my $obj = IO::Uncompress::Adapter::Identity::mkUncompObject();
+
+ *$self->{Uncomp} = $obj;
+ }
+ else
+ {
+ return $self->HeaderError("Unsupported Compression format $compressedMethod");
+ }
+
+ return {
+ 'Type' => 'zip',
+ 'FingerprintLength' => 4,
+ #'HeaderLength' => $compressedMethod == 8 ? length $keep : 0,
+ 'HeaderLength' => length $keep,
+ 'Zip64' => $zip64,
+ 'TrailerLength' => ! $streamingMode ? 0 : $zip64 ? 24 : 16,
+ 'Header' => $keep,
+ 'CompressedLength' => $compressedLength ,
+ 'UncompressedLength' => $uncompressedLength ,
+ 'CRC32' => $crc32 ,
+ 'Name' => $filename,
+ 'Time' => _dosToUnixTime($lastModTime),
+ 'Stream' => $streamingMode,
+
+ 'MethodID' => $compressedMethod,
+ 'MethodName' => $compressedMethod == ZIP_CM_DEFLATE
+ ? "Deflated"
+ : $compressedMethod == ZIP_CM_BZIP2
+ ? "Bzip2"
+ : $compressedMethod == ZIP_CM_LZMA
+ ? "Lzma"
+ : $compressedMethod == ZIP_CM_STORE
+ ? "Stored"
+ : "Unknown" ,
+
+# 'TextFlag' => $flag & GZIP_FLG_FTEXT ? 1 : 0,
+# 'HeaderCRCFlag' => $flag & GZIP_FLG_FHCRC ? 1 : 0,
+# 'NameFlag' => $flag & GZIP_FLG_FNAME ? 1 : 0,
+# 'CommentFlag' => $flag & GZIP_FLG_FCOMMENT ? 1 : 0,
+# 'ExtraFlag' => $flag & GZIP_FLG_FEXTRA ? 1 : 0,
+# 'Comment' => $comment,
+# 'OsID' => $os,
+# 'OsName' => defined $GZIP_OS_Names{$os}
+# ? $GZIP_OS_Names{$os} : "Unknown",
+# 'HeaderCRC' => $HeaderCRC,
+# 'Flags' => $flag,
+# 'ExtraFlags' => $xfl,
+ 'ExtraFieldRaw' => $extraField,
+ 'ExtraField' => [ @EXTRA ],
+
+
+ }
+}
+
+sub filterUncompressed
+{
+ my $self = shift ;
+
+ if (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) {
+ *$self->{ZipData}{CRC32} = *$self->{Uncomp}->crc32() ;
+ }
+ else {
+ *$self->{ZipData}{CRC32} = crc32(${$_[0]}, *$self->{ZipData}{CRC32});
+ }
+}
+
+
+# from Archive::Zip & info-zip
+sub _dosToUnixTime
+{
+ my $dt = shift;
+
+ my $year = ( ( $dt >> 25 ) & 0x7f ) + 80;
+ my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1;
+ my $mday = ( ( $dt >> 16 ) & 0x1f );
+
+ my $hour = ( ( $dt >> 11 ) & 0x1f );
+ my $min = ( ( $dt >> 5 ) & 0x3f );
+ my $sec = ( ( $dt << 1 ) & 0x3e );
+
+
+ use POSIX 'mktime';
+
+ my $time_t = mktime( $sec, $min, $hour, $mday, $mon, $year, 0, 0, -1 );
+ return 0 if ! defined $time_t;
+ return $time_t;
+}
+
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+IO::Uncompress::Unzip - Read zip files/buffers
+
+=head1 SYNOPSIS
+
+ use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
+
+ my $status = unzip $input => $output [,OPTS]
+ or die "unzip failed: $UnzipError\n";
+
+ my $z = new IO::Uncompress::Unzip $input [OPTS]
+ or die "unzip failed: $UnzipError\n";
+
+ $status = $z->read($buffer)
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+ $line = $z->getline()
+ $char = $z->getc()
+ $char = $z->ungetc()
+ $char = $z->opened()
+
+ $status = $z->inflateSync()
+
+ $data = $z->trailingData()
+ $status = $z->nextStream()
+ $data = $z->getHeaderInfo()
+ $z->tell()
+ $z->seek($position, $whence)
+ $z->binmode()
+ $z->fileno()
+ $z->eof()
+ $z->close()
+
+ $UnzipError ;
+
+ # IO::File mode
+
+ <$z>
+ read($z, $buffer);
+ read($z, $buffer, $length);
+ read($z, $buffer, $length, $offset);
+ tell($z)
+ seek($z, $position, $whence)
+ binmode($z)
+ fileno($z)
+ eof($z)
+ close($z)
+
+=head1 DESCRIPTION
+
+This module provides a Perl interface that allows the reading of
+zlib files/buffers.
+
+For writing zip files/buffers, see the companion module IO::Compress::Zip.
+
+=head1 Functional Interface
+
+A top-level function, C<unzip>, is provided to carry out
+"one-shot" uncompression between buffers and/or files. For finer
+control over the uncompression process, see the L</"OO Interface">
+section.
+
+ use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
+
+ unzip $input => $output [,OPTS]
+ or die "unzip failed: $UnzipError\n";
+
+The functional interface needs Perl5.005 or better.
+
+=head2 unzip $input => $output [, OPTS]
+
+C<unzip> expects at least two parameters, C<$input> and C<$output>.
+
+=head3 The C<$input> parameter
+
+The parameter, C<$input>, is used to define the source of
+the compressed data.
+
+It can take one of the following forms:
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
+
+=item An array reference
+
+If C<$input> is an array reference, each element in the array must be a
+filename.
+
+The input data will be read from each file in turn.
+
+The complete array will be walked to ensure that it only
+contains valid filenames before any data is uncompressed.
+
+=item An Input FileGlob string
+
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<unzip> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
+
+See L<File::GlobMapper|File::GlobMapper> for more details.
+
+=back
+
+If the C<$input> parameter is any other type, C<undef> will be returned.
+
+=head3 The C<$output> parameter
+
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
+
+=over 5
+
+=item A filename
+
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
+
+=item A filehandle
+
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
+
+=item A scalar reference
+
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
+
+=item An Array Reference
+
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
+
+=item An Output FileGlob
+
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<unzip> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
+
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
+
+=back
+
+If the C<$output> parameter is any other type, C<undef> will be returned.
+
+=head2 Notes
+
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
+concatenation of all the uncompressed data from each of the input
+files/buffers.
+
+=head2 Optional Parameters
+
+Unless specified below, the optional parameters for C<unzip>,
+C<OPTS>, are the same as those used with the OO interface defined in the
+L</"Constructor Options"> section below.
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option applies to any input or output data streams to
+C<unzip> that are filehandles.
+
+If C<AutoClose> is specified, and the value is true, it will result in all
+input and/or output filehandles being closed once C<unzip> has
+completed.
+
+This parameter defaults to 0.
+
+=item C<< BinModeOut => 0|1 >>
+
+When writing to a file or filehandle, set C<binmode> before writing to the
+file.
+
+Defaults to 0.
+
+=item C<< Append => 0|1 >>
+
+The behaviour of this option is dependent on the type of output data
+stream.
+
+=over 5
+
+=item * A Buffer
+
+If C<Append> is enabled, all uncompressed data will be append to the end of
+the output buffer. Otherwise the output buffer will be cleared before any
+uncompressed data is written to it.
+
+=item * A Filename
+
+If C<Append> is enabled, the file will be opened in append mode. Otherwise
+the contents of the file, if any, will be truncated before any uncompressed
+data is written to it.
+
+=item * A Filehandle
+
+If C<Append> is enabled, the filehandle will be positioned to the end of
+the file via a call to C<seek> before any uncompressed data is
+written to it. Otherwise the file pointer will not be moved.
+
+=back
+
+When C<Append> is specified, and set to true, it will I<append> all uncompressed
+data to the output data stream.
+
+So when the output is a filehandle it will carry out a seek to the eof
+before writing any uncompressed data. If the output is a filename, it will be opened for
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
+
+Conversely when C<Append> is not specified, or it is present and is set to
+false, it will operate as follows.
+
+When the output is a filename, it will truncate the contents of the file
+before writing any uncompressed data. If the output is a filehandle
+its position will not be changed. If the output is a buffer, it will be
+wiped before any uncompressed data is output.
+
+Defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+If the input file/buffer contains multiple compressed data streams, this
+option will uncompress the whole lot as a single data stream.
+
+Defaults to 0.
+
+=item C<< TrailingData => $scalar >>
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option.
+
+=back
+
+=head2 Examples
+
+To read the contents of the file C<file1.txt.zip> and write the
+uncompressed data to the file C<file1.txt>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
+
+ my $input = "file1.txt.zip";
+ my $output = "file1.txt";
+ unzip $input => $output
+ or die "unzip failed: $UnzipError\n";
+
+To read from an existing Perl filehandle, C<$input>, and write the
+uncompressed data to a buffer, C<$buffer>.
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
+ use IO::File ;
+
+ my $input = new IO::File "<file1.txt.zip"
+ or die "Cannot open 'file1.txt.zip': $!\n" ;
+ my $buffer ;
+ unzip $input => \$buffer
+ or die "unzip failed: $UnzipError\n";
+
+To uncompress all files in the directory "/my/home" that match "*.txt.zip" and store the compressed data in the same directory
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
+
+ unzip '</my/home/*.txt.zip>' => '</my/home/#1.txt>'
+ or die "unzip failed: $UnzipError\n";
+
+and if you want to compress each file one at a time, this will do the trick
+
+ use strict ;
+ use warnings ;
+ use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
+
+ for my $input ( glob "/my/home/*.txt.zip" )
+ {
+ my $output = $input;
+ $output =~ s/.zip// ;
+ unzip $input => $output
+ or die "Error compressing '$input': $UnzipError\n";
+ }
+
+=head1 OO Interface
+
+=head2 Constructor
+
+The format of the constructor for IO::Uncompress::Unzip is shown below
+
+ my $z = new IO::Uncompress::Unzip $input [OPTS]
+ or die "IO::Uncompress::Unzip failed: $UnzipError\n";
+
+Returns an C<IO::Uncompress::Unzip> object on success and undef on failure.
+The variable C<$UnzipError> will contain an error message on failure.
+
+If you are running Perl 5.005 or better the object, C<$z>, returned from
+IO::Uncompress::Unzip can be used exactly like an L<IO::File|IO::File> filehandle.
+This means that all normal input file operations can be carried out with
+C<$z>. For example, to read a line from a compressed file/buffer you can
+use either of these forms
+
+ $line = $z->getline();
+ $line = <$z>;
+
+The mandatory parameter C<$input> is used to determine the source of the
+compressed data. This parameter can take one of three forms.
+
+=over 5
+
+=item A filename
+
+If the C<$input> parameter is a scalar, it is assumed to be a filename. This
+file will be opened for reading and the compressed data will be read from it.
+
+=item A filehandle
+
+If the C<$input> parameter is a filehandle, the compressed data will be
+read from it.
+The string '-' can be used as an alias for standard input.
+
+=item A scalar reference
+
+If C<$input> is a scalar reference, the compressed data will be read from
+C<$$output>.
+
+=back
+
+=head2 Constructor Options
+
+The option names defined below are case insensitive and can be optionally
+prefixed by a '-'. So all of the following are valid
+
+ -AutoClose
+ -autoclose
+ AUTOCLOSE
+ autoclose
+
+OPTS is a combination of the following options:
+
+=over 5
+
+=item C<< AutoClose => 0|1 >>
+
+This option is only valid when the C<$input> parameter is a filehandle. If
+specified, and the value is true, it will result in the file being closed once
+either the C<close> method is called or the IO::Uncompress::Unzip object is
+destroyed.
+
+This parameter defaults to 0.
+
+=item C<< MultiStream => 0|1 >>
+
+Treats the complete zip file/buffer as a single compressed data
+stream. When reading in multi-stream mode each member of the zip
+file/buffer will be uncompressed in turn until the end of the file/buffer
+is encountered.
+
+This parameter defaults to 0.
+
+=item C<< Prime => $string >>
+
+This option will uncompress the contents of C<$string> before processing the
+input file/buffer.
+
+This option can be useful when the compressed data is embedded in another
+file/data structure and it is not possible to work out where the compressed
+data begins without having to read the first few bytes. If this is the
+case, the uncompression can be I<primed> with these bytes using this
+option.
+
+=item C<< Transparent => 0|1 >>
+
+If this option is set and the input file/buffer is not compressed data,
+the module will allow reading of it anyway.
+
+In addition, if the input file/buffer does contain compressed data and
+there is non-compressed data immediately following it, setting this option
+will make this module treat the whole file/bufffer as a single data stream.
+
+This option defaults to 1.
+
+=item C<< BlockSize => $num >>
+
+When reading the compressed input data, IO::Uncompress::Unzip will read it in
+blocks of C<$num> bytes.
+
+This option defaults to 4096.
+
+=item C<< InputLength => $size >>
+
+When present this option will limit the number of compressed bytes read
+from the input file/buffer to C<$size>. This option can be used in the
+situation where there is useful data directly after the compressed data
+stream and you know beforehand the exact length of the compressed data
+stream.
+
+This option is mostly used when reading from a filehandle, in which case
+the file pointer will be left pointing to the first byte directly after the
+compressed data stream.
+
+This option defaults to off.
+
+=item C<< Append => 0|1 >>
+
+This option controls what the C<read> method does with uncompressed data.
+
+If set to 1, all uncompressed data will be appended to the output parameter
+of the C<read> method.
+
+If set to 0, the contents of the output parameter of the C<read> method
+will be overwritten by the uncompressed data.
+
+Defaults to 0.
+
+=item C<< Strict => 0|1 >>
+
+This option controls whether the extra checks defined below are used when
+carrying out the decompression. When Strict is on, the extra tests are
+carried out, when Strict is off they are not.
+
+The default for this option is off.
+
+=back
+
+=head2 Examples
+
+TODO
+
+=head1 Methods
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer)
+
+Reads a block of compressed data (the size the the compressed block is
+determined by the C<Buffer> option in the constructor), uncompresses it and
+writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
+set in the constructor, the uncompressed data will be appended to the
+C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 read
+
+Usage is
+
+ $status = $z->read($buffer, $length)
+ $status = $z->read($buffer, $length, $offset)
+
+ $status = read($z, $buffer, $length)
+ $status = read($z, $buffer, $length, $offset)
+
+Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
+
+The main difference between this form of the C<read> method and the
+previous one, is that this one will attempt to return I<exactly> C<$length>
+bytes. The only circumstances that this function will not is if end-of-file
+or an IO error is encountered.
+
+Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
+or a negative number on error.
+
+=head2 getline
+
+Usage is
+
+ $line = $z->getline()
+ $line = <$z>
+
+Reads a single line.
+
+This method fully supports the use of of the variable C<$/> (or
+C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
+determine what constitutes an end of line. Paragraph mode, record mode and
+file slurp mode are all supported.
+
+=head2 getc
+
+Usage is
+
+ $char = $z->getc()
+
+Read a single character.
+
+=head2 ungetc
+
+Usage is
+
+ $char = $z->ungetc($string)
+
+=head2 inflateSync
+
+Usage is
+
+ $status = $z->inflateSync()
+
+TODO
+
+=head2 getHeaderInfo
+
+Usage is
+
+ $hdr = $z->getHeaderInfo();
+ @hdrs = $z->getHeaderInfo();
+
+This method returns either a hash reference (in scalar context) or a list
+or hash references (in array context) that contains information about each
+of the header fields in the compressed data stream(s).
+
+=head2 tell
+
+Usage is
+
+ $z->tell()
+ tell $z
+
+Returns the uncompressed file offset.
+
+=head2 eof
+
+Usage is
+
+ $z->eof();
+ eof($z);
+
+Returns true if the end of the compressed input stream has been reached.
+
+=head2 seek
+
+ $z->seek($position, $whence);
+ seek($z, $position, $whence);
+
+Provides a sub-set of the C<seek> functionality, with the restriction
+that it is only legal to seek forward in the input file/buffer.
+It is a fatal error to attempt to seek backward.
+
+The C<$whence> parameter takes one the usual values, namely SEEK_SET,
+SEEK_CUR or SEEK_END.
+
+Returns 1 on success, 0 on failure.
+
+=head2 binmode
+
+Usage is
+
+ $z->binmode
+ binmode $z ;
+
+This is a noop provided for completeness.
+
+=head2 opened
+
+ $z->opened()
+
+Returns true if the object currently refers to a opened file/buffer.
+
+=head2 autoflush
+
+ my $prev = $z->autoflush()
+ my $prev = $z->autoflush(EXPR)
+
+If the C<$z> object is associated with a file or a filehandle, this method
+returns the current autoflush setting for the underlying filehandle. If
+C<EXPR> is present, and is non-zero, it will enable flushing after every
+write/print operation.
+
+If C<$z> is associated with a buffer, this method has no effect and always
+returns C<undef>.
+
+B<Note> that the special variable C<$|> B<cannot> be used to set or
+retrieve the autoflush setting.
+
+=head2 input_line_number
+
+ $z->input_line_number()
+ $z->input_line_number(EXPR)
+
+Returns the current uncompressed line number. If C<EXPR> is present it has
+the effect of setting the line number. Note that setting the line number
+does not change the current position within the file/buffer being read.
+
+The contents of C<$/> are used to to determine what constitutes a line
+terminator.
+
+=head2 fileno
+
+ $z->fileno()
+ fileno($z)
+
+If the C<$z> object is associated with a file or a filehandle, C<fileno>
+will return the underlying file descriptor. Once the C<close> method is
+called C<fileno> will return C<undef>.
+
+If the C<$z> object is is associated with a buffer, this method will return
+C<undef>.
+
+=head2 close
+
+ $z->close() ;
+ close $z ;
+
+Closes the output file/buffer.
+
+For most versions of Perl this method will be automatically invoked if
+the IO::Uncompress::Unzip object is destroyed (either explicitly or by the
+variable with the reference to the object going out of scope). The
+exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
+these cases, the C<close> method will be called automatically, but
+not until global destruction of all live objects when the program is
+terminating.
+
+Therefore, if you want your scripts to be able to run on all versions
+of Perl, you should call C<close> explicitly and not rely on automatic
+closing.
+
+Returns true on success, otherwise 0.
+
+If the C<AutoClose> option has been enabled when the IO::Uncompress::Unzip
+object was created, and the object is associated with a file, the
+underlying file will also be closed.
+
+=head2 nextStream
+
+Usage is
+
+ my $status = $z->nextStream();
+
+Skips to the next compressed data stream in the input file/buffer. If a new
+compressed data stream is found, the eof marker will be cleared and C<$.>
+will be reset to 0.
+
+Returns 1 if a new stream was found, 0 if none was found, and -1 if an
+error was encountered.
+
+=head2 trailingData
+
+Usage is
+
+ my $data = $z->trailingData();
+
+Returns the data, if any, that is present immediately after the compressed
+data stream once uncompression is complete. It only makes sense to call
+this method once the end of the compressed data stream has been
+encountered.
+
+This option can be used when there is useful information immediately
+following the compressed data stream, and you don't know the length of the
+compressed data stream.
+
+If the input is a buffer, C<trailingData> will return everything from the
+end of the compressed data stream to the end of the buffer.
+
+If the input is a filehandle, C<trailingData> will return the data that is
+left in the filehandle input buffer once the end of the compressed data
+stream has been reached. You can then use the filehandle to read the rest
+of the input file.
+
+Don't bother using C<trailingData> if the input is a filename.
+
+If you know the length of the compressed data stream before you start
+uncompressing, you can avoid having to use C<trailingData> by setting the
+C<InputLength> option in the constructor.
+
+=head1 Importing
+
+No symbolic constants are required by this IO::Uncompress::Unzip at present.
+
+=over 5
+
+=item :all
+
+Imports C<unzip> and C<$UnzipError>.
+Same as doing this
+
+ use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
+
+=back
+
+=head1 EXAMPLES
+
+=head2 Working with Net::FTP
+
+See L<IO::Uncompress::Unzip::FAQ|IO::Uncompress::Unzip::FAQ/"Compressed files and Net::FTP">
+
+=head1 SEE ALSO
+
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
+
+L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
+L<Archive::Tar|Archive::Tar>,
+L<IO::Zlib|IO::Zlib>
+
+For RFC 1950, 1951 and 1952 see
+F<http://www.faqs.org/rfcs/rfc1950.html>,
+F<http://www.faqs.org/rfcs/rfc1951.html> and
+F<http://www.faqs.org/rfcs/rfc1952.html>
+
+The I<zlib> compression library was written by Jean-loup Gailly
+F<gzip@prep.ai.mit.edu> and Mark Adler F<madler@alumni.caltech.edu>.
+
+The primary site for the I<zlib> compression library is
+F<http://www.zlib.org>.
+
+The primary site for gzip is F<http://www.gzip.org>.
+
+=head1 AUTHOR
+
+This module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 MODIFICATION HISTORY
+
+See the Changes file.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Wrap.pm b/Master/tlpkg/tlperl/lib/IO/Wrap.pm
new file mode 100755
index 00000000000..5a28392dd23
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Wrap.pm
@@ -0,0 +1,222 @@
+package IO::Wrap;
+
+# SEE DOCUMENTATION AT BOTTOM OF FILE
+
+require 5.002;
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+@ISA = qw(Exporter);
+@EXPORT = qw(wraphandle);
+
+use FileHandle;
+use Carp;
+
+# The package version, both in 1.23 style *and* usable by MakeMaker:
+$VERSION = "2.110";
+
+
+#------------------------------
+# wraphandle RAW
+#------------------------------
+sub wraphandle {
+ my $raw = shift;
+ new IO::Wrap $raw;
+}
+
+#------------------------------
+# new STREAM
+#------------------------------
+sub new {
+ my ($class, $stream) = @_;
+ no strict 'refs';
+
+ ### Convert raw scalar to globref:
+ ref($stream) or $stream = \*$stream;
+
+ ### Wrap globref and incomplete objects:
+ if ((ref($stream) eq 'GLOB') or ### globref
+ (ref($stream) eq 'FileHandle') && !defined(&FileHandle::read)) {
+ return bless \$stream, $class;
+ }
+ $stream; ### already okay!
+}
+
+#------------------------------
+# I/O methods...
+#------------------------------
+sub close {
+ my $self = shift;
+ return close($$self);
+}
+sub getline {
+ my $self = shift;
+ my $fh = $$self;
+ return scalar(<$fh>);
+}
+sub getlines {
+ my $self = shift;
+ wantarray or croak("Can't call getlines in scalar context!");
+ my $fh = $$self;
+ <$fh>;
+}
+sub print {
+ my $self = shift;
+ print { $$self } @_;
+}
+sub read {
+ my $self = shift;
+ return read($$self, $_[0], $_[1]);
+}
+sub seek {
+ my $self = shift;
+ return seek($$self, $_[0], $_[1]);
+}
+sub tell {
+ my $self = shift;
+ return tell($$self);
+}
+
+#------------------------------
+1;
+__END__
+
+
+=head1 NAME
+
+IO::Wrap - wrap raw filehandles in IO::Handle interface
+
+
+=head1 SYNOPSIS
+
+ use IO::Wrap;
+
+ ### Do stuff with any kind of filehandle (including a bare globref), or
+ ### any kind of blessed object that responds to a print() message.
+ ###
+ sub do_stuff {
+ my $fh = shift;
+
+ ### At this point, we have no idea what the user gave us...
+ ### a globref? a FileHandle? a scalar filehandle name?
+
+ $fh = wraphandle($fh);
+
+ ### At this point, we know we have an IO::Handle-like object!
+
+ $fh->print("Hey there!");
+ ...
+ }
+
+
+=head1 DESCRIPTION
+
+Let's say you want to write some code which does I/O, but you don't
+want to force the caller to provide you with a FileHandle or IO::Handle
+object. You want them to be able to say:
+
+ do_stuff(\*STDOUT);
+ do_stuff('STDERR');
+ do_stuff($some_FileHandle_object);
+ do_stuff($some_IO_Handle_object);
+
+And even:
+
+ do_stuff($any_object_with_a_print_method);
+
+Sure, one way to do it is to force the caller to use tiehandle().
+But that puts the burden on them. Another way to do it is to
+use B<IO::Wrap>, which provides you with the following functions:
+
+
+=over 4
+
+=item wraphandle SCALAR
+
+This function will take a single argument, and "wrap" it based on
+what it seems to be...
+
+=over 4
+
+=item *
+
+B<A raw scalar filehandle name,> like C<"STDOUT"> or C<"Class::HANDLE">.
+In this case, the filehandle name is wrapped in an IO::Wrap object,
+which is returned.
+
+=item *
+
+B<A raw filehandle glob,> like C<\*STDOUT>.
+In this case, the filehandle glob is wrapped in an IO::Wrap object,
+which is returned.
+
+=item *
+
+B<A blessed FileHandle object.>
+In this case, the FileHandle is wrapped in an IO::Wrap object if and only
+if your FileHandle class does not support the C<read()> method.
+
+=item *
+
+B<Any other kind of blessed object,> which is assumed to be already
+conformant to the IO::Handle interface.
+In this case, you just get back that object.
+
+=back
+
+=back
+
+
+If you get back an IO::Wrap object, it will obey a basic subset of
+the IO:: interface. That is, the following methods (note: I said
+I<methods>, not named operators) should work on the thing you get back:
+
+ close
+ getline
+ getlines
+ print ARGS...
+ read BUFFER,NBYTES
+ seek POS,WHENCE
+ tell
+
+
+
+=head1 NOTES
+
+Clearly, when wrapping a raw external filehandle (like \*STDOUT),
+I didn't want to close the file descriptor when the "wrapper" object is
+destroyed... since the user might not appreciate that! Hence,
+there's no DESTROY method in this class.
+
+When wrapping a FileHandle object, however, I believe that Perl will
+invoke the FileHandle::DESTROY when the last reference goes away,
+so in that case, the filehandle is closed if the wrapped FileHandle
+really was the last reference to it.
+
+
+=head1 WARNINGS
+
+This module does not allow you to wrap filehandle names which are given
+as strings that lack the package they were opened in. That is, if a user
+opens FOO in package Foo, they must pass it to you either as C<\*FOO>
+or as C<"Foo::FOO">. However, C<"STDIN"> and friends will work just fine.
+
+
+=head1 VERSION
+
+$Id: Wrap.pm,v 1.2 2005/02/10 21:21:53 dfs Exp $
+
+
+=head1 AUTHOR
+
+=item Primary Maintainer
+
+David F. Skoll (F<dfs@roaringpenguin.com>).
+
+=item Original Author
+
+Eryq (F<eryq@zeegee.com>).
+President, ZeeGee Software Inc (F<http://www.zeegee.com>).
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/IO/WrapTie.pm b/Master/tlpkg/tlperl/lib/IO/WrapTie.pm
new file mode 100755
index 00000000000..5e22508bbd9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/WrapTie.pm
@@ -0,0 +1,491 @@
+# SEE DOCUMENTATION AT BOTTOM OF FILE
+
+
+#------------------------------------------------------------
+package IO::WrapTie;
+#------------------------------------------------------------
+require 5.004; ### for tie
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+use Exporter;
+
+# Inheritance, exporting, and package version:
+@ISA = qw(Exporter);
+@EXPORT = qw(wraptie);
+$VERSION = "2.110";
+
+# Function, exported.
+sub wraptie {
+ IO::WrapTie::Master->new(@_);
+}
+
+# Class method; BACKWARDS-COMPATIBILITY ONLY!
+sub new {
+ shift;
+ IO::WrapTie::Master->new(@_);
+}
+
+
+
+#------------------------------------------------------------
+package IO::WrapTie::Master;
+#------------------------------------------------------------
+
+use strict;
+use vars qw(@ISA $AUTOLOAD);
+use IO::Handle;
+
+# We inherit from IO::Handle to get methods which invoke i/o operators,
+# like print(), on our tied handle:
+@ISA = qw(IO::Handle);
+
+#------------------------------
+# new SLAVE, TIEARGS...
+#------------------------------
+# Create a new subclass of IO::Handle which...
+#
+# (1) Handles i/o OPERATORS because it is tied to an instance of
+# an i/o-like class, like IO::Scalar.
+#
+# (2) Handles i/o METHODS by delegating them to that same tied object!.
+#
+# Arguments are the slave class (e.g., IO::Scalar), followed by all
+# the arguments normally sent into that class's TIEHANDLE method.
+# In other words, much like the arguments to tie(). :-)
+#
+# NOTE:
+# The thing $x we return must be a BLESSED REF, for ($x->print()).
+# The underlying symbol must be a FILEHANDLE, for (print $x "foo").
+# It has to have a way of getting to the "real" back-end object...
+#
+sub new {
+ my $master = shift;
+ my $io = IO::Handle->new; ### create a new handle
+ my $slave = shift;
+ tie *$io, $slave, @_; ### tie: will invoke slave's TIEHANDLE
+ bless $io, $master; ### return a master
+}
+
+#------------------------------
+# AUTOLOAD
+#------------------------------
+# Delegate method invocations on the master to the underlying slave.
+#
+sub AUTOLOAD {
+ my $method = $AUTOLOAD;
+ $method =~ s/.*:://;
+ my $self = shift; tied(*$self)->$method(\@_);
+}
+
+#------------------------------
+# PRELOAD
+#------------------------------
+# Utility.
+#
+# Most methods like print(), getline(), etc. which work on the tied object
+# via Perl's i/o operators (like 'print') are inherited from IO::Handle.
+#
+# Other methods, like seek() and sref(), we must delegate ourselves.
+# AUTOLOAD takes care of these.
+#
+# However, it may be necessary to preload delegators into your
+# own class. PRELOAD will do this.
+#
+sub PRELOAD {
+ my $class = shift;
+ foreach (@_) {
+ eval "sub ${class}::$_ { my \$s = shift; tied(*\$s)->$_(\@_) }";
+ }
+}
+
+# Preload delegators for some standard methods which we can't simply
+# inherit from IO::Handle... for example, some IO::Handle methods
+# assume that there is an underlying file descriptor.
+#
+PRELOAD IO::WrapTie::Master
+ qw(open opened close read clearerr eof seek tell setpos getpos);
+
+
+
+#------------------------------------------------------------
+package IO::WrapTie::Slave;
+#------------------------------------------------------------
+# Teeny private class providing a new_tie constructor...
+#
+# HOW IT ALL WORKS:
+#
+# Slaves inherit from this class.
+#
+# When you send a new_tie() message to a tie-slave class (like IO::Scalar),
+# it first determines what class should provide its master, via TIE_MASTER.
+# In this case, IO::Scalar->TIE_MASTER would return IO::Scalar::Master.
+# Then, we create a new master (an IO::Scalar::Master) with the same args
+# sent to new_tie.
+#
+# In general, the new() method of the master is inherited directly
+# from IO::WrapTie::Master.
+#
+sub new_tie {
+ my $self = shift;
+ $self->TIE_MASTER->new($self,@_); ### e.g., IO::Scalar::Master->new(@_)
+}
+
+# Default class method for new_tie().
+# All your tie-slave class (like IO::Scalar) has to do is override this
+# method with a method that returns the name of an appropriate "master"
+# class for tying that slave.
+#
+sub TIE_MASTER { 'IO::WrapTie::Master' }
+
+#------------------------------
+1;
+__END__
+
+
+package IO::WrapTie; ### for doc generator
+
+
+=head1 NAME
+
+IO::WrapTie - wrap tieable objects in IO::Handle interface
+
+I<This is currently Alpha code, released for comments.
+ Please give me your feedback!>
+
+
+=head1 SYNOPSIS
+
+First of all, you'll need tie(), so:
+
+ require 5.004;
+
+I<Function interface (experimental).>
+Use this with any existing class...
+
+ use IO::WrapTie;
+ use FooHandle; ### implements TIEHANDLE interface
+
+ ### Suppose we want a "FooHandle->new(&FOO_RDWR, 2)".
+ ### We can instead say...
+
+ $FH = wraptie('FooHandle', &FOO_RDWR, 2);
+
+ ### Now we can use...
+ print $FH "Hello, "; ### traditional operator syntax...
+ $FH->print("world!\n"); ### ...and OO syntax as well!
+
+I<OO interface (preferred).>
+You can inherit from the IO::WrapTie::Slave mixin to get a
+nifty C<new_tie()> constructor...
+
+ #------------------------------
+ package FooHandle; ### a class which can TIEHANDLE
+
+ use IO::WrapTie;
+ @ISA = qw(IO::WrapTie::Slave); ### inherit new_tie()
+ ...
+
+
+ #------------------------------
+ package main;
+
+ $FH = FooHandle->new_tie(&FOO_RDWR, 2); ### $FH is an IO::WrapTie::Master
+ print $FH "Hello, "; ### traditional operator syntax
+ $FH->print("world!\n"); ### OO syntax
+
+See IO::Scalar as an example. It also shows you how to create classes
+which work both with and without 5.004.
+
+
+=head1 DESCRIPTION
+
+Suppose you have a class C<FooHandle>, where...
+
+=over 4
+
+=item *
+
+B<FooHandle does not inherit from IO::Handle;> that is, it performs
+filehandle-like I/O, but to something other than an underlying
+file descriptor. Good examples are IO::Scalar (for printing to a
+string) and IO::Lines (for printing to an array of lines).
+
+=item *
+
+B<FooHandle implements the TIEHANDLE interface> (see L<perltie>);
+that is, it provides methods TIEHANDLE, GETC, PRINT, PRINTF,
+READ, and READLINE.
+
+=item *
+
+B<FooHandle implements the traditional OO interface> of
+FileHandle and IO::Handle; i.e., it contains methods like getline(),
+read(), print(), seek(), tell(), eof(), etc.
+
+=back
+
+
+Normally, users of your class would have two options:
+
+
+=over 4
+
+=item *
+
+B<Use only OO syntax,> and forsake named I/O operators like 'print'.
+
+=item *
+
+B<Use with tie,> and forsake treating it as a first-class object
+(i.e., class-specific methods can only be invoked through the underlying
+object via tied()... giving the object a "split personality").
+
+=back
+
+
+But now with IO::WrapTie, you can say:
+
+ $WT = wraptie('FooHandle', &FOO_RDWR, 2);
+ $WT->print("Hello, world\n"); ### OO syntax
+ print $WT "Yes!\n"; ### Named operator syntax too!
+ $WT->weird_stuff; ### Other methods!
+
+And if you're authoring a class like FooHandle, just have it inherit
+from C<IO::WrapTie::Slave> and that first line becomes even prettier:
+
+ $WT = FooHandle->new_tie(&FOO_RDWR, 2);
+
+B<The bottom line:> now, almost any class can look and work exactly like
+an IO::Handle... and be used both with OO and non-OO filehandle syntax.
+
+
+=head1 HOW IT ALL WORKS
+
+
+=head2 The data structures
+
+Consider this example code, using classes in this distribution:
+
+ use IO::Scalar;
+ use IO::WrapTie;
+
+ $WT = wraptie('IO::Scalar',\$s);
+ print $WT "Hello, ";
+ $WT->print("world!\n");
+
+In it, the wraptie() function creates a data structure as follows:
+
+ * $WT is a blessed reference to a tied filehandle
+ $WT glob; that glob is tied to the "Slave" object.
+ | * You would do all your i/o with $WT directly.
+ |
+ |
+ | ,---isa--> IO::WrapTie::Master >--isa--> IO::Handle
+ V /
+ .-------------.
+ | |
+ | | * Perl i/o operators work on the tied object,
+ | "Master" | invoking the TIEHANDLE methods.
+ | | * Method invocations are delegated to the tied
+ | | slave.
+ `-------------'
+ |
+ tied(*$WT) | .---isa--> IO::WrapTie::Slave
+ V /
+ .-------------.
+ | |
+ | "Slave" | * Instance of FileHandle-like class which doesn't
+ | | actually use file descriptors, like IO::Scalar.
+ | IO::Scalar | * The slave can be any kind of object.
+ | | * Must implement the TIEHANDLE interface.
+ `-------------'
+
+
+I<NOTE:> just as an IO::Handle is really just a blessed reference to a
+I<traditional> filehandle glob... so also, an IO::WrapTie::Master
+is really just a blessed reference to a filehandle
+glob I<which has been tied to some "slave" class.>
+
+
+=head2 How wraptie() works
+
+=over 4
+
+=item 1.
+
+The call to function C<wraptie(SLAVECLASS, TIEARGS...)> is
+passed onto C<IO::WrapTie::Master::new()>.
+Note that class IO::WrapTie::Master is a subclass of IO::Handle.
+
+=item 2.
+
+The C<IO::WrapTie::Master::new> method creates a new IO::Handle object,
+reblessed into class IO::WrapTie::Master. This object is the I<master>,
+which will be returned from the constructor. At the same time...
+
+=item 3.
+
+The C<new> method also creates the I<slave>: this is an instance
+of SLAVECLASS which is created by tying the master's IO::Handle
+to SLAVECLASS via C<tie(HANDLE, SLAVECLASS, TIEARGS...)>.
+This call to C<tie()> creates the slave in the following manner:
+
+=item 4.
+
+Class SLAVECLASS is sent the message C<TIEHANDLE(TIEARGS...)>; it
+will usually delegate this to C<SLAVECLASS::new(TIEARGS...)>, resulting
+in a new instance of SLAVECLASS being created and returned.
+
+=item 5.
+
+Once both master and slave have been created, the master is returned
+to the caller.
+
+=back
+
+
+=head2 How I/O operators work (on the master)
+
+Consider using an i/o operator on the master:
+
+ print $WT "Hello, world!\n";
+
+Since the master ($WT) is really a [blessed] reference to a glob,
+the normal Perl i/o operators like C<print> may be used on it.
+They will just operate on the symbol part of the glob.
+
+Since the glob is tied to the slave, the slave's PRINT method
+(part of the TIEHANDLE interface) will be automatically invoked.
+
+If the slave is an IO::Scalar, that means IO::Scalar::PRINT will be
+invoked, and that method happens to delegate to the C<print()> method
+of the same class. So the I<real> work is ultimately done by
+IO::Scalar::print().
+
+
+=head2 How methods work (on the master)
+
+Consider using a method on the master:
+
+ $WT->print("Hello, world!\n");
+
+Since the master ($WT) is blessed into the class IO::WrapTie::Master,
+Perl first attempts to find a C<print()> method there. Failing that,
+Perl next attempts to find a C<print()> method in the superclass,
+IO::Handle. It just so happens that there I<is> such a method;
+that method merely invokes the C<print> i/o operator on the self object...
+and for that, see above!
+
+But let's suppose we're dealing with a method which I<isn't> part
+of IO::Handle... for example:
+
+ my $sref = $WT->sref;
+
+In this case, the intuitive behavior is to have the master delegate the
+method invocation to the slave (now do you see where the designations
+come from?). This is indeed what happens: IO::WrapTie::Master contains
+an AUTOLOAD method which performs the delegation.
+
+So: when C<sref()> can't be found in IO::Handle, the AUTOLOAD method
+of IO::WrapTie::Master is invoked, and the standard behavior of
+delegating the method to the underlying slave (here, an IO::Scalar)
+is done.
+
+Sometimes, to get this to work properly, you may need to create
+a subclass of IO::WrapTie::Master which is an effective master for
+I<your> class, and do the delegation there.
+
+
+
+
+=head1 NOTES
+
+B<Why not simply use the object's OO interface?>
+ Because that means forsaking the use of named operators
+like print(), and you may need to pass the object to a subroutine
+which will attempt to use those operators:
+
+ $O = FooHandle->new(&FOO_RDWR, 2);
+ $O->print("Hello, world\n"); ### OO syntax is okay, BUT....
+
+ sub nope { print $_[0] "Nope!\n" }
+ X nope($O); ### ERROR!!! (not a glob ref)
+
+
+B<Why not simply use tie()?>
+ Because (1) you have to use tied() to invoke methods in the
+object's public interface (yuck), and (2) you may need to pass
+the tied symbol to another subroutine which will attempt to treat
+it in an OO-way... and that will break it:
+
+ tie *T, 'FooHandle', &FOO_RDWR, 2;
+ print T "Hello, world\n"; ### Operator is okay, BUT...
+
+ tied(*T)->other_stuff; ### yuck! AND...
+
+ sub nope { shift->print("Nope!\n") }
+ X nope(\*T); ### ERROR!!! (method "print" on unblessed ref)
+
+
+B<Why a master and slave?
+ Why not simply write FooHandle to inherit from IO::Handle?>
+ I tried this, with an implementation similar to that of IO::Socket.
+The problem is that I<the whole point is to use this with objects
+that don't have an underlying file/socket descriptor.>.
+Subclassing IO::Handle will work fine for the OO stuff, and fine with
+named operators I<if> you tie()... but if you just attempt to say:
+
+ $IO = FooHandle->new(&FOO_RDWR, 2);
+ print $IO "Hello!\n";
+
+you get a warning from Perl like:
+
+ Filehandle GEN001 never opened
+
+because it's trying to do system-level i/o on an (unopened) file
+descriptor. To avoid this, you apparently have to tie() the handle...
+which brings us right back to where we started! At least the
+IO::WrapTie mixin lets us say:
+
+ $IO = FooHandle->new_tie(&FOO_RDWR, 2);
+ print $IO "Hello!\n";
+
+and so is not I<too> bad. C<:-)>
+
+
+=head1 WARNINGS
+
+Remember: this stuff is for doing FileHandle-like i/o on things
+I<without underlying file descriptors>. If you have an underlying
+file descriptor, you're better off just inheriting from IO::Handle.
+
+B<Be aware that new_tie() always returns an instance of a
+kind of IO::WrapTie::Master...> it does B<not> return an instance
+of the i/o class you're tying to!
+
+Invoking some methods on the master object causes AUTOLOAD to delegate
+them to the slave object... so it I<looks> like you're manipulating a
+"FooHandle" object directly, but you're not.
+
+I have not explored all the ramifications of this use of tie().
+I<Here there be dragons>.
+
+
+=head1 VERSION
+
+$Id: WrapTie.pm,v 1.2 2005/02/10 21:21:53 dfs Exp $
+
+
+=head1 AUTHOR
+
+=item Primary Maintainer
+
+David F. Skoll (F<dfs@roaringpenguin.com>).
+
+=item Original Author
+
+Eryq (F<eryq@zeegee.com>).
+President, ZeeGee Software Inc (F<http://www.zeegee.com>).
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/IO/Zlib.pm b/Master/tlpkg/tlperl/lib/IO/Zlib.pm
new file mode 100755
index 00000000000..55534b4f374
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO/Zlib.pm
@@ -0,0 +1,652 @@
+# IO::Zlib.pm
+#
+# Copyright (c) 1998-2004 Tom Hughes <tom@compton.nu>.
+# All rights reserved. This program is free software; you can redistribute
+# it and/or modify it under the same terms as Perl itself.
+
+package IO::Zlib;
+
+$VERSION = "1.10";
+
+=head1 NAME
+
+IO::Zlib - IO:: style interface to L<Compress::Zlib>
+
+=head1 SYNOPSIS
+
+With any version of Perl 5 you can use the basic OO interface:
+
+ use IO::Zlib;
+
+ $fh = new IO::Zlib;
+ if ($fh->open("file.gz", "rb")) {
+ print <$fh>;
+ $fh->close;
+ }
+
+ $fh = IO::Zlib->new("file.gz", "wb9");
+ if (defined $fh) {
+ print $fh "bar\n";
+ $fh->close;
+ }
+
+ $fh = IO::Zlib->new("file.gz", "rb");
+ if (defined $fh) {
+ print <$fh>;
+ undef $fh; # automatically closes the file
+ }
+
+With Perl 5.004 you can also use the TIEHANDLE interface to access
+compressed files just like ordinary files:
+
+ use IO::Zlib;
+
+ tie *FILE, 'IO::Zlib', "file.gz", "wb";
+ print FILE "line 1\nline2\n";
+
+ tie *FILE, 'IO::Zlib', "file.gz", "rb";
+ while (<FILE>) { print "LINE: ", $_ };
+
+=head1 DESCRIPTION
+
+C<IO::Zlib> provides an IO:: style interface to L<Compress::Zlib> and
+hence to gzip/zlib compressed files. It provides many of the same methods
+as the L<IO::Handle> interface.
+
+Starting from IO::Zlib version 1.02, IO::Zlib can also use an
+external F<gzip> command. The default behaviour is to try to use
+an external F<gzip> if no C<Compress::Zlib> can be loaded, unless
+explicitly disabled by
+
+ use IO::Zlib qw(:gzip_external 0);
+
+If explicitly enabled by
+
+ use IO::Zlib qw(:gzip_external 1);
+
+then the external F<gzip> is used B<instead> of C<Compress::Zlib>.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ARGS] )
+
+Creates an C<IO::Zlib> object. If it receives any parameters, they are
+passed to the method C<open>; if the open fails, the object is destroyed.
+Otherwise, it is returned to the caller.
+
+=back
+
+=head1 OBJECT METHODS
+
+=over 4
+
+=item open ( FILENAME, MODE )
+
+C<open> takes two arguments. The first is the name of the file to open
+and the second is the open mode. The mode can be anything acceptable to
+L<Compress::Zlib> and by extension anything acceptable to I<zlib> (that
+basically means POSIX fopen() style mode strings plus an optional number
+to indicate the compression level).
+
+=item opened
+
+Returns true if the object currently refers to a opened file.
+
+=item close
+
+Close the file associated with the object and disassociate
+the file from the handle.
+Done automatically on destroy.
+
+=item getc
+
+Return the next character from the file, or undef if none remain.
+
+=item getline
+
+Return the next line from the file, or undef on end of string.
+Can safely be called in an array context.
+Currently ignores $/ ($INPUT_RECORD_SEPARATOR or $RS when L<English>
+is in use) and treats lines as delimited by "\n".
+
+=item getlines
+
+Get all remaining lines from the file.
+It will croak() if accidentally called in a scalar context.
+
+=item print ( ARGS... )
+
+Print ARGS to the file.
+
+=item read ( BUF, NBYTES, [OFFSET] )
+
+Read some bytes from the file.
+Returns the number of bytes actually read, 0 on end-of-file, undef on error.
+
+=item eof
+
+Returns true if the handle is currently positioned at end of file?
+
+=item seek ( OFFSET, WHENCE )
+
+Seek to a given position in the stream.
+Not yet supported.
+
+=item tell
+
+Return the current position in the stream, as a numeric offset.
+Not yet supported.
+
+=item setpos ( POS )
+
+Set the current position, using the opaque value returned by C<getpos()>.
+Not yet supported.
+
+=item getpos ( POS )
+
+Return the current position in the string, as an opaque object.
+Not yet supported.
+
+=back
+
+=head1 USING THE EXTERNAL GZIP
+
+If the external F<gzip> is used, the following C<open>s are used:
+
+ open(FH, "gzip -dc $filename |") # for read opens
+ open(FH, " | gzip > $filename") # for write opens
+
+You can modify the 'commands' for example to hardwire
+an absolute path by e.g.
+
+ use IO::Zlib ':gzip_read_open' => '/some/where/gunzip -c %s |';
+ use IO::Zlib ':gzip_write_open' => '| /some/where/gzip.exe > %s';
+
+The C<%s> is expanded to be the filename (C<sprintf> is used, so be
+careful to escape any other C<%> signs). The 'commands' are checked
+for sanity - they must contain the C<%s>, and the read open must end
+with the pipe sign, and the write open must begin with the pipe sign.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item has_Compress_Zlib
+
+Returns true if C<Compress::Zlib> is available. Note that this does
+not mean that C<Compress::Zlib> is being used: see L</gzip_external>
+and L<gzip_used>.
+
+=item gzip_external
+
+Undef if an external F<gzip> B<can> be used if C<Compress::Zlib> is
+not available (see L</has_Compress_Zlib>), true if an external F<gzip>
+is explicitly used, false if an external F<gzip> must not be used.
+See L</gzip_used>.
+
+=item gzip_used
+
+True if an external F<gzip> is being used, false if not.
+
+=item gzip_read_open
+
+Return the 'command' being used for opening a file for reading using an
+external F<gzip>.
+
+=item gzip_write_open
+
+Return the 'command' being used for opening a file for writing using an
+external F<gzip>.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item IO::Zlib::getlines: must be called in list context
+
+If you want read lines, you must read in list context.
+
+=item IO::Zlib::gzopen_external: mode '...' is illegal
+
+Use only modes 'rb' or 'wb' or /wb[1-9]/.
+
+=item IO::Zlib::import: '...' is illegal
+
+The known import symbols are the C<:gzip_external>, C<:gzip_read_open>,
+and C<:gzip_write_open>. Anything else is not recognized.
+
+=item IO::Zlib::import: ':gzip_external' requires an argument
+
+The C<:gzip_external> requires one boolean argument.
+
+=item IO::Zlib::import: 'gzip_read_open' requires an argument
+
+The C<:gzip_external> requires one string argument.
+
+=item IO::Zlib::import: 'gzip_read' '...' is illegal
+
+The C<:gzip_read_open> argument must end with the pipe sign (|)
+and have the C<%s> for the filename. See L</"USING THE EXTERNAL GZIP">.
+
+=item IO::Zlib::import: 'gzip_write_open' requires an argument
+
+The C<:gzip_external> requires one string argument.
+
+=item IO::Zlib::import: 'gzip_write_open' '...' is illegal
+
+The C<:gzip_write_open> argument must begin with the pipe sign (|)
+and have the C<%s> for the filename. An output redirect (>) is also
+often a good idea, depending on your operating system shell syntax.
+See L</"USING THE EXTERNAL GZIP">.
+
+=item IO::Zlib::import: no Compress::Zlib and no external gzip
+
+Given that we failed to load C<Compress::Zlib> and that the use of
+ an external F<gzip> was disabled, IO::Zlib has not much chance of working.
+
+=item IO::Zlib::open: needs a filename
+
+No filename, no open.
+
+=item IO::Zlib::READ: NBYTES must be specified
+
+We must know how much to read.
+
+=item IO::Zlib::WRITE: too long LENGTH
+
+The LENGTH must be less than or equal to the buffer size.
+
+=back
+
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<IO::Handle>,
+L<Compress::Zlib>
+
+=head1 HISTORY
+
+Created by Tom Hughes E<lt>F<tom@compton.nu>E<gt>.
+
+Support for external gzip added by Jarkko Hietaniemi E<lt>F<jhi@iki.fi>E<gt>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1998-2004 Tom Hughes E<lt>F<tom@compton.nu>E<gt>.
+All rights reserved. This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+require 5.006;
+
+use strict;
+use vars qw($VERSION $AUTOLOAD @ISA);
+
+use Carp;
+use Fcntl qw(SEEK_SET);
+
+my $has_Compress_Zlib;
+my $aliased;
+
+sub has_Compress_Zlib {
+ $has_Compress_Zlib;
+}
+
+BEGIN {
+ eval { require Compress::Zlib };
+ $has_Compress_Zlib = $@ || $Compress::Zlib::VERSION < 2.000 ? 0 : 1;
+}
+
+use Symbol;
+use Tie::Handle;
+
+# These might use some $^O logic.
+my $gzip_read_open = "gzip -dc %s |";
+my $gzip_write_open = "| gzip > %s";
+
+my $gzip_external;
+my $gzip_used;
+
+sub gzip_read_open {
+ $gzip_read_open;
+}
+
+sub gzip_write_open {
+ $gzip_write_open;
+}
+
+sub gzip_external {
+ $gzip_external;
+}
+
+sub gzip_used {
+ $gzip_used;
+}
+
+sub can_gunzip {
+ $has_Compress_Zlib || $gzip_external;
+}
+
+sub _import {
+ my $import = shift;
+ while (@_) {
+ if ($_[0] eq ':gzip_external') {
+ shift;
+ if (@_) {
+ $gzip_external = shift;
+ } else {
+ croak "$import: ':gzip_external' requires an argument";
+ }
+ }
+ elsif ($_[0] eq ':gzip_read_open') {
+ shift;
+ if (@_) {
+ $gzip_read_open = shift;
+ croak "$import: ':gzip_read_open' '$gzip_read_open' is illegal"
+ unless $gzip_read_open =~ /^.+%s.+\|\s*$/;
+ } else {
+ croak "$import: ':gzip_read_open' requires an argument";
+ }
+ }
+ elsif ($_[0] eq ':gzip_write_open') {
+ shift;
+ if (@_) {
+ $gzip_write_open = shift;
+ croak "$import: ':gzip_write_open' '$gzip_read_open' is illegal"
+ unless $gzip_write_open =~ /^\s*\|.+%s.*$/;
+ } else {
+ croak "$import: ':gzip_write_open' requires an argument";
+ }
+ }
+ else {
+ last;
+ }
+ }
+ return @_;
+}
+
+sub _alias {
+ my $import = shift;
+ if ((!$has_Compress_Zlib && !defined $gzip_external) || $gzip_external) {
+ # The undef *gzopen is really needed only during
+ # testing where we eval several 'use IO::Zlib's.
+ undef *gzopen;
+ *gzopen = \&gzopen_external;
+ *IO::Handle::gzread = \&gzread_external;
+ *IO::Handle::gzwrite = \&gzwrite_external;
+ *IO::Handle::gzreadline = \&gzreadline_external;
+ *IO::Handle::gzeof = \&gzeof_external;
+ *IO::Handle::gzclose = \&gzclose_external;
+ $gzip_used = 1;
+ } else {
+ croak "$import: no Compress::Zlib and no external gzip"
+ unless $has_Compress_Zlib;
+ *gzopen = \&Compress::Zlib::gzopen;
+ *gzread = \&Compress::Zlib::gzread;
+ *gzwrite = \&Compress::Zlib::gzwrite;
+ *gzreadline = \&Compress::Zlib::gzreadline;
+ *gzeof = \&Compress::Zlib::gzeof;
+ }
+ $aliased = 1;
+}
+
+sub import {
+ shift;
+ my $import = "IO::Zlib::import";
+ if (@_) {
+ if (_import($import, @_)) {
+ croak "$import: '@_' is illegal";
+ }
+ }
+ _alias($import);
+}
+
+@ISA = qw(Tie::Handle);
+
+sub TIEHANDLE
+{
+ my $class = shift;
+ my @args = @_;
+
+ my $self = bless {}, $class;
+
+ return @args ? $self->OPEN(@args) : $self;
+}
+
+sub DESTROY
+{
+}
+
+sub OPEN
+{
+ my $self = shift;
+ my $filename = shift;
+ my $mode = shift;
+
+ croak "IO::Zlib::open: needs a filename" unless defined($filename);
+
+ $self->{'file'} = gzopen($filename,$mode);
+
+ return defined($self->{'file'}) ? $self : undef;
+}
+
+sub CLOSE
+{
+ my $self = shift;
+
+ return undef unless defined($self->{'file'});
+
+ my $status = $self->{'file'}->gzclose();
+
+ delete $self->{'file'};
+
+ return ($status == 0) ? 1 : undef;
+}
+
+sub READ
+{
+ my $self = shift;
+ my $bufref = \$_[0];
+ my $nbytes = $_[1];
+ my $offset = $_[2] || 0;
+
+ croak "IO::Zlib::READ: NBYTES must be specified" unless defined($nbytes);
+
+ $$bufref = "" unless defined($$bufref);
+
+ my $bytesread = $self->{'file'}->gzread(substr($$bufref,$offset),$nbytes);
+
+ return undef if $bytesread < 0;
+
+ return $bytesread;
+}
+
+sub READLINE
+{
+ my $self = shift;
+
+ my $line;
+
+ return () if $self->{'file'}->gzreadline($line) <= 0;
+
+ return $line unless wantarray;
+
+ my @lines = $line;
+
+ while ($self->{'file'}->gzreadline($line) > 0)
+ {
+ push @lines, $line;
+ }
+
+ return @lines;
+}
+
+sub WRITE
+{
+ my $self = shift;
+ my $buf = shift;
+ my $length = shift;
+ my $offset = shift;
+
+ croak "IO::Zlib::WRITE: too long LENGTH" unless $offset + $length <= length($buf);
+
+ return $self->{'file'}->gzwrite(substr($buf,$offset,$length));
+}
+
+sub EOF
+{
+ my $self = shift;
+
+ return $self->{'file'}->gzeof();
+}
+
+sub FILENO
+{
+ return undef;
+}
+
+sub new
+{
+ my $class = shift;
+ my @args = @_;
+
+ _alias("new", @_) unless $aliased; # Some call new IO::Zlib directly...
+
+ my $self = gensym();
+
+ tie *{$self}, $class, @args;
+
+ return tied(${$self}) ? bless $self, $class : undef;
+}
+
+sub getline
+{
+ my $self = shift;
+
+ return scalar tied(*{$self})->READLINE();
+}
+
+sub getlines
+{
+ my $self = shift;
+
+ croak "IO::Zlib::getlines: must be called in list context"
+ unless wantarray;
+
+ return tied(*{$self})->READLINE();
+}
+
+sub opened
+{
+ my $self = shift;
+
+ return defined tied(*{$self})->{'file'};
+}
+
+sub AUTOLOAD
+{
+ my $self = shift;
+
+ $AUTOLOAD =~ s/.*:://;
+ $AUTOLOAD =~ tr/a-z/A-Z/;
+
+ return tied(*{$self})->$AUTOLOAD(@_);
+}
+
+sub gzopen_external {
+ my ($filename, $mode) = @_;
+ require IO::Handle;
+ my $fh = IO::Handle->new();
+ if ($mode =~ /r/) {
+ # Because someone will try to read ungzipped files
+ # with this we peek and verify the signature. Yes,
+ # this means that we open the file twice (if it is
+ # gzipped).
+ # Plenty of race conditions exist in this code, but
+ # the alternative would be to capture the stderr of
+ # gzip and parse it, which would be a portability nightmare.
+ if (-e $filename && open($fh, $filename)) {
+ binmode $fh;
+ my $sig;
+ my $rdb = read($fh, $sig, 2);
+ if ($rdb == 2 && $sig eq "\x1F\x8B") {
+ my $ropen = sprintf $gzip_read_open, $filename;
+ if (open($fh, $ropen)) {
+ binmode $fh;
+ return $fh;
+ } else {
+ return undef;
+ }
+ }
+ seek($fh, 0, SEEK_SET) or
+ die "IO::Zlib: open('$filename', 'r'): seek: $!";
+ return $fh;
+ } else {
+ return undef;
+ }
+ } elsif ($mode =~ /w/) {
+ my $level = '';
+ $level = "-$1" if $mode =~ /([1-9])/;
+ # To maximize portability we would need to open
+ # two filehandles here, one for "| gzip $level"
+ # and another for "> $filename", and then when
+ # writing copy bytes from the first to the second.
+ # We are using IO::Handle objects for now, however,
+ # and they can only contain one stream at a time.
+ my $wopen = sprintf $gzip_write_open, $filename;
+ if (open($fh, $wopen)) {
+ $fh->autoflush(1);
+ binmode $fh;
+ return $fh;
+ } else {
+ return undef;
+ }
+ } else {
+ croak "IO::Zlib::gzopen_external: mode '$mode' is illegal";
+ }
+ return undef;
+}
+
+sub gzread_external {
+ # Use read() instead of syswrite() because people may
+ # mix reads and readlines, and we don't want to mess
+ # the stdio buffering. See also gzreadline_external()
+ # and gzwrite_external().
+ my $nread = read($_[0], $_[1], @_ == 3 ? $_[2] : 4096);
+ defined $nread ? $nread : -1;
+}
+
+sub gzwrite_external {
+ # Using syswrite() is okay (cf. gzread_external())
+ # since the bytes leave this process and buffering
+ # is therefore not an issue.
+ my $nwrote = syswrite($_[0], $_[1]);
+ defined $nwrote ? $nwrote : -1;
+}
+
+sub gzreadline_external {
+ # See the comment in gzread_external().
+ $_[1] = readline($_[0]);
+ return defined $_[1] ? length($_[1]) : -1;
+}
+
+sub gzeof_external {
+ return eof($_[0]);
+}
+
+sub gzclose_external {
+ close($_[0]);
+ # I am not entirely certain why this is needed but it seems
+ # the above close() always fails (as if the stream would have
+ # been already closed - something to do with using external
+ # processes via pipes?)
+ return 0;
+}
+
+1;