CPANPLUS

 view release on metacpan or  search on metacpan

inc/bundle/Archive/Extract.pm  view on Meta::CPAN

                return $self->_error(loc("Unable to read '%1': %2",
                            $self->archive, $Archive::Tar::error));
            }

            ### workaround to prevent Archive::Tar from setting uid, which
            ### is a potential security hole. -autrijus
            ### have to do it here, since A::T needs to be /loaded/ first ###
            {   no strict 'refs'; local $^W;

                ### older versions of archive::tar <= 0.23
                *Archive::Tar::chown = sub {};
            }

            {   local $^W;  # quell 'splice() offset past end of array' warnings
                            # on older versions of A::T

                ### older archive::tar always returns $self, return value
                ### slightly fux0r3d because of it.
                $tar->extract or return $self->_error(loc(
                        "Unable to extract '%1': %2",
                        $self->archive, $Archive::Tar::error ));

inc/bundle/Archive/Tar.pm  view on Meta::CPAN

    use Archive::Tar;
    my $tar = Archive::Tar->new;

    $tar->read('origin.tgz');
    $tar->extract();

    $tar->add_files('file/foo.pl', 'docs/README');
    $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->chmod('/tmp', '1777');

    $tar->write('files.tar');                   # plain tar
    $tar->write('files.tgz', COMPRESS_GZIP);    # gzip compressed
    $tar->write('files.tbz', COMPRESS_BZIP);    # bzip2 compressed
    $tar->write('files.txz', COMPRESS_XZ);      # xz compressed

=head1 DESCRIPTION

Archive::Tar provides an object oriented mechanism for handling tar

inc/bundle/Archive/Tar.pm  view on Meta::CPAN

    }

    unless ( -d _ ) {
        eval { File::Path::mkpath( $dir, 0, 0777 ) };
        if( $@ ) {
            my $fp = $entry->full_path;
            $self->_error(qq[Could not create directory '$dir' for '$fp': $@]);
            return;
        }

        ### XXX chown here? that might not be the same as in the archive
        ### as we're only chown'ing to the owner of the file we're extracting
        ### not to the owner of the directory itself, which may or may not
        ### be another entry in the archive
        ### Answer: no, gnu tar doesn't do it either, it'd be the wrong
        ### way to go.
        #if( $CHOWN && CAN_CHOWN ) {
        #    chown $entry->uid, $entry->gid, $dir or
        #        $self->_error( qq[Could not set uid/gid on '$dir'] );
        #}
    }

    ### we're done if we just needed to create a dir ###
    return 1 if $entry->is_dir;

    my $full = File::Spec->catfile( $dir, $file );

    if( $entry->is_unknown ) {

inc/bundle/Archive/Tar.pm  view on Meta::CPAN

    ### only update the timestamp if it's not a symlink; that will change the
    ### timestamp of the original. This addresses bug #33669: Could not update
    ### timestamp warning on symlinks
    if( not -l $full ) {
        utime time, $entry->mtime - TIME_OFFSET, $full or
            $self->_error( qq[Could not update timestamp] );
    }

    if( $CHOWN && CAN_CHOWN->() and not -l $full ) {
        CORE::chown( $entry->uid, $entry->gid, $full ) or
            $self->_error( qq[Could not set uid/gid on '$full'] );
    }

    ### only chmod if we're allowed to, but never chmod symlinks, since they'll
    ### change the perms on the file they're linking too...
    if( $CHMOD and not -l $full ) {
        my $mode = $entry->mode;
        unless ($SAME_PERMISSIONS) {
            $mode &= ~(oct(7000) | umask);
        }
        CORE::chmod( $mode, $full ) or
            $self->_error( qq[Could not chown '$full' to ] . $entry->mode );
    }

    return 1;
}

sub _make_special_file {
    my $self    = shift;
    my $entry   = shift     or return;
    my $file    = shift;    return unless defined $file;

inc/bundle/Archive/Tar.pm  view on Meta::CPAN

    my $self = shift;
    my $file = shift; return unless defined $file;
    my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
    my @args = ("$mode");

    my $entry = $self->_find_entry( $file ) or return;
    my $x = $entry->chmod( @args );
    return $x;
}

=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
from the in-memory archive. Returns a list of C<Archive::Tar::File>
objects that remain.

=cut

inc/bundle/Archive/Tar.pm  view on Meta::CPAN

means the symlink stays intact. Of course, you will have to pack the
file linked to as well.

This option is checked when you write out the tarfile using C<write>
or C<create_archive>.

This works just like C</bin/tar>'s C<-h> option.

=head2 $Archive::Tar::CHOWN

By default, C<Archive::Tar> will try to C<chown> your files if it is
able to. In some cases, this may not be desired. In that case, set
this variable to C<0> to disable C<chown>-ing, even if it were
possible.

The default is C<1>.

=head2 $Archive::Tar::CHMOD

By default, C<Archive::Tar> will try to C<chmod> your files to
whatever mode was specified for the particular file in the archive.
In some cases, this may not be desired. In that case, set this
variable to C<0> to disable C<chmod>-ing.

inc/bundle/Archive/Tar/File.pm  view on Meta::CPAN

=cut

sub chmod {
    my $self  = shift;
    my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
    $self->{mode} = oct($mode);
    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;
    }