view release on metacpan or  search on metacpan

lib/Archive/Tar.pm  view on Meta::CPAN

                                                    # straight from the tarball

        if( not defined $alt            and
            not $INSECURE_EXTRACT_MODE
        ) {

            ### paths that leave the current directory are not allowed under
            ### strict mode, so only allow it if a user tells us to do this.
            if( grep { $_ eq '..' } @dirs ) {

                $self->_error(
                    q[Entry ']. $entry->full_path .q[' is attempting to leave ].
                    q[the current working directory. Not extracting under ].
                    q[SECURE EXTRACT MODE]
                );
                return;
            }

            ### the archive may be asking us to extract into a symlink. This
            ### is not sane and a possible security issue, as outlined here:
            ### https://rt.cpan.org/Ticket/Display.html?id=30380
            ### https://bugzilla.redhat.com/show_bug.cgi?id=295021
            ### https://issues.rpath.com/browse/RPL-1716
            my $full_path = $cwd;
            for my $d ( @dirs ) {
                $full_path = File::Spec->catdir( $full_path, $d );

                ### we've already checked this one, and it's safe. Move on.
                next if ref $self and $self->{_link_cache}->{$full_path};

                if( -l $full_path ) {
                    my $to   = readlink $full_path;
                    my $diag = "symlinked directory ($full_path => $to)";

                    $self->_error(
                        q[Entry ']. $entry->full_path .q[' is attempting to ].
                        qq[extract to a $diag. This is considered a security ].
                        q[vulnerability and not allowed under SECURE EXTRACT ].
                        q[MODE]
                    );
                    return;
                }

                ### XXX keep a cache if possible, so the stats become cheaper:
                $self->{_link_cache}->{$full_path} = 1 if ref $self;
            }
        }

        ### '.' is the directory delimiter on VMS, which has to be escaped
        ### or changed to '_' on vms.  vmsify is used, because older versions
        ### of vmspath do not handle this properly.
        ### Must not add a '/' to an empty directory though.
        map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS;

        my ($cwd_vol,$cwd_dir,$cwd_file)
                    = File::Spec->splitpath( $cwd );
        my @cwd     = File::Spec->splitdir( $cwd_dir );
        push @cwd, $cwd_file if length $cwd_file;

        ### We need to pass '' as the last element to catpath. Craig Berry
        ### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>):
        ### The root problem is that splitpath on UNIX always returns the
        ### final path element as a file even if it is a directory, and of
        ### course there is no way it can know the difference without checking
        ### against the filesystem, which it is documented as not doing.  When
        ### you turn around and call catpath, on VMS you have to know which bits
        ### are directory bits and which bits are file bits.  In this case we
        ### know the result should be a directory.  I had thought you could omit
        ### the file argument to catpath in such a case, but apparently on UNIX
        ### you can't.
        $dir        = File::Spec->catpath(
                            $cwd_vol, File::Spec->catdir( @cwd, @dirs ), ''
                        );

        ### catdir() returns undef if the path is longer than 255 chars on
        ### older VMS systems.
        unless ( defined $dir ) {
            $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
            return;
        }

    }

    if( -e $dir && !-d _ ) {
        $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] );
        return;
    }

    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 ) {
        $self->_error( qq[Unknown file type for file '$full'] );
        return;
    }

    ### If a file system already contains a block device with the same name as
    ### the being extracted regular file, we would write the file's content
    ### to the block device. So remove the existing file (block device) now.