'Archive::Tar' =>
{
'MAINTAINER' => 'kane',
- 'DISTRIBUTION' => 'BINGOS/Archive-Tar-1.76.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Archive-Tar-1.78.tar.gz',
'FILES' => q[cpan/Archive-Tar],
'EXCLUDED' => [ qw(Makefile.PL) ],
'UPSTREAM' => 'cpan',
my $print = $verbose || $opts->{'t'} || 0;
my $iter = Archive::Tar->iter( $file );
-
+
while( my $f = $iter->() ) {
print $f->full_path . $/ if $print;
### data dumper output
print Dumper( $f ) if $opts->{'D'};
-
+
### extract it
$f->extract if $opts->{'x'};
}
### strip the pod directives
$usage =~ s/=pod\n//g;
$usage =~ s/=head1 //g;
-
+
### add some newlines
$usage .= $/.$/;
-
+
return $usage;
}
foreach my $file ( $tar->get_files ) {
next unless $file->is_file;
my $name = $file->name;
-
- diff( \($file->get_content), $name,
+
+ diff( \($file->get_content), $name,
{ FILENAME_A => $name,
MTIME_A => $file->mtime,
OUTPUT => \*STDOUT
- }
+ }
);
}
Usage: ptardiff ARCHIVE_FILE
ptardiff -h
-
+
ptardiff is a small program that diffs an extracted archive
against an unextracted one, using the perl module Archive::Tar.
-
- This effectively lets you view changes made to an archives contents.
-
+
+ This effectively lets you view changes made to an archives contents.
+
Provide the progam with an ARCHIVE_FILE and it will look up all
the files with in the archive, scan the current working directory
for a file with the name and diff it against the contents of the
archive.
-
+
Options:
h Prints this help message
Sample Usage:
- $ tar -xzf Acme-Buffy-1.3.tar.gz
+ $ tar -xzf Acme-Buffy-1.3.tar.gz
$ vi Acme-Buffy-1.3/README
-
+
[...]
$ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
Archive::Tar
] . $/;
-}
+}
ptardiff is a small program that diffs an extracted archive
against an unextracted one, using the perl module Archive::Tar.
-
- This effectively lets you view changes made to an archives contents.
-
+
+ This effectively lets you view changes made to an archives contents.
+
Provide the progam with an ARCHIVE_FILE and it will look up all
the files with in the archive, scan the current working directory
for a file with the name and diff it against the contents of the
ptardiff ARCHIVE_FILE
ptardiff -h
- $ tar -xzf Acme-Buffy-1.3.tar.gz
+ $ tar -xzf Acme-Buffy-1.3.tar.gz
$ vi Acme-Buffy-1.3/README
[...]
$ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
Copyright 2010 Grant McLean E<lt>grantm@cpan.orgE<gt>
This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
+under the same terms as Perl itself.
=cut
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "1.76";
+$VERSION = "1.78";
$CHOWN = 1;
$CHMOD = 1;
$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
$tar->add_data('file/baz.txt', 'This is the contents now');
$tar->rename('oldname', 'new/file/name');
+ $tar->chown('/', 'root');
+ $tar->chown('/', 'root:root');
$tar->write('files.tar'); # plain tar
$tar->write('files.tgz', COMPRESS_GZIP); # gzip compressed
$self->_error( qq[Cannot read compressed format in tar-mode] );
return;
}
-
+
### size is < HEAD, which means a corrupted file, as the minimum
### length is _at least_ HEAD
if (length $chunk != HEAD) {
if ($skip) {
#
# Since we're skipping, do not allocate memory for the
- # whole file. Read it 64 BLOCKS at a time. Do not
+ # whole file. Read it 64 BLOCKS at a time. Do not
# complete the skip yet because maybe what we read is a
# longlink and it won't get skipped after all
#
return $entry->rename( $new );
}
+=head2 $tar->chown( $file, $uname [, $gname] )
+
+Change owner $file to $uname and $gname.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub chown {
+ my $self = shift;
+ my $file = shift; return unless defined $file;
+ my $uname = shift; return unless defined $uname;
+ my @args = ($uname);
+ push(@args, shift);
+
+ my $entry = $self->_find_entry( $file ) or return;
+ my $x = $entry->chown( @args );
+ return $x;
+}
+
=head2 $tar->remove (@filenamelist)
Removes any entries with names matching any of the given filenames
sub iter {
my $class = shift;
my $filename = shift or return;
- my $compressed = shift or 0;
+ my $compressed = shift || 0;
my $opts = shift || {};
### get a handle to read from.
=head2 $Archive::Tar::ZERO_PAD_NUMBERS
This variable holds a boolean indicating if we will create
-zero padded numbers for C<size>, C<mtime> and C<checksum>.
+zero padded numbers for C<size>, C<mtime> and C<checksum>.
The default is C<0>, indicating that we will create space padded
numbers. Added for compatibility with C<busybox> implementations.
=head1 CAVEATS
-The AIX tar does not fill all unused space in the tar archive with 0x00.
+The AIX tar does not fill all unused space in the tar archive with 0x00.
This sometimes leads to warning messages from C<Archive::Tar>.
Invalid header block at offset nnn
AIX 5.3 TL8 SP8
AIX 5.3 TL9 SP5
AIX 5.3 TL10 SP2
-
+
AIX 6.1 TL0 SP11
AIX 6.1 TL1 SP7
AIX 6.1 TL2 SP6
AIX 6.1 TL3 SP3
-The IBM APAR number for this problem is IZ50240 (Reported component ID:
-5765G0300 / AIX 5.3). It is possible to get an ifix for that problem.
+The IBM APAR number for this problem is IZ50240 (Reported component ID:
+5765G0300 / AIX 5.3). It is possible to get an ifix for that problem.
If you need an ifix please contact your local IBM AIX support.
=head1 TODO
BEGIN {
require Exporter;
-
- $VERSION = '1.76';
+
+ $VERSION = '1.78';
@ISA = qw[Exporter];
require Time::Local if $^O eq "MacOS";
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 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';
### 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
+ $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
};
- ### allow BZIP to be turned off using ENV: DEBUG only
+ ### 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
+ $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
};
use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
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';
+use constant ON_VMS => $^O eq 'VMS';
1;
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
-$VERSION = '1.76';
+$VERSION = '1.78';
### set value to 1 to oct() it during the unpack ###
my $tmpl = [
sub _new_from_file {
my $class = shift;
- my $path = shift;
-
+ my $path = shift;
+
### path has to at least exist
return unless defined $path;
-
+
my $type = __PACKAGE__->_filetype($path);
my $data = '';
- READ: {
+ 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
sub _filetype {
my $self = shift;
my $file = shift;
-
+
return unless defined $file;
return SYMLINK if (-l $file); # Symlink
=head2 $bool = $file->extract( [ $alternative_name ] )
-Extract this object, optionally to an alternative name.
+Extract this object, optionally to an alternative name.
See C<< Archive::Tar->extract_file >> for details.
sub extract {
my $self = shift;
-
+
local $Carp::CarpLevel += 1;
-
+
return Archive::Tar->_extract_file( $self, @_ );
}
sub rename {
my $self = shift;
my $path = shift;
-
+
return unless defined $path;
my ($prefix,$file) = $self->_prefix_and_file( $path );
return 1;
}
+=head2 $bool = $file->chown( $user [, $group])
+
+Change owner of $file to $user. If a $group is given that is changed
+as well. You can also pass a single parameter with a colon separating the
+use and group as in 'root:wheel'.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub chown {
+ my $self = shift;
+ my $uname = shift;
+ return unless defined $uname;
+ my $gname;
+ if (-1 != index($uname, ':')) {
+ ($uname, $gname) = split(/:/, $uname);
+ } else {
+ $gname = shift if @_ > 0;
+ }
+
+ $self->uname( $uname );
+ $self->gname( $gname ) if $gname;
+ return 1;
+}
+
=head1 Convenience methods
To quickly check the type of a C<Archive::Tar::File> object, you can
### This program tests Archive::Tar::File ###
-
use Test::More 'no_plan';
use strict;
### we didnt handle 'false' filenames very well across A::T as of version
### 1.32, as reported in #28687. Test for the handling of such files here.
[ 0, '', ],
-
+
### keep this one as the last entry
[ 'x/yy/z', '', { type => DIR,
mode => 0777,
ok( ! $obj->devminor, " devminor ok" );
ok( ! $obj->raw, " raw ok" );
- ### test type checkers
+ ### test type checkers
SKIP: {
skip "Attributes defined, may not be plainfile", 11 if keys %$attr;
-
+
ok( $obj->is_file, " Object is a file" );
-
- for my $name (qw[dir hardlink symlink chardev blockdev fifo
+
+ for my $name (qw[dir hardlink symlink chardev blockdev fifo
socket unknown longlink label ]
) {
my $method = 'is_' . $name;
-
+
ok(!$obj->$method(), " Object is not a '$name'");
}
- }
+ }
### Use "ok" not "is" to avoid binary data screwing up the screen ###
ok( $obj->get_content eq $contents, " get_content ok" );
ok( $obj->get_content eq $contents, " get_content ok" );
ok( $obj->rename( $rename_path ), " rename ok" );
+ ok( $obj->chown( 'root' ), " chown 1 arg ok" );
+ is( $obj->uname, 'root', " chown to root ok" );
+ ok( $obj->chown( 'rocky', 'perl'), " chown 2 args ok" );
+ is( $obj->uname, 'rocky', " chown to rocky ok" );
+ is( $obj->gname, 'perl', " chown to rocky:perl ok" );
is( $obj->name, $rename_file, " name '$file' ok" );
is( $obj->prefix, $rename_dir, " prefix '$dir' ok" );
ok( $obj->rename( $unix_path ), " rename ok" );
{ my $aref = $test_files[-1];
my $unix_path = $aref->[0];
my $contents = $aref->[1];
- my $attr = $aref->[2];
-
+ my $attr = $aref->[2];
+
my $obj = Archive::Tar::File->new( data => $unix_path, $contents, $attr );
-
+
### check if the object is as expected
isa_ok( $obj, 'Archive::Tar::File' );
ok( $obj->is_dir, " Is a directory" );
-
- ### do the downgrade
+
+ ### do the downgrade
ok( $obj->_downgrade_to_plainfile, " Downgraded to plain file" );
-
+
### now check if it's downgraded
ok( $obj->is_file, " Is now a file" );
is( $obj->linkname, '', " No link entered" );
is( $obj->mode, MODE, " Mode as expected" );
-}
-
+}
+
### helper subs ###
sub dir_and_file {
my $unix_path = shift;
### encoding style
local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
-
- my $dir = 'Catalyst-Helper-Controller-Scaffold-HTML-Template-0_03/' .
+
+ my $dir = 'Catalyst-Helper-Controller-Scaffold-HTML-Template-0_03/' .
'lib/Catalyst/Helper/Controller/Scaffold/HTML/';
my $file = 'Template.pm';
my $out = $$ . '.tar';
-
+
### first create the file
{ my $tar = $Class->new;
-
+
isa_ok( $tar, $Class, " Object" );
ok( $tar->add_data( $dir.$file => $$ ),
" Added long file" );
-
+
ok( $tar->write($out), " File written to $out" );
}
-
+
### then read it back in
{ my $tar = $Class->new;
isa_ok( $tar, $Class, " Object" );
ok( $tar->read( $out ), " Read in $out again" );
-
+
my @files = $tar->get_files;
is( scalar(@files), 1, " Only 1 entry found" );
-
+
my $entry = shift @files;
ok( $entry->is_file, " Entry is a file" );
is( $entry->name, $dir.$file,
" With the proper name" );
- }
-
+ }
+
### remove the file
unless( $NO_UNLINK ) { 1 while unlink $out }
-}
+}
### bug #14922
-### There's a bug in Archive::Tar that causes a file like: foo/foo.txt
+### There's a bug in Archive::Tar that causes a file like: foo/foo.txt
### to be stored in the tar file as: foo/.txt
### XXX could not be reproduced in 1.26 -- leave test to be sure
{ ok( 1, "Testing bug 14922" );
my $dir = $$ . '/';
my $file = $$ . '.txt';
my $out = $$ . '.tar';
-
+
### first create the file
{ my $tar = $Class->new;
-
+
isa_ok( $tar, $Class, " Object" );
ok( $tar->add_data( $dir.$file => $$ ),
" Added long file" );
-
+
ok( $tar->write($out), " File written to $out" );
}
{ my $tar = $Class->new;
isa_ok( $tar, $Class, " Object" );
ok( $tar->read( $out ), " Read in $out again" );
-
+
my @files = $tar->get_files;
is( scalar(@files), 1, " Only 1 entry found" );
-
+
my $entry = shift @files;
ok( $entry->is_file, " Entry is a file" );
is( $entry->full_path, $dir.$file,
" With the proper name" );
- }
-
+ }
+
### remove the file
unless( $NO_UNLINK ) { 1 while unlink $out }
-}
-
-### bug #30380: directory traversal vulnerability in Archive-Tar
+}
+
+### bug #30380: directory traversal vulnerability in Archive-Tar
### Archive::Tar allowed files to be extracted to a dir outside
### it's cwd(), effectively allowing you to overwrite any files
### on the system, given the right permissions.
{ ok( 1, "Testing bug 30880" );
my $tar = $Class->new;
- isa_ok( $tar, $Class, " Object" );
-
+ isa_ok( $tar, $Class, " Object" );
+
### absolute paths are already taken care of. Only relative paths
### matter
my $in_file = basename($0);
my $out_file = '../' . $in_file . "_$$";
-
- ok( $tar->add_files( $in_file ),
+
+ ok( $tar->add_files( $in_file ),
" Added '$in_file'" );
+ ok( $tar->chown( $in_file, 'root' ),
+ " chown to root" );
+
+ ok( $tar->chown( $in_file, 'root', 'root' ),
+ " chown to root:root" );
+
ok( $tar->rename( $in_file, $out_file ),
" Renamed to '$out_file'" );
-
+
### first, test with strict extract permissions on
{ local $Archive::Tar::INSECURE_EXTRACT_MODE = 0;
ok( ! $tar->extract_file( $out_file ),
" File not extracted" );
ok( ! -e $out_file, " File '$out_file' does not exist" );
-
+
ok( $tar->error, " Error message stored" );
like( $tar->error, qr/attempting to leave/,
" Proper violation detected" );
}
-
+
### now disable those
{ local $Archive::Tar::INSECURE_EXTRACT_MODE = 1;
ok( 1, " Extracting in insecure mode" );
-
+
ok( $tar->extract_file( $out_file ),
" File extracted" );
ok( -e $out_file, " File '$out_file' exists" );
-
+
### and clean up
unless( $NO_UNLINK ) { 1 while unlink $out_file };
- }
+ }
}
### 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
{ ok( 1, "Testing bug 43513" );
-
+
my $src = File::Spec->catfile( qw[src header signed.tar] );
my $tar = $Class->new;
-
+
isa_ok( $tar, $Class, " Object" );
ok( $tar->read( $src ), " Read non-Posix file with signed Checksum" );
-
+
for my $file ( $tar->get_files ) {
ok( $file, " File object retrieved" );
ok( $file->validate, " File validates" );
- }
+ }
}
### return error properly on corrupted archives
{ ok( 1, "Testing bug 44680" );
{ ### XXX whitebox test -- resetting the error string
- no warnings 'once';
+ no warnings 'once';
$Archive::Tar::error = "";
}
my $src = File::Spec->catfile( qw[src short b] );
my $tar = $Class->new;
-
+
isa_ok( $tar, $Class, " Object" );
-
-
+
+
### we quell the error on STDERR
local $Archive::Tar::WARN = 0;
use_ok( $Class );
### crazy ref to special case 'all'
-for my $index ( \0, 0 .. $#Expect ) {
+for my $index ( \0, 0 .. $#Expect ) {
my %opts = ();
my @expect = ();
-
+
my $dotest = sub {
my $desc = shift;
my $next = $Class->iter( $File, 0, \%opts );
-
+
my $pp_opts = join " => ", %opts;
ok( $next, "Iterator created from $File ($pp_opts $desc)" );
isa_ok( $next, "CODE", " Iterator $desc" );
push @names, $f->name;
}
-
+
is( scalar(@names), scalar(@expect),
" Found correct number of files $desc" );
-
+
my $i = 0;
for my $name ( @names ) {
ok( 1, " Inspecting '$name' $desc" );
like($name, $expect[$i]," Matches $Expect[$i] $desc" );
$i++;
- }
+ }
};
### do a full test vs individual filters
} else {
@expect = @Expect;
$dotest->("all");
- }
+ }
}
plan 'no_plan';
my $Class = 'Archive::Tar';
-my $Dir = File::Spec->catdir( qw[src linktest] );
+my $Dir = File::Spec->catdir( qw[src linktest] );
my %Map = (
File::Spec->catfile( $Dir, "linktest_with_dir.tar" ) => [
[ 0, qr/SECURE EXTRACT MODE/ ],
### damn warnings
local $Archive::Tar::INSECURE_EXTRACT_MODE = $mode;
local $Archive::Tar::INSECURE_EXTRACT_MODE = $mode;
-
+
ok( 1, " Extracting with insecure mode: $mode" );
my $warning;
ok( !$@, " No fatal error" );
is( !!$rv, !!$expect, " RV as expected" );
like( $warning, $regex, " Error matches $regex" );
-
+
rmtree( 'linktest' );
}
- }
-}
+ }
+}
eval 'use Test::Pod';
plan skip_all => "Test::Pod v0.95 required for testing POD"
if $@ || $Test::Pod::VERSION < 0.95;
-
-plan skip_all => "Pod tests disabled under perl core" if $ENV{PERL_CORE};
+
+plan skip_all => "Pod tests disabled under perl core" if $ENV{PERL_CORE};
my @files;
find( sub { push @files, File::Spec->catfile(
=item *
+L<Archive::Tar> has been upgraded from version 1.76 to version 1.78.
+
+=item *
+
L<CPANPLUS> has been upgraded from version 0.9109 to version 0.9110.
=item *
projects / platform / upstream / perl.git / commitdiff