EVERYTHING FROM THE OTHER REPO
This commit is contained in:
@@ -0,0 +1,210 @@
|
||||
package File::Basename;
|
||||
|
||||
# File::Basename is used during the Perl build, when the re extension may
|
||||
# not be available, but we only actually need it if running under tainting.
|
||||
BEGIN {
|
||||
if (${^TAINT}) {
|
||||
require re;
|
||||
re->import('taint');
|
||||
}
|
||||
}
|
||||
|
||||
use strict;
|
||||
use 5.006;
|
||||
use warnings;
|
||||
our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
|
||||
$VERSION = "2.86";
|
||||
|
||||
fileparse_set_fstype($^O);
|
||||
|
||||
sub fileparse {
|
||||
my($fullname,@suffices) = @_;
|
||||
|
||||
unless (defined $fullname) {
|
||||
require Carp;
|
||||
Carp::croak("fileparse(): need a valid pathname");
|
||||
}
|
||||
|
||||
my $orig_type = '';
|
||||
my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
|
||||
|
||||
my($taint) = substr($fullname,0,0); # Is $fullname tainted?
|
||||
|
||||
if ($type eq "VMS" and $fullname =~ m{/} ) {
|
||||
# We're doing Unix emulation
|
||||
$orig_type = $type;
|
||||
$type = 'Unix';
|
||||
}
|
||||
|
||||
my($dirpath, $basename);
|
||||
|
||||
if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
|
||||
($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
|
||||
$dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
|
||||
}
|
||||
elsif ($type eq "OS2") {
|
||||
($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
|
||||
$dirpath = './' unless $dirpath; # Can't be 0
|
||||
$dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
|
||||
}
|
||||
elsif ($type eq "MacOS") {
|
||||
($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
|
||||
$dirpath = ':' unless $dirpath;
|
||||
}
|
||||
elsif ($type eq "AmigaOS") {
|
||||
($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
|
||||
$dirpath = './' unless $dirpath;
|
||||
}
|
||||
elsif ($type eq 'VMS' ) {
|
||||
($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
|
||||
$dirpath ||= ''; # should always be defined
|
||||
}
|
||||
else { # Default to Unix semantics.
|
||||
($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s);
|
||||
if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) {
|
||||
# dev:[000000] is top of VMS tree, similar to Unix '/'
|
||||
# so strip it off and treat the rest as "normal"
|
||||
my $devspec = $1;
|
||||
my $remainder = $3;
|
||||
($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s);
|
||||
$dirpath ||= ''; # should always be defined
|
||||
$dirpath = $devspec.$dirpath;
|
||||
}
|
||||
$dirpath = './' unless $dirpath;
|
||||
}
|
||||
|
||||
|
||||
my $tail = '';
|
||||
my $suffix = '';
|
||||
if (@suffices) {
|
||||
foreach $suffix (@suffices) {
|
||||
my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
|
||||
if ($basename =~ s/$pat//s) {
|
||||
$taint .= substr($suffix,0,0);
|
||||
$tail = $1 . $tail;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Ensure taint is propagated from the path to its pieces.
|
||||
$tail .= $taint;
|
||||
wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
|
||||
: ($basename .= $taint);
|
||||
}
|
||||
|
||||
sub basename {
|
||||
my($path) = shift;
|
||||
|
||||
# From BSD basename(1)
|
||||
# The basename utility deletes any prefix ending with the last slash '/'
|
||||
# character present in string (after first stripping trailing slashes)
|
||||
_strip_trailing_sep($path);
|
||||
|
||||
my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) );
|
||||
|
||||
# From BSD basename(1)
|
||||
# The suffix is not stripped if it is identical to the remaining
|
||||
# characters in string.
|
||||
if( length $suffix and !length $basename ) {
|
||||
$basename = $suffix;
|
||||
}
|
||||
|
||||
# Ensure that basename '/' == '/'
|
||||
if( !length $basename ) {
|
||||
$basename = $dirname;
|
||||
}
|
||||
|
||||
return $basename;
|
||||
}
|
||||
|
||||
sub dirname {
|
||||
my $path = shift;
|
||||
|
||||
my($type) = $Fileparse_fstype;
|
||||
|
||||
if( $type eq 'VMS' and $path =~ m{/} ) {
|
||||
# Parse as Unix
|
||||
local($File::Basename::Fileparse_fstype) = '';
|
||||
return dirname($path);
|
||||
}
|
||||
|
||||
my($basename, $dirname) = fileparse($path);
|
||||
|
||||
if ($type eq 'VMS') {
|
||||
$dirname ||= $ENV{DEFAULT};
|
||||
}
|
||||
elsif ($type eq 'MacOS') {
|
||||
if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
|
||||
_strip_trailing_sep($dirname);
|
||||
($basename,$dirname) = fileparse $dirname;
|
||||
}
|
||||
$dirname .= ":" unless $dirname =~ /:\z/;
|
||||
}
|
||||
elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
|
||||
_strip_trailing_sep($dirname);
|
||||
unless( length($basename) ) {
|
||||
($basename,$dirname) = fileparse $dirname;
|
||||
_strip_trailing_sep($dirname);
|
||||
}
|
||||
}
|
||||
elsif ($type eq 'AmigaOS') {
|
||||
if ( $dirname =~ /:\z/) { return $dirname }
|
||||
chop $dirname;
|
||||
$dirname =~ s{[^:/]+\z}{} unless length($basename);
|
||||
}
|
||||
else {
|
||||
_strip_trailing_sep($dirname);
|
||||
unless( length($basename) ) {
|
||||
($basename,$dirname) = fileparse $dirname;
|
||||
_strip_trailing_sep($dirname);
|
||||
}
|
||||
}
|
||||
|
||||
$dirname;
|
||||
}
|
||||
|
||||
# Strip the trailing path separator.
|
||||
sub _strip_trailing_sep {
|
||||
my $type = $Fileparse_fstype;
|
||||
|
||||
if ($type eq 'MacOS') {
|
||||
$_[0] =~ s/([^:]):\z/$1/s;
|
||||
}
|
||||
elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
|
||||
$_[0] =~ s/([^:])[\\\/]*\z/$1/;
|
||||
}
|
||||
else {
|
||||
$_[0] =~ s{(.)/*\z}{$1}s;
|
||||
}
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
|
||||
my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
|
||||
my @Types = (@Ignore_Case, qw(Unix));
|
||||
|
||||
sub fileparse_set_fstype {
|
||||
my $old = $Fileparse_fstype;
|
||||
|
||||
if (@_) {
|
||||
my $new_type = shift;
|
||||
|
||||
$Fileparse_fstype = 'Unix'; # default
|
||||
foreach my $type (@Types) {
|
||||
$Fileparse_fstype = $type if $new_type =~ /^$type/i;
|
||||
}
|
||||
|
||||
$Fileparse_igncase =
|
||||
(grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
|
||||
}
|
||||
|
||||
return $old;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,73 @@
|
||||
package File::Glob;
|
||||
|
||||
use strict;
|
||||
our($DEFAULT_FLAGS);
|
||||
|
||||
require XSLoader;
|
||||
|
||||
# NOTE: The glob() export is only here for compatibility with 5.6.0.
|
||||
# csh_glob() should not be used directly, unless you know what you're doing.
|
||||
|
||||
our %EXPORT_TAGS = (
|
||||
'glob' => [ qw(
|
||||
GLOB_ABEND
|
||||
GLOB_ALPHASORT
|
||||
GLOB_ALTDIRFUNC
|
||||
GLOB_BRACE
|
||||
GLOB_CSH
|
||||
GLOB_ERR
|
||||
GLOB_ERROR
|
||||
GLOB_LIMIT
|
||||
GLOB_MARK
|
||||
GLOB_NOCASE
|
||||
GLOB_NOCHECK
|
||||
GLOB_NOMAGIC
|
||||
GLOB_NOSORT
|
||||
GLOB_NOSPACE
|
||||
GLOB_QUOTE
|
||||
GLOB_TILDE
|
||||
bsd_glob
|
||||
) ],
|
||||
);
|
||||
$EXPORT_TAGS{bsd_glob} = [@{$EXPORT_TAGS{glob}}];
|
||||
|
||||
our @EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
|
||||
|
||||
our $VERSION = '1.42';
|
||||
|
||||
sub import {
|
||||
require Exporter;
|
||||
local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
|
||||
Exporter::import(grep {
|
||||
my $passthrough;
|
||||
if ($_ eq ':case') {
|
||||
$DEFAULT_FLAGS &= ~GLOB_NOCASE()
|
||||
}
|
||||
elsif ($_ eq ':nocase') {
|
||||
$DEFAULT_FLAGS |= GLOB_NOCASE();
|
||||
}
|
||||
elsif ($_ eq ':globally') {
|
||||
no warnings 'redefine';
|
||||
*CORE::GLOBAL::glob = \&File::Glob::csh_glob;
|
||||
}
|
||||
elsif ($_ eq ':bsd_glob') {
|
||||
no strict; *{caller."::glob"} = \&bsd_glob_override;
|
||||
$passthrough = 1;
|
||||
}
|
||||
else {
|
||||
$passthrough = 1;
|
||||
}
|
||||
$passthrough;
|
||||
} @_);
|
||||
}
|
||||
|
||||
XSLoader::load();
|
||||
|
||||
$DEFAULT_FLAGS = GLOB_CSH();
|
||||
if ($^O =~ /^(?:MSWin32|VMS|os2|riscos)$/) {
|
||||
$DEFAULT_FLAGS |= GLOB_NOCASE();
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
@@ -0,0 +1,629 @@
|
||||
package File::Path;
|
||||
|
||||
use 5.005_04;
|
||||
use strict;
|
||||
|
||||
use Cwd 'getcwd';
|
||||
use File::Basename ();
|
||||
use File::Spec ();
|
||||
|
||||
BEGIN {
|
||||
if ( $] < 5.006 ) {
|
||||
|
||||
# can't say 'opendir my $dh, $dirname'
|
||||
# need to initialise $dh
|
||||
eval 'use Symbol';
|
||||
}
|
||||
}
|
||||
|
||||
use Exporter ();
|
||||
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
|
||||
$VERSION = '2.18';
|
||||
$VERSION = eval $VERSION;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(mkpath rmtree);
|
||||
@EXPORT_OK = qw(make_path remove_tree);
|
||||
|
||||
BEGIN {
|
||||
for (qw(VMS MacOS MSWin32 os2)) {
|
||||
no strict 'refs';
|
||||
*{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 };
|
||||
}
|
||||
|
||||
# These OSes complain if you want to remove a file that you have no
|
||||
# write permission to:
|
||||
*_FORCE_WRITABLE = (
|
||||
grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2)
|
||||
) ? sub () { 1 } : sub () { 0 };
|
||||
|
||||
# Unix-like systems need to stat each directory in order to detect
|
||||
# race condition. MS-Windows is immune to this particular attack.
|
||||
*_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 };
|
||||
}
|
||||
|
||||
sub _carp {
|
||||
require Carp;
|
||||
goto &Carp::carp;
|
||||
}
|
||||
|
||||
sub _croak {
|
||||
require Carp;
|
||||
goto &Carp::croak;
|
||||
}
|
||||
|
||||
sub _error {
|
||||
my $arg = shift;
|
||||
my $message = shift;
|
||||
my $object = shift;
|
||||
|
||||
if ( $arg->{error} ) {
|
||||
$object = '' unless defined $object;
|
||||
$message .= ": $!" if $!;
|
||||
push @{ ${ $arg->{error} } }, { $object => $message };
|
||||
}
|
||||
else {
|
||||
_carp( defined($object) ? "$message for $object: $!" : "$message: $!" );
|
||||
}
|
||||
}
|
||||
|
||||
sub __is_arg {
|
||||
my ($arg) = @_;
|
||||
|
||||
# If client code blessed an array ref to HASH, this will not work
|
||||
# properly. We could have done $arg->isa() wrapped in eval, but
|
||||
# that would be expensive. This implementation should suffice.
|
||||
# We could have also used Scalar::Util:blessed, but we choose not
|
||||
# to add this dependency
|
||||
return ( ref $arg eq 'HASH' );
|
||||
}
|
||||
|
||||
sub make_path {
|
||||
push @_, {} unless @_ and __is_arg( $_[-1] );
|
||||
goto &mkpath;
|
||||
}
|
||||
|
||||
sub mkpath {
|
||||
my $old_style = !( @_ and __is_arg( $_[-1] ) );
|
||||
|
||||
my $data;
|
||||
my $paths;
|
||||
|
||||
if ($old_style) {
|
||||
my ( $verbose, $mode );
|
||||
( $paths, $verbose, $mode ) = @_;
|
||||
$paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
|
||||
$data->{verbose} = $verbose;
|
||||
$data->{mode} = defined $mode ? $mode : oct '777';
|
||||
}
|
||||
else {
|
||||
my %args_permitted = map { $_ => 1 } ( qw|
|
||||
chmod
|
||||
error
|
||||
group
|
||||
mask
|
||||
mode
|
||||
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);
|
||||
|
||||
# @t can't be a subdir if it's shorter than @d
|
||||
return 0 if @t < @d;
|
||||
|
||||
return join( '/', @d ) eq join( '/', splice @t, 0, +@d );
|
||||
}
|
||||
|
||||
sub rmtree {
|
||||
my $old_style = !( @_ and __is_arg( $_[-1] ) );
|
||||
|
||||
my ($arg, $data, $paths);
|
||||
|
||||
if ($old_style) {
|
||||
my ( $verbose, $safe );
|
||||
( $paths, $verbose, $safe ) = @_;
|
||||
$data->{verbose} = $verbose;
|
||||
$data->{safe} = defined $safe ? $safe : 0;
|
||||
|
||||
if ( defined($paths) and length($paths) ) {
|
||||
$paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
|
||||
}
|
||||
else {
|
||||
_carp("No root path(s) specified\n");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my %args_permitted = map { $_ => 1 } ( qw|
|
||||
error
|
||||
keep_root
|
||||
result
|
||||
safe
|
||||
verbose
|
||||
| );
|
||||
my @bad_args = ();
|
||||
my $arg = pop @_;
|
||||
for my $k (sort keys %{$arg}) {
|
||||
if (! $args_permitted{$k}) {
|
||||
push @bad_args, $k;
|
||||
}
|
||||
else {
|
||||
$data->{$k} = $arg->{$k};
|
||||
}
|
||||
}
|
||||
_carp("Unrecognized option(s) passed to remove_tree(): @bad_args")
|
||||
if @bad_args;
|
||||
${ $data->{error} } = [] if exists $data->{error};
|
||||
${ $data->{result} } = [] if exists $data->{result};
|
||||
|
||||
# Wouldn't it make sense to do some validation on @_ before assigning
|
||||
# to $paths here?
|
||||
# In the $old_style case we guarantee that each path is both defined
|
||||
# and non-empty. We don't check that here, which means we have to
|
||||
# check it later in the first condition in this line:
|
||||
# if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
|
||||
# Granted, that would be a change in behavior for the two
|
||||
# non-old-style interfaces.
|
||||
|
||||
$paths = [@_];
|
||||
}
|
||||
|
||||
$data->{prefix} = '';
|
||||
$data->{depth} = 0;
|
||||
|
||||
my @clean_path;
|
||||
$data->{cwd} = getcwd() or do {
|
||||
_error( $data, "cannot fetch initial working directory" );
|
||||
return 0;
|
||||
};
|
||||
for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint
|
||||
|
||||
for my $p (@$paths) {
|
||||
|
||||
# need to fixup case and map \ to / on Windows
|
||||
my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p;
|
||||
my $ortho_cwd =
|
||||
_IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd};
|
||||
my $ortho_root_length = length($ortho_root);
|
||||
$ortho_root_length-- if _IS_VMS; # don't compare '.' with ']'
|
||||
if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
|
||||
local $! = 0;
|
||||
_error( $data, "cannot remove path when cwd is $data->{cwd}", $p );
|
||||
next;
|
||||
}
|
||||
|
||||
if (_IS_MACOS) {
|
||||
$p = ":$p" unless $p =~ /:/;
|
||||
$p .= ":" unless $p =~ /:\z/;
|
||||
}
|
||||
elsif ( _IS_MSWIN32 ) {
|
||||
$p =~ s{[/\\]\z}{};
|
||||
}
|
||||
else {
|
||||
$p =~ s{/\z}{};
|
||||
}
|
||||
push @clean_path, $p;
|
||||
}
|
||||
|
||||
@{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do {
|
||||
_error( $data, "cannot stat initial working directory", $data->{cwd} );
|
||||
return 0;
|
||||
};
|
||||
|
||||
return _rmtree( $data, \@clean_path );
|
||||
}
|
||||
|
||||
sub _rmtree {
|
||||
my $data = shift;
|
||||
my $paths = shift;
|
||||
|
||||
my $count = 0;
|
||||
my $curdir = File::Spec->curdir();
|
||||
my $updir = File::Spec->updir();
|
||||
|
||||
my ( @files, $root );
|
||||
ROOT_DIR:
|
||||
foreach my $root (@$paths) {
|
||||
|
||||
# since we chdir into each directory, it may not be obvious
|
||||
# to figure out where we are if we generate a message about
|
||||
# a file name. We therefore construct a semi-canonical
|
||||
# filename, anchored from the directory being unlinked (as
|
||||
# opposed to being truly canonical, anchored from the root (/).
|
||||
|
||||
my $canon =
|
||||
$data->{prefix}
|
||||
? File::Spec->catfile( $data->{prefix}, $root )
|
||||
: $root;
|
||||
|
||||
my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
|
||||
or next ROOT_DIR;
|
||||
|
||||
if ( -d _ ) {
|
||||
$root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) )
|
||||
if _IS_VMS;
|
||||
|
||||
if ( !chdir($root) ) {
|
||||
|
||||
# see if we can escalate privileges to get in
|
||||
# (e.g. funny protection mask such as -w- instead of rwx)
|
||||
# This uses fchmod to avoid traversing outside of the proper
|
||||
# location (CVE-2017-6512)
|
||||
my $root_fh;
|
||||
if (open($root_fh, '<', $root)) {
|
||||
my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1];
|
||||
$perm &= oct '7777';
|
||||
my $nperm = $perm | oct '700';
|
||||
local $@;
|
||||
if (
|
||||
!(
|
||||
$data->{safe}
|
||||
or $nperm == $perm
|
||||
or !-d _
|
||||
or $fh_dev ne $ldev
|
||||
or $fh_inode ne $lino
|
||||
or eval { chmod( $nperm, $root_fh ) }
|
||||
)
|
||||
)
|
||||
{
|
||||
_error( $data,
|
||||
"cannot make child directory read-write-exec", $canon );
|
||||
next ROOT_DIR;
|
||||
}
|
||||
close $root_fh;
|
||||
}
|
||||
if ( !chdir($root) ) {
|
||||
_error( $data, "cannot chdir to child", $canon );
|
||||
next ROOT_DIR;
|
||||
}
|
||||
}
|
||||
|
||||
my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ]
|
||||
or do {
|
||||
_error( $data, "cannot stat current working directory", $canon );
|
||||
next ROOT_DIR;
|
||||
};
|
||||
|
||||
if (_NEED_STAT_CHECK) {
|
||||
( $ldev eq $cur_dev and $lino eq $cur_inode )
|
||||
or _croak(
|
||||
"directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."
|
||||
);
|
||||
}
|
||||
|
||||
$perm &= oct '7777'; # don't forget setuid, setgid, sticky bits
|
||||
my $nperm = $perm | oct '700';
|
||||
|
||||
# notabene: 0700 is for making readable in the first place,
|
||||
# it's also intended to change it to writable in case we have
|
||||
# to recurse in which case we are better than rm -rf for
|
||||
# subtrees with strange permissions
|
||||
|
||||
if (
|
||||
!(
|
||||
$data->{safe}
|
||||
or $nperm == $perm
|
||||
or chmod( $nperm, $curdir )
|
||||
)
|
||||
)
|
||||
{
|
||||
_error( $data, "cannot make directory read+writeable", $canon );
|
||||
$nperm = $perm;
|
||||
}
|
||||
|
||||
my $d;
|
||||
$d = gensym() if $] < 5.006;
|
||||
if ( !opendir $d, $curdir ) {
|
||||
_error( $data, "cannot opendir", $canon );
|
||||
@files = ();
|
||||
}
|
||||
else {
|
||||
if ( !defined ${^TAINT} or ${^TAINT} ) {
|
||||
# Blindly untaint dir names if taint mode is active
|
||||
@files = map { /\A(.*)\z/s; $1 } readdir $d;
|
||||
}
|
||||
else {
|
||||
@files = readdir $d;
|
||||
}
|
||||
closedir $d;
|
||||
}
|
||||
|
||||
if (_IS_VMS) {
|
||||
|
||||
# Deleting large numbers of files from VMS Files-11
|
||||
# filesystems is faster if done in reverse ASCIIbetical order.
|
||||
# include '.' to '.;' from blead patch #31775
|
||||
@files = map { $_ eq '.' ? '.;' : $_ } reverse @files;
|
||||
}
|
||||
|
||||
@files = grep { $_ ne $updir and $_ ne $curdir } @files;
|
||||
|
||||
if (@files) {
|
||||
|
||||
# remove the contained files before the directory itself
|
||||
my $narg = {%$data};
|
||||
@{$narg}{qw(device inode cwd prefix depth)} =
|
||||
( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 );
|
||||
$count += _rmtree( $narg, \@files );
|
||||
}
|
||||
|
||||
# restore directory permissions of required now (in case the rmdir
|
||||
# below fails), while we are still in the directory and may do so
|
||||
# without a race via '.'
|
||||
if ( $nperm != $perm and not chmod( $perm, $curdir ) ) {
|
||||
_error( $data, "cannot reset chmod", $canon );
|
||||
}
|
||||
|
||||
# don't leave the client code in an unexpected directory
|
||||
chdir( $data->{cwd} )
|
||||
or
|
||||
_croak("cannot chdir to $data->{cwd} from $canon: $!, aborting.");
|
||||
|
||||
# ensure that a chdir upwards didn't take us somewhere other
|
||||
# than we expected (see CVE-2002-0435)
|
||||
( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ]
|
||||
or _croak(
|
||||
"cannot stat prior working directory $data->{cwd}: $!, aborting."
|
||||
);
|
||||
|
||||
if (_NEED_STAT_CHECK) {
|
||||
( $data->{device} eq $cur_dev and $data->{inode} eq $cur_inode )
|
||||
or _croak( "previous directory $data->{cwd} "
|
||||
. "changed before entering $canon, "
|
||||
. "expected dev=$ldev ino=$lino, "
|
||||
. "actual dev=$cur_dev ino=$cur_inode, aborting."
|
||||
);
|
||||
}
|
||||
|
||||
if ( $data->{depth} or !$data->{keep_root} ) {
|
||||
if ( $data->{safe}
|
||||
&& ( _IS_VMS
|
||||
? !&VMS::Filespec::candelete($root)
|
||||
: !-w $root ) )
|
||||
{
|
||||
print "skipped $root\n" if $data->{verbose};
|
||||
next ROOT_DIR;
|
||||
}
|
||||
if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) {
|
||||
_error( $data, "cannot make directory writeable", $canon );
|
||||
}
|
||||
print "rmdir $root\n" if $data->{verbose};
|
||||
if ( rmdir $root ) {
|
||||
push @{ ${ $data->{result} } }, $root if $data->{result};
|
||||
++$count;
|
||||
}
|
||||
else {
|
||||
_error( $data, "cannot remove directory", $canon );
|
||||
if (
|
||||
_FORCE_WRITABLE
|
||||
&& !chmod( $perm,
|
||||
( _IS_VMS ? VMS::Filespec::fileify($root) : $root )
|
||||
)
|
||||
)
|
||||
{
|
||||
_error(
|
||||
$data,
|
||||
sprintf( "cannot restore permissions to 0%o",
|
||||
$perm ),
|
||||
$canon
|
||||
);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
# not a directory
|
||||
$root = VMS::Filespec::vmsify("./$root")
|
||||
if _IS_VMS
|
||||
&& !File::Spec->file_name_is_absolute($root)
|
||||
&& ( $root !~ m/(?<!\^)[\]>]+/ ); # not already in VMS syntax
|
||||
|
||||
if (
|
||||
$data->{safe}
|
||||
&& (
|
||||
_IS_VMS
|
||||
? !&VMS::Filespec::candelete($root)
|
||||
: !( -l $root || -w $root )
|
||||
)
|
||||
)
|
||||
{
|
||||
print "skipped $root\n" if $data->{verbose};
|
||||
next ROOT_DIR;
|
||||
}
|
||||
|
||||
my $nperm = $perm & oct '7777' | oct '600';
|
||||
if ( _FORCE_WRITABLE
|
||||
and $nperm != $perm
|
||||
and not chmod $nperm, $root )
|
||||
{
|
||||
_error( $data, "cannot make file writeable", $canon );
|
||||
}
|
||||
print "unlink $canon\n" if $data->{verbose};
|
||||
|
||||
# delete all versions under VMS
|
||||
for ( ; ; ) {
|
||||
if ( unlink $root ) {
|
||||
push @{ ${ $data->{result} } }, $root if $data->{result};
|
||||
}
|
||||
else {
|
||||
_error( $data, "cannot unlink file", $canon );
|
||||
_FORCE_WRITABLE and chmod( $perm, $root )
|
||||
or _error( $data,
|
||||
sprintf( "cannot restore permissions to 0%o", $perm ),
|
||||
$canon );
|
||||
last;
|
||||
}
|
||||
++$count;
|
||||
last unless _IS_VMS && lstat $root;
|
||||
}
|
||||
}
|
||||
}
|
||||
return $count;
|
||||
}
|
||||
|
||||
sub _slash_lc {
|
||||
|
||||
# fix up slashes and case on MSWin32 so that we can determine that
|
||||
# c:\path\to\dir is underneath C:/Path/To
|
||||
my $path = shift;
|
||||
$path =~ tr{\\}{/};
|
||||
return lc($path);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
@@ -0,0 +1,28 @@
|
||||
package File::Spec;
|
||||
|
||||
use strict;
|
||||
|
||||
# Keep $VERSION consistent in all *.pm files in this distribution, including
|
||||
# Cwd.pm.
|
||||
our $VERSION = '3.91';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
my %module = (
|
||||
MSWin32 => 'Win32',
|
||||
os2 => 'OS2',
|
||||
VMS => 'VMS',
|
||||
NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
|
||||
symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
|
||||
dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP.
|
||||
cygwin => 'Cygwin',
|
||||
amigaos => 'AmigaOS');
|
||||
|
||||
my $module = $module{$^O} || 'Unix';
|
||||
|
||||
require "File/Spec/$module.pm";
|
||||
our @ISA = ("File::Spec::$module");
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
@@ -0,0 +1,319 @@
|
||||
package File::Spec::Unix;
|
||||
|
||||
use strict;
|
||||
use Cwd ();
|
||||
|
||||
our $VERSION = '3.91';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
sub _pp_canonpath {
|
||||
my ($self,$path) = @_;
|
||||
return unless defined $path;
|
||||
|
||||
# Handle POSIX-style node names beginning with double slash (qnx, nto)
|
||||
# (POSIX says: "a pathname that begins with two successive slashes
|
||||
# may be interpreted in an implementation-defined manner, although
|
||||
# more than two leading slashes shall be treated as a single slash.")
|
||||
my $node = '';
|
||||
my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
|
||||
|
||||
if ( $double_slashes_special
|
||||
&& ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
|
||||
$node = $1;
|
||||
}
|
||||
# This used to be
|
||||
# $path =~ s|/+|/|g unless ($^O eq 'cygwin');
|
||||
# but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
|
||||
# (Mainly because trailing "" directories didn't get stripped).
|
||||
# Why would cygwin avoid collapsing multiple slashes into one? --jhi
|
||||
$path =~ s|/{2,}|/|g; # xx////xx -> xx/xx
|
||||
$path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx
|
||||
$path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx
|
||||
$path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx
|
||||
$path =~ s|^/\.\.$|/|; # /.. -> /
|
||||
$path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx
|
||||
return "$node$path";
|
||||
}
|
||||
*canonpath = \&_pp_canonpath unless defined &canonpath;
|
||||
|
||||
sub _pp_catdir {
|
||||
my $self = shift;
|
||||
|
||||
$self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
|
||||
}
|
||||
*catdir = \&_pp_catdir unless defined &catdir;
|
||||
|
||||
sub _pp_catfile {
|
||||
my $self = shift;
|
||||
my $file = $self->canonpath(pop @_);
|
||||
return $file unless @_;
|
||||
my $dir = $self->catdir(@_);
|
||||
$dir .= "/" unless substr($dir,-1) eq "/";
|
||||
return $dir.$file;
|
||||
}
|
||||
*catfile = \&_pp_catfile unless defined &catfile;
|
||||
|
||||
sub curdir { '.' }
|
||||
use constant _fn_curdir => ".";
|
||||
|
||||
sub devnull { '/dev/null' }
|
||||
use constant _fn_devnull => "/dev/null";
|
||||
|
||||
sub rootdir { '/' }
|
||||
use constant _fn_rootdir => "/";
|
||||
|
||||
my ($tmpdir, %tmpenv);
|
||||
# Cache and return the calculated tmpdir, recording which env vars
|
||||
# determined it.
|
||||
sub _cache_tmpdir {
|
||||
@tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]};
|
||||
return $tmpdir = $_[1];
|
||||
}
|
||||
# Retrieve the cached tmpdir, checking first whether relevant env vars have
|
||||
# changed and invalidated the cache.
|
||||
sub _cached_tmpdir {
|
||||
shift;
|
||||
local $^W;
|
||||
return if grep $ENV{$_} ne $tmpenv{$_}, @_;
|
||||
return $tmpdir;
|
||||
}
|
||||
sub _tmpdir {
|
||||
my $self = shift;
|
||||
my @dirlist = @_;
|
||||
my $taint = do { no strict 'refs'; ${"\cTAINT"} };
|
||||
if ($taint) { # Check for taint mode on perl >= 5.8.0
|
||||
require Scalar::Util;
|
||||
@dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
|
||||
}
|
||||
elsif ($] < 5.007) { # No ${^TAINT} before 5.8
|
||||
@dirlist = grep { !defined($_) || eval { eval('1'.substr $_,0,0) } }
|
||||
@dirlist;
|
||||
}
|
||||
|
||||
foreach (@dirlist) {
|
||||
next unless defined && -d && -w _;
|
||||
$tmpdir = $_;
|
||||
last;
|
||||
}
|
||||
$tmpdir = $self->curdir unless defined $tmpdir;
|
||||
$tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
|
||||
if ( !$self->file_name_is_absolute($tmpdir) ) {
|
||||
# See [perl #120593] for the full details
|
||||
# If possible, return a full path, rather than '.' or 'lib', but
|
||||
# jump through some hoops to avoid returning a tainted value.
|
||||
($tmpdir) = grep {
|
||||
$taint ? ! Scalar::Util::tainted($_) :
|
||||
$] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1
|
||||
} $self->rel2abs($tmpdir), $tmpdir;
|
||||
}
|
||||
return $tmpdir;
|
||||
}
|
||||
|
||||
sub tmpdir {
|
||||
my $cached = $_[0]->_cached_tmpdir('TMPDIR');
|
||||
return $cached if defined $cached;
|
||||
$_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR');
|
||||
}
|
||||
|
||||
sub updir { '..' }
|
||||
use constant _fn_updir => "..";
|
||||
|
||||
sub no_upwards {
|
||||
my $self = shift;
|
||||
return grep(!/^\.{1,2}\z/s, @_);
|
||||
}
|
||||
|
||||
sub case_tolerant { 0 }
|
||||
use constant _fn_case_tolerant => 0;
|
||||
|
||||
sub file_name_is_absolute {
|
||||
my ($self,$file) = @_;
|
||||
return scalar($file =~ m:^/:s);
|
||||
}
|
||||
|
||||
sub path {
|
||||
return () unless exists $ENV{PATH};
|
||||
my @path = split(':', $ENV{PATH});
|
||||
foreach (@path) { $_ = '.' if $_ eq '' }
|
||||
return @path;
|
||||
}
|
||||
|
||||
sub join {
|
||||
my $self = shift;
|
||||
return $self->catfile(@_);
|
||||
}
|
||||
|
||||
sub splitpath {
|
||||
my ($self,$path, $nofile) = @_;
|
||||
|
||||
my ($volume,$directory,$file) = ('','','');
|
||||
|
||||
if ( $nofile ) {
|
||||
$directory = $path;
|
||||
}
|
||||
else {
|
||||
$path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
|
||||
$directory = $1;
|
||||
$file = $2;
|
||||
}
|
||||
|
||||
return ($volume,$directory,$file);
|
||||
}
|
||||
|
||||
sub splitdir {
|
||||
return split m|/|, $_[1], -1; # Preserve trailing fields
|
||||
}
|
||||
|
||||
sub catpath {
|
||||
my ($self,$volume,$directory,$file) = @_;
|
||||
|
||||
if ( $directory ne '' &&
|
||||
$file ne '' &&
|
||||
substr( $directory, -1 ) ne '/' &&
|
||||
substr( $file, 0, 1 ) ne '/'
|
||||
) {
|
||||
$directory .= "/$file" ;
|
||||
}
|
||||
else {
|
||||
$directory .= $file ;
|
||||
}
|
||||
|
||||
return $directory ;
|
||||
}
|
||||
|
||||
sub abs2rel {
|
||||
my($self,$path,$base) = @_;
|
||||
$base = Cwd::getcwd() unless defined $base and length $base;
|
||||
|
||||
($path, $base) = map $self->canonpath($_), $path, $base;
|
||||
|
||||
my $path_directories;
|
||||
my $base_directories;
|
||||
|
||||
if (grep $self->file_name_is_absolute($_), $path, $base) {
|
||||
($path, $base) = map $self->rel2abs($_), $path, $base;
|
||||
|
||||
my ($path_volume) = $self->splitpath($path, 1);
|
||||
my ($base_volume) = $self->splitpath($base, 1);
|
||||
|
||||
# Can't relativize across volumes
|
||||
return $path unless $path_volume eq $base_volume;
|
||||
|
||||
$path_directories = ($self->splitpath($path, 1))[1];
|
||||
$base_directories = ($self->splitpath($base, 1))[1];
|
||||
|
||||
# For UNC paths, the user might give a volume like //foo/bar that
|
||||
# strictly speaking has no directory portion. Treat it as if it
|
||||
# had the root directory for that volume.
|
||||
if (!length($base_directories) and $self->file_name_is_absolute($base)) {
|
||||
$base_directories = $self->rootdir;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $wd= ($self->splitpath(Cwd::getcwd(), 1))[1];
|
||||
$path_directories = $self->catdir($wd, $path);
|
||||
$base_directories = $self->catdir($wd, $base);
|
||||
}
|
||||
|
||||
# Now, remove all leading components that are the same
|
||||
my @pathchunks = $self->splitdir( $path_directories );
|
||||
my @basechunks = $self->splitdir( $base_directories );
|
||||
|
||||
if ($base_directories eq $self->rootdir) {
|
||||
return $self->curdir if $path_directories eq $self->rootdir;
|
||||
shift @pathchunks;
|
||||
return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
|
||||
}
|
||||
|
||||
my @common;
|
||||
while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
|
||||
push @common, shift @pathchunks ;
|
||||
shift @basechunks ;
|
||||
}
|
||||
return $self->curdir unless @pathchunks || @basechunks;
|
||||
|
||||
# @basechunks now contains the directories the resulting relative path
|
||||
# must ascend out of before it can descend to $path_directory. If there
|
||||
# are updir components, we must descend into the corresponding directories
|
||||
# (this only works if they are no symlinks).
|
||||
my @reverse_base;
|
||||
while( defined(my $dir= shift @basechunks) ) {
|
||||
if( $dir ne $self->updir ) {
|
||||
unshift @reverse_base, $self->updir;
|
||||
push @common, $dir;
|
||||
}
|
||||
elsif( @common ) {
|
||||
if( @reverse_base && $reverse_base[0] eq $self->updir ) {
|
||||
shift @reverse_base;
|
||||
pop @common;
|
||||
}
|
||||
else {
|
||||
unshift @reverse_base, pop @common;
|
||||
}
|
||||
}
|
||||
}
|
||||
my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
|
||||
return $self->canonpath( $self->catpath('', $result_dirs, '') );
|
||||
}
|
||||
|
||||
sub _same {
|
||||
$_[1] eq $_[2];
|
||||
}
|
||||
|
||||
sub rel2abs {
|
||||
my ($self,$path,$base ) = @_;
|
||||
|
||||
# Clean up $path
|
||||
if ( ! $self->file_name_is_absolute( $path ) ) {
|
||||
# Figure out the effective $base and clean it up.
|
||||
if ( !defined( $base ) || $base eq '' ) {
|
||||
$base = Cwd::getcwd();
|
||||
}
|
||||
elsif ( ! $self->file_name_is_absolute( $base ) ) {
|
||||
$base = $self->rel2abs( $base ) ;
|
||||
}
|
||||
else {
|
||||
$base = $self->canonpath( $base ) ;
|
||||
}
|
||||
|
||||
# Glom them together
|
||||
$path = $self->catdir( $base, $path ) ;
|
||||
}
|
||||
|
||||
return $self->canonpath( $path ) ;
|
||||
}
|
||||
|
||||
# Internal method to reduce xx\..\yy -> yy
|
||||
sub _collapse {
|
||||
my($fs, $path) = @_;
|
||||
|
||||
my $updir = $fs->updir;
|
||||
my $curdir = $fs->curdir;
|
||||
|
||||
my($vol, $dirs, $file) = $fs->splitpath($path);
|
||||
my @dirs = $fs->splitdir($dirs);
|
||||
pop @dirs if @dirs && $dirs[-1] eq '';
|
||||
|
||||
my @collapsed;
|
||||
foreach my $dir (@dirs) {
|
||||
if( $dir eq $updir and # if we have an updir
|
||||
@collapsed and # and something to collapse
|
||||
length $collapsed[-1] and # and its not the rootdir
|
||||
$collapsed[-1] ne $updir and # nor another updir
|
||||
$collapsed[-1] ne $curdir # nor the curdir
|
||||
)
|
||||
{ # then
|
||||
pop @collapsed; # collapse
|
||||
}
|
||||
else { # else
|
||||
push @collapsed, $dir; # just hang onto it
|
||||
}
|
||||
}
|
||||
|
||||
return $fs->catpath($vol,
|
||||
$fs->catdir(@collapsed),
|
||||
$file
|
||||
);
|
||||
}
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user