move tlperl.straw to tlperl

git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751

2 files changed, 746 insertions, 0 deletions

diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm
new file mode 100755
index 00000000000..aef1d623fa8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm
@@ -0,0 +1,86 @@
+package Archive::Tar::Constant;
+
+BEGIN {
+    require Exporter;
+    
+    $VERSION    = '0.02';
+    @ISA        = qw[Exporter];
+
+    require Time::Local if $^O eq "MacOS";
+}
+
+use Package::Constants;
+@EXPORT = Package::Constants->list( __PACKAGE__ );
+
+use constant FILE           => 0;
+use constant HARDLINK       => 1;
+use constant SYMLINK        => 2;
+use constant CHARDEV        => 3;
+use constant BLOCKDEV       => 4;
+use constant DIR            => 5;
+use constant FIFO           => 6;
+use constant SOCKET         => 8;
+use constant UNKNOWN        => 9;
+use constant LONGLINK       => 'L';
+use constant LABEL          => 'V';
+
+use constant BUFFER         => 4096;
+use constant HEAD           => 512;
+use constant BLOCK          => 512;
+
+use constant COMPRESS_GZIP  => 9;
+use constant COMPRESS_BZIP  => 'bzip2';
+
+use constant BLOCK_SIZE     => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK };
+use constant TAR_PAD        => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) };
+use constant TAR_END        => "\0" x BLOCK;
+
+use constant READ_ONLY      => sub { shift() ? 'rb' : 'r' };
+use constant WRITE_ONLY     => sub { $_[0] ? 'wb' . shift : 'w' };
+use constant MODE_READ      => sub { $_[0] =~ /^r/ ? 1 : 0 };
+
+# Pointless assignment to make -w shut up
+my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); };
+my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); };
+use constant UNAME          => sub { $getpwuid || scalar getpwuid( shift() ) || '' };
+use constant GNAME          => sub { $getgrgid || scalar getgrgid( shift() ) || '' };
+use constant UID            => $>;
+use constant GID            => (split ' ', $) )[0];
+
+use constant MODE           => do { 0666 & (0777 & ~umask) };
+use constant STRIP_MODE     => sub { shift() & 0777 };
+use constant CHECK_SUM      => "      ";
+
+use constant UNPACK         => 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12';
+use constant PACK           => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
+use constant NAME_LENGTH    => 100;
+use constant PREFIX_LENGTH  => 155;
+
+use constant TIME_OFFSET    => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;    
+use constant MAGIC          => "ustar";
+use constant TAR_VERSION    => "00";
+use constant LONGLINK_NAME  => '././@LongLink';
+use constant PAX_HEADER     => 'pax_global_header';
+
+                            ### allow ZLIB to be turned off using ENV: DEBUG only
+use constant ZLIB           => do { !$ENV{'PERL5_AT_NO_ZLIB'} and
+                                        eval { require IO::Zlib };
+                                    $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1 
+                                };
+
+                            ### allow BZIP to be turned off using ENV: DEBUG only                                
+use constant BZIP           => do { !$ENV{'PERL5_AT_NO_BZIP'} and
+                                        eval { require IO::Uncompress::Bunzip2;
+                                               require IO::Compress::Bzip2; };
+                                    $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1 
+                                };
+
+use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
+use constant BZIP_MAGIC_NUM => qr/^BZh\d/;
+
+use constant CAN_CHOWN      => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
+use constant CAN_READLINK   => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
+use constant ON_UNIX        => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS');
+use constant ON_VMS         => $^O eq 'VMS'; 
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
new file mode 100755
index 00000000000..0815bb67620
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm
@@ -0,0 +1,660 @@
+package Archive::Tar::File;
+use strict;
+
+use Carp                ();
+use IO::File;
+use File::Spec::Unix    ();
+use File::Spec          ();
+use File::Basename      ();
+
+### avoid circular use, so only require;
+require Archive::Tar;
+use Archive::Tar::Constant;
+
+use vars qw[@ISA $VERSION];
+#@ISA        = qw[Archive::Tar];
+$VERSION    = '0.02';
+
+### set value to 1 to oct() it during the unpack ###
+my $tmpl = [
+        name        => 0,   # string
+        mode        => 1,   # octal
+        uid         => 1,   # octal
+        gid         => 1,   # octal
+        size        => 1,   # octal
+        mtime       => 1,   # octal
+        chksum      => 1,   # octal
+        type        => 0,   # character
+        linkname    => 0,   # string
+        magic       => 0,   # string
+        version     => 0,   # 2 bytes
+        uname       => 0,   # string
+        gname       => 0,   # string
+        devmajor    => 1,   # octal
+        devminor    => 1,   # octal
+        prefix      => 0,
+
+### end UNPACK items ###
+        raw         => 0,   # the raw data chunk
+        data        => 0,   # the data associated with the file --
+                            # This  might be very memory intensive
+];
+
+### install get/set accessors for this object.
+for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
+    my $key = $tmpl->[$i];
+    no strict 'refs';
+    *{__PACKAGE__."::$key"} = sub {
+        my $self = shift;
+        $self->{$key} = $_[0] if @_;
+
+        ### just in case the key is not there or undef or something ###
+        {   local $^W = 0;
+            return $self->{$key};
+        }
+    }
+}
+
+=head1 NAME
+
+Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar
+
+=head1 SYNOPSIS
+
+    my @items = $tar->get_files;
+
+    print $_->name, ' ', $_->size, "\n" for @items;
+
+    print $object->get_content;
+    $object->replace_content('new content');
+
+    $object->rename( 'new/full/path/to/file.c' );
+
+=head1 DESCRIPTION
+
+Archive::Tar::Files provides a neat little object layer for in-memory
+extracted files. It's mostly used internally in Archive::Tar to tidy
+up the code, but there's no reason users shouldn't use this API as
+well.
+
+=head2 Accessors
+
+A lot of the methods in this package are accessors to the various
+fields in the tar header:
+
+=over 4
+
+=item name
+
+The file's name
+
+=item mode
+
+The file's mode
+
+=item uid
+
+The user id owning the file
+
+=item gid
+
+The group id owning the file
+
+=item size
+
+File size in bytes
+
+=item mtime
+
+Modification time. Adjusted to mac-time on MacOS if required
+
+=item chksum
+
+Checksum field for the tar header
+
+=item type
+
+File type -- numeric, but comparable to exported constants -- see
+Archive::Tar's documentation
+
+=item linkname
+
+If the file is a symlink, the file it's pointing to
+
+=item magic
+
+Tar magic string -- not useful for most users
+
+=item version
+
+Tar version string -- not useful for most users
+
+=item uname
+
+The user name that owns the file
+
+=item gname
+
+The group name that owns the file
+
+=item devmajor
+
+Device major number in case of a special file
+
+=item devminor
+
+Device minor number in case of a special file
+
+=item prefix
+
+Any directory to prefix to the extraction path, if any
+
+=item raw
+
+Raw tar header -- not useful for most users
+
+=back
+
+=head1 Methods
+
+=head2 Archive::Tar::File->new( file => $path )
+
+Returns a new Archive::Tar::File object from an existing file.
+
+Returns undef on failure.
+
+=head2 Archive::Tar::File->new( data => $path, $data, $opt )
+
+Returns a new Archive::Tar::File object from data.
+
+C<$path> defines the file name (which need not exist), C<$data> the
+file contents, and C<$opt> is a reference to a hash of attributes
+which may be used to override the default attributes (fields in the
+tar header), which are described above in the Accessors section.
+
+Returns undef on failure.
+
+=head2 Archive::Tar::File->new( chunk => $chunk )
+
+Returns a new Archive::Tar::File object from a raw 512-byte tar
+archive chunk.
+
+Returns undef on failure.
+
+=cut
+
+sub new {
+    my $class   = shift;
+    my $what    = shift;
+
+    my $obj =   ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) :
+                ($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) :
+                ($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) :
+                undef;
+
+    return $obj;
+}
+
+### copies the data, creates a clone ###
+sub clone {
+    my $self = shift;
+    return bless { %$self }, ref $self;
+}
+
+sub _new_from_chunk {
+    my $class = shift;
+    my $chunk = shift or return;    # 512 bytes of tar header
+    my %hash  = @_;
+
+    ### filter any arguments on defined-ness of values.
+    ### this allows overriding from what the tar-header is saying
+    ### about this tar-entry. Particularly useful for @LongLink files
+    my %args  = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;
+
+    ### makes it start at 0 actually... :) ###
+    my $i = -1;
+    my %entry = map {
+        $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_
+    } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );
+
+    my $obj = bless { %entry, %args }, $class;
+
+	### magic is a filetype string.. it should have something like 'ustar' or
+	### something similar... if the chunk is garbage, skip it
+	return unless $obj->magic !~ /\W/;
+
+    ### store the original chunk ###
+    $obj->raw( $chunk );
+
+    $obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
+    $obj->type(DIR)  if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
+
+
+    return $obj;
+
+}
+
+sub _new_from_file {
+    my $class       = shift;
+    my $path        = shift;        
+    
+    ### path has to at least exist
+    return unless defined $path;
+    
+    my $type        = __PACKAGE__->_filetype($path);
+    my $data        = '';
+
+    READ: { 
+        unless ($type == DIR ) {
+            my $fh = IO::File->new;
+        
+            unless( $fh->open($path) ) {
+                ### dangling symlinks are fine, stop reading but continue
+                ### creating the object
+                last READ if $type == SYMLINK;
+                
+                ### otherwise, return from this function --
+                ### anything that's *not* a symlink should be
+                ### resolvable
+                return;
+            }
+
+            ### binmode needed to read files properly on win32 ###
+            binmode $fh;
+            $data = do { local $/; <$fh> };
+            close $fh;
+        }
+    }
+
+    my @items       = qw[mode uid gid size mtime];
+    my %hash        = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
+
+    if (ON_VMS) {
+        ### VMS has two UID modes, traditional and POSIX.  Normally POSIX is
+        ### not used.  We currently do not have an easy way to see if we are in
+        ### POSIX mode.  In traditional mode, the UID is actually the VMS UIC.
+        ### The VMS UIC has the upper 16 bits is the GID, which in many cases
+        ### the VMS UIC will be larger than 209715, the largest that TAR can
+        ### handle.  So for now, assume it is traditional if the UID is larger
+        ### than 0x10000.
+
+        if ($hash{uid} > 0x10000) {
+            $hash{uid} = $hash{uid} & 0xFFFF;
+        }
+
+        ### The file length from stat() is the physical length of the file
+        ### However the amount of data read in may be more for some file types.
+        ### Fixed length files are read past the logical EOF to end of the block
+        ### containing.  Other file types get expanded on read because record
+        ### delimiters are added.
+
+        my $data_len = length $data;
+        $hash{size} = $data_len if $hash{size} < $data_len;
+
+    }
+    ### you *must* set size == 0 on symlinks, or the next entry will be
+    ### though of as the contents of the symlink, which is wrong.
+    ### this fixes bug #7937
+    $hash{size}     = 0 if ($type == DIR or $type == SYMLINK);
+    $hash{mtime}    -= TIME_OFFSET;
+
+    ### strip the high bits off the mode, which we don't need to store
+    $hash{mode}     = STRIP_MODE->( $hash{mode} );
+
+
+    ### probably requires some file path munging here ... ###
+    ### name and prefix are set later
+    my $obj = {
+        %hash,
+        name        => '',
+        chksum      => CHECK_SUM,
+        type        => $type,
+        linkname    => ($type == SYMLINK and CAN_READLINK)
+                            ? readlink $path
+                            : '',
+        magic       => MAGIC,
+        version     => TAR_VERSION,
+        uname       => UNAME->( $hash{uid} ),
+        gname       => GNAME->( $hash{gid} ),
+        devmajor    => 0,   # not handled
+        devminor    => 0,   # not handled
+        prefix      => '',
+        data        => $data,
+    };
+
+    bless $obj, $class;
+
+    ### fix up the prefix and file from the path
+    my($prefix,$file) = $obj->_prefix_and_file( $path );
+    $obj->prefix( $prefix );
+    $obj->name( $file );
+
+    return $obj;
+}
+
+sub _new_from_data {
+    my $class   = shift;
+    my $path    = shift;    return unless defined $path;
+    my $data    = shift;    return unless defined $data;
+    my $opt     = shift;
+
+    my $obj = {
+        data        => $data,
+        name        => '',
+        mode        => MODE,
+        uid         => UID,
+        gid         => GID,
+        size        => length $data,
+        mtime       => time - TIME_OFFSET,
+        chksum      => CHECK_SUM,
+        type        => FILE,
+        linkname    => '',
+        magic       => MAGIC,
+        version     => TAR_VERSION,
+        uname       => UNAME->( UID ),
+        gname       => GNAME->( GID ),
+        devminor    => 0,
+        devmajor    => 0,
+        prefix      => '',
+    };
+
+    ### overwrite with user options, if provided ###
+    if( $opt and ref $opt eq 'HASH' ) {
+        for my $key ( keys %$opt ) {
+
+            ### don't write bogus options ###
+            next unless exists $obj->{$key};
+            $obj->{$key} = $opt->{$key};
+        }
+    }
+
+    bless $obj, $class;
+
+    ### fix up the prefix and file from the path
+    my($prefix,$file) = $obj->_prefix_and_file( $path );
+    $obj->prefix( $prefix );
+    $obj->name( $file );
+
+    return $obj;
+}
+
+sub _prefix_and_file {
+    my $self = shift;
+    my $path = shift;
+
+    my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
+    my @dirs = File::Spec->splitdir( $dirs );
+
+    ### so sometimes the last element is '' -- probably when trailing
+    ### dir slashes are encountered... this is of course pointless,
+    ### so remove it
+    pop @dirs while @dirs and not length $dirs[-1];
+
+    ### if it's a directory, then $file might be empty
+    $file = pop @dirs if $self->is_dir and not length $file;
+
+    ### splitting ../ gives you the relative path in native syntax
+    map { $_ = '..' if $_  eq '-' } @dirs if ON_VMS;
+
+    my $prefix = File::Spec::Unix->catdir(
+                        grep { length } $vol, @dirs
+                    );
+    return( $prefix, $file );
+}
+
+sub _filetype {
+    my $self = shift;
+    my $file = shift;
+    
+    return unless defined $file;
+
+    return SYMLINK  if (-l $file);	# Symlink
+
+    return FILE     if (-f _);		# Plain file
+
+    return DIR      if (-d _);		# Directory
+
+    return FIFO     if (-p _);		# Named pipe
+
+    return SOCKET   if (-S _);		# Socket
+
+    return BLOCKDEV if (-b _);		# Block special
+
+    return CHARDEV  if (-c _);		# Character special
+
+    ### shouldn't happen, this is when making archives, not reading ###
+    return LONGLINK if ( $file eq LONGLINK_NAME );
+
+    return UNKNOWN;		            # Something else (like what?)
+
+}
+
+### this method 'downgrades' a file to plain file -- this is used for
+### symlinks when FOLLOW_SYMLINKS is true.
+sub _downgrade_to_plainfile {
+    my $entry = shift;
+    $entry->type( FILE );
+    $entry->mode( MODE );
+    $entry->linkname('');
+
+    return 1;
+}
+
+=head2 $bool = $file->extract( [ $alternative_name ] )
+
+Extract this object, optionally to an alternative name. 
+
+See C<< Archive::Tar->extract_file >> for details.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub extract {
+    my $self = shift;
+    
+    local $Carp::CarpLevel += 1;
+    
+    return Archive::Tar->_extract_file( $self, @_ );
+}
+
+=head2 $path = $file->full_path
+
+Returns the full path from the tar header; this is basically a
+concatenation of the C<prefix> and C<name> fields.
+
+=cut
+
+sub full_path {
+    my $self = shift;
+
+    ### if prefix field is emtpy
+    return $self->name unless defined $self->prefix and length $self->prefix;
+
+    ### or otherwise, catfile'd
+    return File::Spec::Unix->catfile( $self->prefix, $self->name );
+}
+
+
+=head2 $bool = $file->validate
+
+Done by Archive::Tar internally when reading the tar file:
+validate the header against the checksum to ensure integer tar file.
+
+Returns true on success, false on failure
+
+=cut
+
+sub validate {
+    my $self = shift;
+
+    my $raw = $self->raw;
+
+    ### don't know why this one is different from the one we /write/ ###
+    substr ($raw, 148, 8) = "        ";
+
+    ### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar
+    ### like GNU tar does. See here for details:
+    ### http://www.gnu.org/software/tar/manual/tar.html#SEC139
+    ### so we do both a signed AND unsigned validate. if one succeeds, that's
+    ### good enough
+	return (   (unpack ("%16C*", $raw) == $self->chksum)
+	        or (unpack ("%16c*", $raw) == $self->chksum)) ? 1 : 0;
+}
+
+=head2 $bool = $file->has_content
+
+Returns a boolean to indicate whether the current object has content.
+Some special files like directories and so on never will have any
+content. This method is mainly to make sure you don't get warnings
+for using uninitialized values when looking at an object's content.
+
+=cut
+
+sub has_content {
+    my $self = shift;
+    return defined $self->data() && length $self->data() ? 1 : 0;
+}
+
+=head2 $content = $file->get_content
+
+Returns the current content for the in-memory file
+
+=cut
+
+sub get_content {
+    my $self = shift;
+    $self->data( );
+}
+
+=head2 $cref = $file->get_content_by_ref
+
+Returns the current content for the in-memory file as a scalar
+reference. Normal users won't need this, but it will save memory if
+you are dealing with very large data files in your tar archive, since
+it will pass the contents by reference, rather than make a copy of it
+first.
+
+=cut
+
+sub get_content_by_ref {
+    my $self = shift;
+
+    return \$self->{data};
+}
+
+=head2 $bool = $file->replace_content( $content )
+
+Replace the current content of the file with the new content. This
+only affects the in-memory archive, not the on-disk version until
+you write it.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub replace_content {
+    my $self = shift;
+    my $data = shift || '';
+
+    $self->data( $data );
+    $self->size( length $data );
+    return 1;
+}
+
+=head2 $bool = $file->rename( $new_name )
+
+Rename the current file to $new_name.
+
+Note that you must specify a Unix path for $new_name, since per tar
+standard, all files in the archive must be Unix paths.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub rename {
+    my $self = shift;
+    my $path = shift;
+    
+    return unless defined $path;
+
+    my ($prefix,$file) = $self->_prefix_and_file( $path );
+
+    $self->name( $file );
+    $self->prefix( $prefix );
+
+	return 1;
+}
+
+=head1 Convenience methods
+
+To quickly check the type of a C<Archive::Tar::File> object, you can
+use the following methods:
+
+=over 4
+
+=item $file->is_file
+
+Returns true if the file is of type C<file>
+
+=item $file->is_dir
+
+Returns true if the file is of type C<dir>
+
+=item $file->is_hardlink
+
+Returns true if the file is of type C<hardlink>
+
+=item $file->is_symlink
+
+Returns true if the file is of type C<symlink>
+
+=item $file->is_chardev
+
+Returns true if the file is of type C<chardev>
+
+=item $file->is_blockdev
+
+Returns true if the file is of type C<blockdev>
+
+=item $file->is_fifo
+
+Returns true if the file is of type C<fifo>
+
+=item $file->is_socket
+
+Returns true if the file is of type C<socket>
+
+=item $file->is_longlink
+
+Returns true if the file is of type C<LongLink>.
+Should not happen after a successful C<read>.
+
+=item $file->is_label
+
+Returns true if the file is of type C<Label>.
+Should not happen after a successful C<read>.
+
+=item $file->is_unknown
+
+Returns true if the file type is C<unknown>
+
+=back
+
+=cut
+
+#stupid perl5.5.3 needs to warn if it's not numeric
+sub is_file     { local $^W;    FILE      == $_[0]->type }
+sub is_dir      { local $^W;    DIR       == $_[0]->type }
+sub is_hardlink { local $^W;    HARDLINK  == $_[0]->type }
+sub is_symlink  { local $^W;    SYMLINK   == $_[0]->type }
+sub is_chardev  { local $^W;    CHARDEV   == $_[0]->type }
+sub is_blockdev { local $^W;    BLOCKDEV  == $_[0]->type }
+sub is_fifo     { local $^W;    FIFO      == $_[0]->type }
+sub is_socket   { local $^W;    SOCKET    == $_[0]->type }
+sub is_unknown  { local $^W;    UNKNOWN   == $_[0]->type }
+sub is_longlink { local $^W;    LONGLINK  eq $_[0]->type }
+sub is_label    { local $^W;    LABEL     eq $_[0]->type }
+
+1;