"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/Archive/Tar/Constant.pm" (7 Mar 2020, 4203 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package Archive::Tar::Constant;
    2 
    3 BEGIN {
    4     require Exporter;
    5 
    6     $VERSION    = '2.32';
    7     @ISA        = qw[Exporter];
    8 
    9     require Time::Local if $^O eq "MacOS";
   10 }
   11 
   12 @EXPORT = Archive::Tar::Constant->_list_consts( __PACKAGE__ );
   13 
   14 use strict;
   15 use warnings;
   16 
   17 use constant FILE           => 0;
   18 use constant HARDLINK       => 1;
   19 use constant SYMLINK        => 2;
   20 use constant CHARDEV        => 3;
   21 use constant BLOCKDEV       => 4;
   22 use constant DIR            => 5;
   23 use constant FIFO           => 6;
   24 use constant SOCKET         => 8;
   25 use constant UNKNOWN        => 9;
   26 use constant LONGLINK       => 'L';
   27 use constant LABEL          => 'V';
   28 
   29 use constant BUFFER         => 4096;
   30 use constant HEAD           => 512;
   31 use constant BLOCK          => 512;
   32 
   33 use constant COMPRESS_GZIP  => 9;
   34 use constant COMPRESS_BZIP  => 'bzip2';
   35 
   36 use constant BLOCK_SIZE     => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK };
   37 use constant TAR_PAD        => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) };
   38 use constant TAR_END        => "\0" x BLOCK;
   39 
   40 use constant READ_ONLY      => sub { shift() ? 'rb' : 'r' };
   41 use constant WRITE_ONLY     => sub { $_[0] ? 'wb' . shift : 'w' };
   42 use constant MODE_READ      => sub { $_[0] =~ /^r/ ? 1 : 0 };
   43 
   44 # Pointless assignment to make -w shut up
   45 my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); };
   46 my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); };
   47 use constant UNAME          => sub { $getpwuid || scalar getpwuid( shift() ) || '' };
   48 use constant GNAME          => sub { $getgrgid || scalar getgrgid( shift() ) || '' };
   49 use constant UID            => $>;
   50 use constant GID            => (split ' ', $) )[0];
   51 
   52 use constant MODE           => do { 0666 & (0777 & ~umask) };
   53 use constant STRIP_MODE     => sub { shift() & 0777 };
   54 use constant CHECK_SUM      => "      ";
   55 
   56 use constant UNPACK         => 'a100 a8 a8 a8 a12 a12 a8 a1 a100 A6 a2 a32 a32 a8 a8 a155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb)
   57 use constant PACK           => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
   58 use constant NAME_LENGTH    => 100;
   59 use constant PREFIX_LENGTH  => 155;
   60 
   61 use constant TIME_OFFSET    => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;
   62 use constant MAGIC          => "ustar";
   63 use constant TAR_VERSION    => "00";
   64 use constant LONGLINK_NAME  => '././@LongLink';
   65 use constant PAX_HEADER     => 'pax_global_header';
   66 
   67                             ### allow ZLIB to be turned off using ENV: DEBUG only
   68 use constant ZLIB           => do { !$ENV{'PERL5_AT_NO_ZLIB'} and
   69                                         eval { require IO::Zlib };
   70                                     $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
   71                                 };
   72 
   73                             ### allow BZIP to be turned off using ENV: DEBUG only
   74 use constant BZIP           => do { !$ENV{'PERL5_AT_NO_BZIP'} and
   75                                         eval { require IO::Uncompress::Bunzip2;
   76                                                require IO::Compress::Bzip2; };
   77                                     $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
   78                                 };
   79 
   80 use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
   81 use constant BZIP_MAGIC_NUM => qr/^BZh\d/;
   82 
   83 use constant CAN_CHOWN      => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
   84 use constant CAN_READLINK   => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
   85 use constant ON_UNIX        => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS');
   86 use constant ON_VMS         => $^O eq 'VMS';
   87 
   88 sub _list_consts {
   89     my $class = shift;
   90     my $pkg   = shift;
   91     return unless defined $pkg; # some joker might use '0' as a pkg...
   92 
   93     my @rv;
   94     {   no strict 'refs';
   95         my $stash = $pkg . '::';
   96 
   97         for my $name (sort keys %$stash ) {
   98 
   99             ### is it a subentry?
  100             my $sub = $pkg->can( $name );
  101             next unless defined $sub;
  102 
  103             next unless defined prototype($sub) and
  104                      not length prototype($sub);
  105 
  106             push @rv, $name;
  107         }
  108     }
  109 
  110     return sort @rv;
  111 }
  112 
  113 1;