diff options
Diffstat (limited to 'gnu/usr.bin/perl/dist/PathTools')
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/Cwd.pm | 86 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/Cwd.xs | 8 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/Makefile.PL | 27 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/lib/File/Spec.pm | 17 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Cygwin.pm | 5 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Epoc.pm | 5 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Functions.pm | 12 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Mac.pm | 39 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/OS2.pm | 15 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Unix.pm | 37 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/VMS.pm | 20 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Win32.pm | 11 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/t/Spec.t | 30 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/dist/PathTools/t/taint.t | 2 |
14 files changed, 134 insertions, 180 deletions
diff --git a/gnu/usr.bin/perl/dist/PathTools/Cwd.pm b/gnu/usr.bin/perl/dist/PathTools/Cwd.pm index 3b6388938a1..58af9352db3 100644 --- a/gnu/usr.bin/perl/dist/PathTools/Cwd.pm +++ b/gnu/usr.bin/perl/dist/PathTools/Cwd.pm @@ -1,16 +1,16 @@ package Cwd; use strict; use Exporter; -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); -$VERSION = '3.63_01'; + +our $VERSION = '3.74'; my $xs_version = $VERSION; $VERSION =~ tr/_//d; -@ISA = qw/ Exporter /; -@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +our @ISA = qw/ Exporter /; +our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; -@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); +our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # sys_cwd may keep the builtin command @@ -77,19 +77,9 @@ sub _vms_efs { # If loading the XS stuff doesn't work, we can fall back to pure perl -if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) { - eval {#eval is questionable since we are handling potential errors like - #"Cwd object version 3.48 does not match bootstrap parameter 3.50 - #at lib/DynaLoader.pm line 216." by having this eval - if ( $] >= 5.006 ) { - require XSLoader; - XSLoader::load( __PACKAGE__, $xs_version); - } else { - require DynaLoader; - push @ISA, 'DynaLoader'; - __PACKAGE__->bootstrap( $xs_version ); - } - }; +if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) { # skipped on miniperl + require XSLoader; + XSLoader::load( __PACKAGE__, $xs_version); } # Big nasty table of function aliases @@ -145,23 +135,6 @@ my %METHOD_MAP = realpath => 'fast_abs_path', }, - epoc => - { - cwd => '_epoc_cwd', - getcwd => '_epoc_cwd', - fastgetcwd => '_epoc_cwd', - fastcwd => '_epoc_cwd', - abs_path => 'fast_abs_path', - }, - - MacOS => - { - getcwd => 'cwd', - fastgetcwd => 'cwd', - fastcwd => 'cwd', - abs_path => 'fast_abs_path', - }, - amigaos => { getcwd => '_backtick_pwd', @@ -254,8 +227,7 @@ unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { } } - # MacOS has some special magic to make `pwd` work. - if( $os eq 'MacOS' || $found_pwd_cmd ) + if( $found_pwd_cmd ) { *cwd = \&_backtick_pwd; } @@ -384,9 +356,6 @@ sub chdir { if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } - elsif ($^O eq 'MacOS') { - return $ENV{'PWD'} = cwd(); - } elsif ($^O eq 'MSWin32') { $ENV{'PWD'} = $newpwd; return 1; @@ -418,8 +387,7 @@ sub _perl_abs_path unless (@cst = stat( $start )) { - _carp("stat($start): $!"); - return ''; + return undef; } unless (-d _) { @@ -453,15 +421,14 @@ sub _perl_abs_path local *PARENT; unless (opendir(PARENT, $dotdots)) { - # probably a permissions issue. Try the native command. - require File::Spec; - return File::Spec->rel2abs( $start, _backtick_pwd() ); + return undef; } unless (@cst = stat($dotdots)) { - _carp("stat($dotdots): $!"); + my $e = $!; closedir(PARENT); - return ''; + $! = $e; + return undef; } if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) { @@ -473,9 +440,10 @@ sub _perl_abs_path { unless (defined ($dir = readdir(PARENT))) { - _carp("readdir($dotdots): $!"); closedir(PARENT); - return ''; + require Errno; + $! = Errno::ENOENT(); + return undef; } $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) } @@ -494,6 +462,7 @@ my $Curdir; sub fast_abs_path { local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage my $cwd = getcwd(); + defined $cwd or return undef; require File::Spec; my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); @@ -503,7 +472,9 @@ sub fast_abs_path { ($cwd) = $cwd =~ /(.*)/s; unless (-e $path) { - _croak("$path: No such file or directory"); + require Errno; + $! = Errno::ENOENT(); + return undef; } unless (-d _) { @@ -514,7 +485,7 @@ sub fast_abs_path { if (-l $path) { my $link_target = readlink($path); - die "Can't resolve link $path: $!" unless defined $link_target; + defined $link_target or return undef; $link_target = File::Spec->catpath($vol, $dir, $link_target) unless File::Spec->file_name_is_absolute($link_target); @@ -528,7 +499,7 @@ sub fast_abs_path { } if (!CORE::chdir($path)) { - _croak("Cannot chdir to $path: $!"); + return undef; } my $realpath = getcwd(); if (! ((-d $cwd) && (CORE::chdir($cwd)))) { @@ -676,11 +647,6 @@ sub _qnx_abs_path { return $realpath; } -sub _epoc_cwd { - return $ENV{'PWD'} = EPOC::getcwd(); -} - - # Now that all the base-level functions are set up, alias the # user-level functions to the right places @@ -737,7 +703,8 @@ absolute path of the current working directory. my $cwd = getcwd(); -Returns the current working directory. +Returns the current working directory. On error returns C<undef>, +with C<$!> set to indicate the error. Exposes the POSIX function getcwd(3) or re-implements it if it's not available. @@ -800,7 +767,8 @@ given they'll use the current working directory. Uses the same algorithm as getcwd(). Symbolic links and relative-path components ("." and "..") are resolved to return the canonical -pathname, just like realpath(3). +pathname, just like realpath(3). On error returns C<undef>, with C<$!> +set to indicate the error. =item realpath diff --git a/gnu/usr.bin/perl/dist/PathTools/Cwd.xs b/gnu/usr.bin/perl/dist/PathTools/Cwd.xs index 3d018dc43f9..2ca8acd6abb 100644 --- a/gnu/usr.bin/perl/dist/PathTools/Cwd.xs +++ b/gnu/usr.bin/perl/dist/PathTools/Cwd.xs @@ -7,6 +7,8 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#define NEED_croak_xs_usage +#define NEED_sv_2pv_flags #define NEED_my_strlcpy #define NEED_my_strlcat #include "ppport.h" @@ -134,9 +136,9 @@ bsd_realpath(const char *path, char resolved[MAXPATHLEN]) } if (next_token[0] == '\0') continue; - else if (strcmp(next_token, ".") == 0) + else if (strEQ(next_token, ".")) continue; - else if (strcmp(next_token, "..") == 0) { + else if (strEQ(next_token, "..")) { /* * Strip the last path component except when we have * single "/" @@ -424,7 +426,7 @@ int Perl_getcwd_sv(pTHX_ SV *sv) #endif #if USE_MY_CXT -# define MY_CXT_KEY "Cwd::_guts"XS_VERSION +# define MY_CXT_KEY "Cwd::_guts" XS_VERSION typedef struct { SV *empty_string_sv, *slash_string_sv; } my_cxt_t; diff --git a/gnu/usr.bin/perl/dist/PathTools/Makefile.PL b/gnu/usr.bin/perl/dist/PathTools/Makefile.PL index bc40baff608..11e04af5230 100644 --- a/gnu/usr.bin/perl/dist/PathTools/Makefile.PL +++ b/gnu/usr.bin/perl/dist/PathTools/Makefile.PL @@ -1,13 +1,34 @@ -BEGIN { @INC = grep {!/blib/} @INC } +# See https://rt.cpan.org/Public/Bug/Display.html?id=4681 +# and https://rt.perl.org/Ticket/Display.html?id=125603 +# When installing a newer Cwd on a system with an existing Cwd, +# under some circumstances the old Cwd.pm and the new Cwd.xs could +# get mixed up and SEGVs ensue. + +BEGIN { @INC = grep { $_ ne "blib/arch" and $_ ne "blib/lib" } @INC } require 5.005; use ExtUtils::MakeMaker; + +my @extra; +push @extra, 'LICENSE' => 'perl_5' + unless $ExtUtils::MakeMaker::VERSION < 6.31; +push @extra, 'META_MERGE' => { + resources => { + repository => 'git://perl5.git.perl.org/perl.git', + bugtracker => 'https://rt.perl.org/rt3/', + homepage => "http://dev.perl.org/", + license => [ 'http://dev.perl.org/licenses/' ], + }, + } unless $ExtUtils::MakeMaker::VERSION < 6.46; + WriteMakefile ( 'DISTNAME' => 'PathTools', 'NAME' => 'Cwd', 'VERSION_FROM' => 'Cwd.pm', + 'ABSTRACT' => 'Tools for working with directory and file names', + 'AUTHOR' => 'Perl 5 Porters', 'DEFINE' => join(" ", "-DDOUBLE_SLASHES_SPECIAL=@{[$^O eq q(qnx) || $^O eq q(nto) ? 1 : 0]}", ((grep { $_ eq 'PERL_CORE=1' } @ARGV) ? '-DNO_PPPORT_H' : ()), @@ -16,12 +37,12 @@ WriteMakefile 'Carp' => '0', 'File::Basename' => '0', 'Scalar::Util' => '0', - 'Test' => '0', # done_testing() is used in dist/Cwd/t/Spec.t 'Test::More' => 0.88, }, ($] > 5.011) ? () : ( INSTALLDIRS => 'perl' ), # CPAN sourced versions should now install to site 'EXE_FILES' => [], - 'PL_FILES' => {} + 'PL_FILES' => {}, + @extra, ) ; diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec.pm index 3ef0f339db3..85327ee0da3 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec.pm @@ -1,16 +1,14 @@ package File::Spec; use strict; -use vars qw(@ISA $VERSION); -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -my %module = (MacOS => 'Mac', +my %module = ( MSWin32 => 'Win32', os2 => 'OS2', VMS => 'VMS', - epoc => 'Epoc', 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. @@ -21,7 +19,7 @@ my %module = (MacOS => 'Mac', my $module = $module{$^O} || 'Unix'; require "File/Spec/$module.pm"; -@ISA = ("File::Spec::$module"); +our @ISA = ("File::Spec::$module"); 1; @@ -158,10 +156,13 @@ Returns a string representation of the parent directory. =item no_upwards -Given a list of file names, strip out those that refer to a parent -directory. (Does not strip symlinks, only '.', '..', and equivalents.) +Given a list of files in a directory (such as from C<readdir()>), +strip out C<'.'> and C<'..'>. - @paths = File::Spec->no_upwards( @paths ); +B<SECURITY NOTE:> This does NOT filter paths containing C<'..'>, like +C<'../../../../etc/passwd'>, only literal matches to C<'.'> and C<'..'>. + + @paths = File::Spec->no_upwards( readdir $dirhandle ); =item case_tolerant diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Cygwin.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Cygwin.pm index 10b14c4b9a6..ed646a160fd 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Cygwin.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Cygwin.pm @@ -1,13 +1,12 @@ package File::Spec::Cygwin; use strict; -use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -@ISA = qw(File::Spec::Unix); +our @ISA = qw(File::Spec::Unix); =head1 NAME diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Epoc.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Epoc.pm index 9b9e1fae587..58f74a33ca2 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Epoc.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Epoc.pm @@ -1,13 +1,12 @@ package File::Spec::Epoc; use strict; -use vars qw($VERSION @ISA); -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; require File::Spec::Unix; -@ISA = qw(File::Spec::Unix); +our @ISA = qw(File::Spec::Unix); =head1 NAME diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Functions.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Functions.pm index a4e1b1bb338..9af6352dd24 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Functions.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Functions.pm @@ -3,16 +3,14 @@ package File::Spec::Functions; use File::Spec; use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); - -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; require Exporter; -@ISA = qw(Exporter); +our @ISA = qw(Exporter); -@EXPORT = qw( +our @EXPORT = qw( canonpath catdir catfile @@ -24,7 +22,7 @@ require Exporter; path ); -@EXPORT_OK = qw( +our @EXPORT_OK = qw( devnull tmpdir splitpath @@ -35,7 +33,7 @@ require Exporter; case_tolerant ); -%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); +our %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); require File::Spec::Unix; my %udeps = ( diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Mac.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Mac.pm index 22424f32510..a1b044d152a 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Mac.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Mac.pm @@ -1,18 +1,13 @@ package File::Spec::Mac; use strict; -use vars qw(@ISA $VERSION); +use Cwd (); require File::Spec::Unix; -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -@ISA = qw(File::Spec::Unix); - -my $macfiles; -if ($^O eq 'MacOS') { - $macfiles = eval { require Mac::Files }; -} +our @ISA = qw(File::Spec::Unix); sub case_tolerant { 1 } @@ -121,7 +116,7 @@ doesn't alter the path, i.e. these arguments are ignored. (When a "" is passed as the first argument, it has a special meaning, see (6)). This way, a colon ":" is handled like a "." (curdir) on Unix, while an empty string "" is generally ignored (see -C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".." +L<File::Spec::Unix/canonpath()> ). Likewise, a "::" is handled like a ".." (updir), and a ":::" is handled like a "../.." etc. E.g. catdir("a",":",":","b") = ":a:b:" @@ -168,7 +163,7 @@ their Unix counterparts: # (e.g. "HD:a:") However, this approach is limited to the first arguments following -"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more +"root" (again, see L<File::Spec::Unix/canonpath()>. If there are more arguments that move up the directory tree, an invalid path going beyond root can be created. @@ -343,27 +338,11 @@ sub devnull { =item rootdir -Returns a string representing the root directory. Under MacPerl, -returns the name of the startup volume, since that's the closest in -concept, although other volumes aren't rooted there. The name has a -trailing ":", because that's the correct specification for a volume -name on Mac OS. - -If Mac::Files could not be loaded, the empty string is returned. +Returns the empty string. Mac OS has no real root directory. =cut -sub rootdir { -# -# There's no real root directory on Mac OS. The name of the startup -# volume is returned, since that's the closest in concept. -# - return '' unless $macfiles; - my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, - &Mac::Files::kSystemFolderType); - $system =~ s/:.*\Z(?!\n)/:/s; - return $system; -} +sub rootdir { '' } =item tmpdir @@ -669,7 +648,7 @@ sub abs2rel { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; @@ -737,7 +716,7 @@ sub rel2abs { if ( ! $self->file_name_is_absolute($path) ) { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute($base) ) { $base = $self->rel2abs($base) ; diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/OS2.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/OS2.pm index 0119042c9c0..e961ad4e333 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/OS2.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/OS2.pm @@ -1,13 +1,13 @@ package File::Spec::OS2; use strict; -use vars qw(@ISA $VERSION); +use Cwd (); require File::Spec::Unix; -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -@ISA = qw(File::Spec::Unix); +our @ISA = qw(File::Spec::Unix); sub devnull { return "/dev/nul"; @@ -30,11 +30,6 @@ sub path { return @path; } -sub _cwd { - # In OS/2 the "require Cwd" is unnecessary bloat. - return Cwd::sys_cwd(); -} - sub tmpdir { my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TEMP TMP'); return $cached if defined $cached; @@ -148,7 +143,7 @@ sub abs2rel { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; } else { @@ -205,7 +200,7 @@ sub rel2abs { if ( ! $self->file_name_is_absolute( $path ) ) { if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Unix.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Unix.pm index 9598dbb3621..a1fa6736a1e 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Unix.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Unix.pm @@ -1,26 +1,11 @@ package File::Spec::Unix; use strict; -use vars qw($VERSION); +use Cwd (); -$VERSION = '3.63_01'; -my $xs_version = $VERSION; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -#dont try to load XSLoader and DynaLoader only to ultimately fail on miniperl -if(!defined &canonpath && defined &DynaLoader::boot_DynaLoader) { - eval {#eval is questionable since we are handling potential errors like - #"Cwd object version 3.48 does not match bootstrap parameter 3.50 - #at lib/DynaLoader.pm line 216." by having this eval - if ( $] >= 5.006 ) { - require XSLoader; - XSLoader::load("Cwd", $xs_version); - } else { - require Cwd; - } - }; -} - =head1 NAME File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules @@ -185,7 +170,8 @@ sub _tmpdir { @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; } elsif ($] < 5.007) { # No ${^TAINT} before 5.8 - @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist; + @dirlist = grep { !defined($_) || eval { eval('1'.substr $_,0,0) } } + @dirlist; } foreach (@dirlist) { @@ -409,7 +395,7 @@ Based on code written by Shigio Yamaguchi. sub abs2rel { my($self,$path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; + $base = Cwd::getcwd() unless defined $base and length $base; ($path, $base) = map $self->canonpath($_), $path, $base; @@ -436,7 +422,7 @@ sub abs2rel { } } else { - my $wd= ($self->splitpath($self->_cwd(), 1))[1]; + my $wd= ($self->splitpath(Cwd::getcwd(), 1))[1]; $path_directories = $self->catdir($wd, $path); $base_directories = $self->catdir($wd, $base); } @@ -519,7 +505,7 @@ sub rel2abs { if ( ! $self->file_name_is_absolute( $path ) ) { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; @@ -552,15 +538,6 @@ L<File::Spec> =cut -# Internal routine to File::Spec, no point in making this public since -# it is the standard Cwd interface. Most of the platform-specific -# File::Spec subclasses use this. -sub _cwd { - require Cwd; - Cwd::getcwd(); -} - - # Internal method to reduce xx\..\yy -> yy sub _collapse { my($fs, $path) = @_; diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/VMS.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/VMS.pm index c0cc1e50434..cbafdce88ab 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/VMS.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/VMS.pm @@ -1,13 +1,13 @@ package File::Spec::VMS; use strict; -use vars qw(@ISA $VERSION); +use Cwd (); require File::Spec::Unix; -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -@ISA = qw(File::Spec::Unix); +our @ISA = qw(File::Spec::Unix); use File::Basename; use VMS::Filespec; @@ -97,7 +97,7 @@ sub canonpath { # [-.-. ==> [--. # .-.-] ==> .--] # [-.-] ==> [--] - 1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/); + 1 while ($path =~ s/(?<!\^)([\[\.])(?:\^.|[^\]\.])+\.-(-+)([\]\.])/$1$2$3/); # That loop does the following # with any amount (minimum 2) # of dashes: @@ -108,11 +108,11 @@ sub canonpath { # # And then, the remaining cases $path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [- - $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g; # .foo.-. ==> . - $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [ - $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ] + $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\./\./g; # .foo.-. ==> . + $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\./\[/g; # [foo.-. ==> [ + $path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\]/\]/g; # .foo.-] ==> ] # [foo.-] ==> [000000] - $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g; + $path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\]/\[000000\]/g; # [] ==> $path =~ s/(?<!\^)\[\]// unless $path eq '[]'; return $unix_rpt ? unixify($path) : $path; @@ -442,7 +442,7 @@ sub abs2rel { my $self = shift; my($path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; + $base = Cwd::getcwd() unless defined $base and length $base; # If there is no device or directory syntax on $base, make sure it # is treated as a directory. @@ -514,7 +514,7 @@ sub rel2abs { if ( ! $self->file_name_is_absolute( $path ) ) { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd; + $base = Cwd::getcwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; diff --git a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Win32.pm b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Win32.pm index 578d61b37f8..9ccafa7d15f 100644 --- a/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Win32.pm +++ b/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Win32.pm @@ -2,13 +2,13 @@ package File::Spec::Win32; use strict; -use vars qw(@ISA $VERSION); +use Cwd (); require File::Spec::Unix; -$VERSION = '3.63_01'; +our $VERSION = '3.74'; $VERSION =~ tr/_//d; -@ISA = qw(File::Spec::Unix); +our @ISA = qw(File::Spec::Unix); # Some regexes we use for path splitting my $DRIVE_RX = '[a-zA-Z]:'; @@ -330,14 +330,13 @@ sub rel2abs { if ($is_abs) { # It's missing a volume, add one - my $vol = ($self->splitpath( $self->_cwd() ))[0]; + my $vol = ($self->splitpath( Cwd::getcwd() ))[0]; return $self->canonpath( $vol . $path ); } if ( !defined( $base ) || $base eq '' ) { - require Cwd ; $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; - $base = $self->_cwd() unless defined $base ; + $base = Cwd::getcwd() unless defined $base ; } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; diff --git a/gnu/usr.bin/perl/dist/PathTools/t/Spec.t b/gnu/usr.bin/perl/dist/PathTools/t/Spec.t index 150c8d48735..84ed6b16fde 100644 --- a/gnu/usr.bin/perl/dist/PathTools/t/Spec.t +++ b/gnu/usr.bin/perl/dist/PathTools/t/Spec.t @@ -61,6 +61,9 @@ my @tests = ( [ "Unix->catfile('a', do { my \$x = 'b'.chr(0xaf); use utf8 (); utf8::upgrade(\$x); \$x })", 'a/b'.chr(0xaf) ], ) : ()), [ "Unix->catfile(substr('foo', 2))", 'o' ], +# https://rt.cpan.org/Ticket/Display.html?id=121633 +# https://rt.perl.org/Ticket/Display.html?id=131296 +[ "Unix->catfile('.', 'hints', 'Makefile.PL')", 'hints/Makefile.PL' ], [ "Unix->splitpath('file')", ',,file' ], [ "Unix->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ], @@ -139,6 +142,7 @@ my @tests = ( ($] >= 5.008 ? ( [ "Unix->canonpath(do { my \$x = '///a'.chr(0xaf); use utf8 (); utf8::upgrade(\$x); \$x })", '/a'.chr(0xaf) ], ) : ()), +[ "Unix->canonpath(1)", '1' ], [ "Unix->abs2rel('/t1/t2/t3','/t1/t2/t3')", '.' ], [ "Unix->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ], @@ -284,7 +288,7 @@ my @tests = ( [ "Win32->canonpath('/..\\')", '\\' ], [ "Win32->canonpath('d1/../foo')", 'foo' ], -# FakeWin32 subclass (see below) just sets CWD to C:\one\two and getdcwd('D') to D:\alpha\beta +# FakeWin32 subclass (see below) just sets getcwd() to C:\one\two and getdcwd('D') to D:\alpha\beta [ "FakeWin32->abs2rel('/t1/t2/t3','/t1/t2/t3')", '.' ], [ "FakeWin32->abs2rel('/t1/t2/t4','/t1/t2/t3')", '..\\t4' ], @@ -448,6 +452,13 @@ my @tests = ( # During the Perl 5.8 era, FS::Unix stopped eliminating redundant path elements, so mimic that here. [ "VMS->canonpath('a/../../b/c.dat')", $vms_unix_rpt ? 'a/../../b/c.dat' : '[-.b]c.dat' ], [ "VMS->canonpath('^<test^.new.-.caret^ escapes^>')", $vms_unix_rpt ? '/<test.new.-.caret escapes>' : '^<test^.new.-.caret^ escapes^>' ], +# Check that directory specs with caret-dot component is treated correctly +[ "VMS->canonpath('foo:[bar.coo.kie.--]file.txt')", $vms_unix_rpt ? '/foo/bar/file.txt' : "foo:[bar]file.txt" ], +[ "VMS->canonpath('foo:[bar^.coo.kie.--]file.txt')", $vms_unix_rpt ? '/foo/file.txt' : "foo:[000000]file.txt" ], +[ "VMS->canonpath('foo:[bar.coo^.kie.--]file.txt')", $vms_unix_rpt ? '/foo/file.txt' : "foo:[000000]file.txt" ], +[ "VMS->canonpath('foo:[bar.coo.kie.-]file.txt')", $vms_unix_rpt ? '/foo/bar/coo/file.txt' : "foo:[bar.coo]file.txt" ], +[ "VMS->canonpath('foo:[bar^.coo.kie.-]file.txt')", $vms_unix_rpt ? '/foo/bar.coo/file.txt' : "foo:[bar^.coo]file.txt" ], +[ "VMS->canonpath('foo:[bar.coo^.kie.-]file.txt')", $vms_unix_rpt ? '/foo/bar/file.txt' : "foo:[bar]file.txt" ], [ "VMS->splitdir('')", '' ], [ "VMS->splitdir('[]')", '' ], @@ -790,14 +801,9 @@ my @tests = ( ) ; -can_ok('File::Spec::Win32', '_cwd'); - { package File::Spec::FakeWin32; - use vars qw(@ISA); - @ISA = qw(File::Spec::Win32); - - sub _cwd { 'C:\\one\\two' } + our @ISA = qw(File::Spec::Win32); # Some funky stuff to override Cwd::getdcwd() for testing purposes, # in the limited scope of the rel2abs() method. @@ -806,6 +812,8 @@ can_ok('File::Spec::Win32', '_cwd'); *rel2abs = sub { my $self = shift; local $^W; + local *Cwd::getcwd = sub { 'C:\\one\\two' }; + *Cwd::getcwd = *Cwd::getcwd; # Avoid a 'used only once' warning local *Cwd::getdcwd = sub { return 'D:\alpha\beta' if $_[0] eq 'D:'; return 'C:\one\two' if $_[0] eq 'C:'; @@ -815,6 +823,14 @@ can_ok('File::Spec::Win32', '_cwd'); return $self->SUPER::rel2abs(@_); }; *rel2abs = *rel2abs; # Avoid a 'used only once' warning + *abs2rel = sub { + my $self = shift; + local $^W; + local *Cwd::getcwd = sub { 'C:\\one\\two' }; + *Cwd::getcwd = *Cwd::getcwd; # Avoid a 'used only once' warning + return $self->SUPER::abs2rel(@_); + }; + *abs2rel = *abs2rel; # Avoid a 'used only once' warning } } diff --git a/gnu/usr.bin/perl/dist/PathTools/t/taint.t b/gnu/usr.bin/perl/dist/PathTools/t/taint.t index 48f8c5bc8f6..95154704c00 100644 --- a/gnu/usr.bin/perl/dist/PathTools/t/taint.t +++ b/gnu/usr.bin/perl/dist/PathTools/t/taint.t @@ -11,7 +11,7 @@ use lib File::Spec->catdir('t', 'lib'); use Test::More; BEGIN { plan( - ${^TAINT} + !eval { eval("1".substr($^X,0,0)) } ? (tests => 21) : (skip_all => "A perl without taint support") ); |