Commit | Line | Data |
---|---|---|
39713df4 RGS |
1 | package Archive::Tar::Constant; |
2 | ||
401624ce TR |
3 | use strict; |
4 | use warnings; | |
5 | ||
6 | use vars qw[$VERSION @ISA @EXPORT]; | |
7 | ||
39713df4 RGS |
8 | BEGIN { |
9 | require Exporter; | |
93e94d8a | 10 | |
401624ce | 11 | $VERSION = '2.38'; |
642eb381 | 12 | @ISA = qw[Exporter]; |
39713df4 RGS |
13 | |
14 | require Time::Local if $^O eq "MacOS"; | |
15 | } | |
16 | ||
501bd44a | 17 | @EXPORT = Archive::Tar::Constant->_list_consts( __PACKAGE__ ); |
642eb381 | 18 | |
39713df4 RGS |
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 | ||
642eb381 SH |
35 | use constant COMPRESS_GZIP => 9; |
36 | use constant COMPRESS_BZIP => 'bzip2'; | |
2db5b8da | 37 | use constant COMPRESS_XZ => 'xz'; |
642eb381 | 38 | |
39713df4 RGS |
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 | ||
3c4b39be | 47 | # Pointless assignment to make -w shut up |
39713df4 RGS |
48 | my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); }; |
49 | my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); }; | |
97a504ba RGS |
50 | use constant UNAME => sub { $getpwuid || scalar getpwuid( shift() ) || '' }; |
51 | use constant GNAME => sub { $getgrgid || scalar getgrgid( shift() ) || '' }; | |
39713df4 RGS |
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 | ||
55701e3e | 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) |
39713df4 RGS |
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 | ||
2db5b8da | 64 | use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,1970) : 0; |
39713df4 RGS |
65 | use constant MAGIC => "ustar"; |
66 | use constant TAR_VERSION => "00"; | |
67 | use constant LONGLINK_NAME => '././@LongLink'; | |
642eb381 | 68 | use constant PAX_HEADER => 'pax_global_header'; |
39713df4 | 69 | |
642eb381 | 70 | ### allow ZLIB to be turned off using ENV: DEBUG only |
81a5970e RGS |
71 | use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and |
72 | eval { require IO::Zlib }; | |
93e94d8a | 73 | $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1 |
642eb381 SH |
74 | }; |
75 | ||
93e94d8a | 76 | ### allow BZIP to be turned off using ENV: DEBUG only |
642eb381 SH |
77 | use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and |
78 | eval { require IO::Uncompress::Bunzip2; | |
79 | require IO::Compress::Bzip2; }; | |
93e94d8a | 80 | $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1 |
642eb381 SH |
81 | }; |
82 | ||
2db5b8da CBW |
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 | ||
39713df4 | 90 | use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/; |
642eb381 | 91 | use constant BZIP_MAGIC_NUM => qr/^BZh\d/; |
2db5b8da | 92 | use constant XZ_MAGIC_NUM => qr/^\xFD\x37\x7A\x58\x5A\x00/; |
39713df4 | 93 | |
2610e7a4 | 94 | use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") }; |
39713df4 RGS |
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'); | |
93e94d8a | 97 | use constant ON_VMS => $^O eq 'VMS'; |
39713df4 | 98 | |
501bd44a CBW |
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 | ||
39713df4 | 124 | 1; |