"Fossies" - the Fresh Open Source Software Archive

Member "Archive-Tar-2.38/lib/Archive/Tar/Constant.pm" (25 Jun 2020, 4747 Bytes) of package /linux/privat/Archive-Tar-2.38.tar.gz:


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. For more information about "Constant.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 2.36_vs_2.38.

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