view release on metacpan or  search on metacpan

lib/File/Path.pm  view on Meta::CPAN

            owner
            uid
            user
            verbose
        | );
        my %not_on_win32_args = map { $_ => 1 } ( qw|
            group
            owner
            uid
            user
        | );
        my @bad_args = ();
        my @win32_implausible_args = ();
        my $arg = pop @_;
        for my $k (sort keys %{$arg}) {
            if (! $args_permitted{$k}) {
                push @bad_args, $k;
            }
            elsif ($not_on_win32_args{$k} and _IS_MSWIN32) {
                push @win32_implausible_args, $k;
            }
            else {
                $data->{$k} = $arg->{$k};
            }
        }
        _carp("Unrecognized option(s) passed to mkpath() or make_path(): @bad_args")
            if @bad_args;
        _carp("Option(s) implausible on Win32 passed to mkpath() or make_path(): @win32_implausible_args")
            if @win32_implausible_args;
        $data->{mode} = delete $data->{mask} if exists $data->{mask};
        $data->{mode} = oct '777' unless exists $data->{mode};
        ${ $data->{error} } = [] if exists $data->{error};
        unless (@win32_implausible_args) {
            $data->{owner} = delete $data->{user} if exists $data->{user};
            $data->{owner} = delete $data->{uid}  if exists $data->{uid};
            if ( exists $data->{owner} and $data->{owner} =~ /\D/ ) {
                my $uid = ( getpwnam $data->{owner} )[2];
                if ( defined $uid ) {
                    $data->{owner} = $uid;
                }
                else {
                    _error( $data,
                            "unable to map $data->{owner} to a uid, ownership not changed"
                          );
                    delete $data->{owner};
                }
            }
            if ( exists $data->{group} and $data->{group} =~ /\D/ ) {
                my $gid = ( getgrnam $data->{group} )[2];
                if ( defined $gid ) {
                    $data->{group} = $gid;
                }
                else {
                    _error( $data,
                            "unable to map $data->{group} to a gid, group ownership not changed"
                    );
                    delete $data->{group};
                }
            }
            if ( exists $data->{owner} and not exists $data->{group} ) {
                $data->{group} = -1;    # chown will leave group unchanged
            }
            if ( exists $data->{group} and not exists $data->{owner} ) {
                $data->{owner} = -1;    # chown will leave owner unchanged
            }
        }
        $paths = [@_];
    }
    return _mkpath( $data, $paths );
}

sub _mkpath {
    my $data   = shift;
    my $paths = shift;

    my ( @created );
    foreach my $path ( @{$paths} ) {
        next unless defined($path) and length($path);
        $path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT

        # Logic wants Unix paths, so go with the flow.
        if (_IS_VMS) {
            next if $path eq '/';
            $path = VMS::Filespec::unixify($path);
        }
        next if -d $path;
        my $parent = File::Basename::dirname($path);
        # Coverage note:  It's not clear how we would test the condition:
        # '-d $parent or $path eq $parent'
        unless ( -d $parent or $path eq $parent ) {
            push( @created, _mkpath( $data, [$parent] ) );
        }
        print "mkdir $path\n" if $data->{verbose};
        if ( mkdir( $path, $data->{mode} ) ) {
            push( @created, $path );
            if ( exists $data->{owner} ) {

                # NB: $data->{group} guaranteed to be set during initialisation
                if ( !chown $data->{owner}, $data->{group}, $path ) {
                    _error( $data,
                        "Cannot change ownership of $path to $data->{owner}:$data->{group}"
                    );
                }
            }
            if ( exists $data->{chmod} ) {
                # Coverage note:  It's not clear how we would trigger the next
                # 'if' block.  Failure of 'chmod' might first result in a
                # system error: "Permission denied".
                if ( !chmod $data->{chmod}, $path ) {
                    _error( $data,
                        "Cannot change permissions of $path to $data->{chmod}" );
                }
            }
        }
        else {
            my $save_bang = $!;

            # From 'perldoc perlvar': $EXTENDED_OS_ERROR ($^E) is documented
            # as:
            # Error information specific to the current operating system. At the
            # moment, this differs from "$!" under only VMS, OS/2, and Win32
            # (and for MacPerl). On all other platforms, $^E is always just the
            # same as $!.

            my ( $e, $e1 ) = ( $save_bang, $^E );
            $e .= "; $e1" if $e ne $e1;

            # allow for another process to have created it meanwhile
            if ( ! -d $path ) {
                $! = $save_bang;
                if ( $data->{error} ) {
                    push @{ ${ $data->{error} } }, { $path => $e };
                }
                else {
                    _croak("mkdir $path: $e");
                }
            }
        }
    }
    return @created;
}

sub remove_tree {
    push @_, {} unless @_ and __is_arg( $_[-1] );
    goto &rmtree;
}

sub _is_subdir {
    my ( $dir, $test ) = @_;

    my ( $dv, $dd ) = File::Spec->splitpath( $dir,  1 );
    my ( $tv, $td ) = File::Spec->splitpath( $test, 1 );

    # not on same volume
    return 0 if $dv ne $tv;

    my @d = File::Spec->splitdir($dd);
    my @t = File::Spec->splitdir($td);