Bug #51588 for File-Path: [PATCH] avoid logical name conflicts in _rmtree on VMS

Greetings, David. The attached patch fixes a VMS-only problem with a couple of very small VMS-only changes to Path.pm. The comment I put in the new test that verifies the fix has some discussion of what it's about, but that may not make much sense if you aren't familiar with logical names and how they work. Basically it is not entirely safe to pass a bareword to chdir, rmdir, and so forth because it may actually be a logical name that does not point to what you think it's pointing to. 'foo' may point to a directory of that name relative to where you are, but it could also point to somewhere entirely different; but the native syntax '[.foo]' always points to the local directory. The new test only runs on VMS and should gracefully bail out elsewhere, but if you'd rather not include it with the package that's fine; at least it will be here for reference. The two-line change to Path.pm, though, would be a big help. Thanks.

--- Path.pm;-0 2009-10-04 05:15:58 -0500 +++ Path.pm 2009-11-15 16:57:52 -0600 @@ -279,7 +279,7 @@ sub _rmtree { my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR; if ( -d _ ) { - $root = VMS::Filespec::pathify($root) if $Is_VMS; + $root = VMS::Filespec::vmspath(VMS::Filespec::pathify($root)) if $Is_VMS; if (!chdir($root)) { # see if we can escalate privileges to get in @@ -343,7 +343,6 @@ sub _rmtree { # filesystems is faster if done in reverse ASCIIbetical order. # include '.' to '.;' from blead patch #31775 @files = map {$_ eq '.' ? '.;' : $_} reverse @files; - ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//; } @files = grep {$_ ne $updir and $_ ne $curdir} @files; --- /dev/null 2009-11-16 21:38:15 -0600 +++ t/vms_safety_check.t 2009-11-15 15:24:36 -0600 @@ -0,0 +1,52 @@ +use strict; + +BEGIN { + if ($^O ne 'VMS') { + print "1..0 # Skip on non-VMS platforms\n"; + exit 0; + } +} + +=head1 Synopsis + +This test verifies that when removing a directory tree where one of +the directory names is the same as an existing logical name we don't +get thrown off by the logical name. Say we're removing +C<disk1:[mystuff.lib.bar]>. Say we also have a logical name C<lib> +pointing elsewhere in the filesystem. Because File::Path picks +apart and operates on each component of the path separately, there's +a danger that when C<lib> is passed to chdir, rmdir, etc., those +functions might be operating on what C<lib> points to rather than the +intended directory. File::Path's internal consistency checks would +prevent us from doing any damage, but would also bail out and cause +the operation to fail. There have been bugs in this area before, +now fixed; the test makes sure they stay that way. + +=cut + +use Test::More tests => 2; +use File::Path qw(rmtree mkpath); +use File::Spec::Functions; + +my $tmp_base = catdir( + curdir(), + sprintf( 'test_%x_%x_%x', time, $$, rand(99999) ), +); + +my @dir = ( + catdir($tmp_base, qw(a fp_test_subdir c)), +); + +my @created = mkpath([@dir]); + +$ENV{'fp_test_subdir'} = '_NLA0:'; +END { + delete $ENV{'fp_test_subdir'}; +} + +is(scalar(@created), 4, "created directory tree"); + +my $dir = catdir($tmp_base, 'a'); +rmtree($dir); +ok(!(-d $dir), "directory tree safely removed with environment set"); +