File::Find: fix "follow => 1" on Windows

File::Find's code expects unix-style paths and it manipulates them using basic string operations. That code is very fragile, and ideally we should make it use File::Spec, but that would involve rewriting almost the whole module. Instead, we made it convert backslashes to slashes and handle drive letters. Note from xenu: this commit was adapted from the PR linked in this blogpost[1]. I have squashed it, written the commit message and slightly modified the code. [1] - https://www.nu42.com/2021/09/canonical-paths-file-find-way-forward.html Fixes #19995
Perl · Aug 2, 2022 · 414f14d · 414f14d
1 parent 2fcaad3
commit 414f14d
Show file tree

Hide file tree

Showing 7 changed files with 97 additions and 27 deletions.
diff --git a/MANIFEST b/MANIFEST
@@ -4265,6 +4265,7 @@ ext/File-DosGlob/DosGlob.xs		Win32 DOS-globbing module
 ext/File-DosGlob/lib/File/DosGlob.pm	Win32 DOS-globbing module
 ext/File-DosGlob/t/DosGlob.t		See if File::DosGlob works
 ext/File-Find/lib/File/Find.pm	Routines to do a find
+ext/File-Find/t/correct-absolute-path-with-follow.t
 ext/File-Find/t/find.t		See if File::Find works
 ext/File-Find/t/lib/Testing.pm		Functions used in testing File-find
 ext/File-Find/t/taint.t		See if File::Find works with taint

diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
@@ -172,6 +172,7 @@ package Maintainers;
         'DISTRIBUTION' => 'SMUELLER/AutoLoader-5.74.tar.gz',
         'FILES'        => q[cpan/AutoLoader],
         'EXCLUDED'     => ['t/00pod.t'],
+        'CUSTOMIZED'   => ['t/02AutoSplit.t'],
     },
 
     'autouse' => {

diff --git a/cpan/AutoLoader/t/02AutoSplit.t b/cpan/AutoLoader/t/02AutoSplit.t
@@ -149,8 +149,12 @@ foreach (@tests) {
 
   if ($args{Files}) {
     $args{Files} =~ s!/!:!gs if $^O eq 'MacOS';
+    $args{Files} =~ s!\\!/!g if $^O eq 'MSWin32';
     my (%missing, %got);
-    find (sub {$got{$File::Find::name}++ unless -d $_}, $dir);
+    find(
+        sub { (my $f = $File::Find::name) =~ s!\\!/!g; $got{$f}++ unless -d $_ },
+        $dir
+    );
     foreach (split /\n/, $args{Files}) {
       next if /^#/;
       $_ = lc($_) if $Is_VMS_lc;

diff --git a/ext/File-Find/lib/File/Find.pm b/ext/File-Find/lib/File/Find.pm
@@ -43,11 +43,21 @@ sub contract_name {
     return $abs_name;
 }
 
+sub _is_absolute {
+    return $_[0] =~ m|^(?:[A-Za-z]:)?/| if $Is_Win32;
+    return substr($_[0], 0, 1) eq '/';
+}
+
+sub _is_root {
+    return $_[0] =~ m|^(?:[A-Za-z]:)?/\z| if $Is_Win32;
+    return $_[0] eq '/';
+}
+
 sub PathCombine($$) {
     my ($Base,$Name) = @_;
     my $AbsName;
 
-    if (substr($Name,0,1) eq '/') {
+    if (_is_absolute($Name)) {
         $AbsName= $Name;
     }
     else {
@@ -123,6 +133,7 @@ sub is_tainted_pp {
     return length($@) != 0;
 }
 
+
 sub _find_opt {
     my $wanted = shift;
     return unless @_;
@@ -183,19 +194,17 @@ sub _find_opt {
 
         ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;
 
-        if ($Is_Win32) {
-            $top_item =~ s|[/\\]\z||
-              unless $top_item =~ m{^(?:\w:)?[/\\]$};
-        }
-        else {
-            $top_item =~ s|/\z|| unless $top_item eq '/';
-        }
+        # canonicalize directory separators
+        $top_item =~ s|[/\\]|/|g if $Is_Win32;
+
+        # no trailing / unless path is root
+        $top_item =~ s|/\z|| unless _is_root($top_item);
 
         $Is_Dir= 0;
 
         if ($follow) {
 
-            if (substr($top_item,0,1) eq '/') {
+            if (_is_absolute($top_item)) {
                 $abs_dir = $top_item;
             }
             elsif ($top_item eq $File::Find::current_dir) {
@@ -304,11 +313,7 @@ sub _find_dir($$$) {
     my $tainted = 0;
     my $no_nlink;
 
-    if ($Is_Win32) {
-        $dir_pref
-          = ($p_dir =~ m{^(?:\w:[/\\]?|[/\\])$} ? $p_dir : "$p_dir/" );
-    } elsif ($Is_VMS) {
-
+    if ($Is_VMS) {
         # VMS is returning trailing .dir on directories
         # and trailing . on files and symbolic links
         # in UNIX syntax.
@@ -319,7 +324,7 @@ sub _find_dir($$$) {
         $dir_pref = ($p_dir =~ m/[\]>]+$/ ? $p_dir : "$p_dir/" );
     }
     else {
-        $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
+        $dir_pref = _is_root($p_dir) ? $p_dir : "$p_dir/";
     }
 
     local ($dir, $name, $prune);
@@ -471,12 +476,7 @@ sub _find_dir($$$) {
                 $CdLvl = $Level;
             }
 
-            if ($Is_Win32) {
-                $dir_name = ($p_dir =~ m{^(?:\w:[/\\]?|[/\\])$}
-                    ? "$p_dir$dir_rel" : "$p_dir/$dir_rel");
-                $dir_pref = "$dir_name/";
-            }
-            elsif ($^O eq 'VMS') {
+            if ($^O eq 'VMS') {
                 if ($p_dir =~ m/[\]>]+$/) {
                     $dir_name = $p_dir;
                     $dir_name =~ s/([\]>]+)$/.$dir_rel$1/;
@@ -488,7 +488,7 @@ sub _find_dir($$$) {
                 }
             }
             else {
-                $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
+                $dir_name = _is_root($p_dir) ? "$p_dir$dir_rel" : "$p_dir/$dir_rel";
                 $dir_pref = "$dir_name/";
             }
 
@@ -540,8 +540,8 @@ sub _find_dir_symlnk($$$) {
     my $tainted = 0;
     my $ok = 1;
 
-    $dir_pref = ( $p_dir   eq '/' ? '/' : "$p_dir/" );
-    $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
+    $dir_pref = _is_root($p_dir) ? $p_dir : "$p_dir/";
+    $loc_pref = _is_root($dir_loc) ? $dir_loc : "$dir_loc/";
 
     local ($dir, $name, $fullname, $prune);
 
@@ -677,7 +677,7 @@ sub _find_dir_symlnk($$$) {
     continue {
         while (defined($SE = pop @Stack)) {
             ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE;
-            $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
+            $dir_name = _is_root($p_dir) ? "$p_dir$dir_rel" : "$p_dir/$dir_rel";
             $dir_pref = "$dir_name/";
             $loc_pref = "$dir_loc/";
             if ( $byd_flag < 0 ) {  # must be finddepth, report dirname now

diff --git a/ext/File-Find/t/correct-absolute-path-with-follow.t b/ext/File-Find/t/correct-absolute-path-with-follow.t
@@ -0,0 +1,63 @@
+#!./perl
+
+use strict;
+use warnings;
+
+use File::Find qw( find finddepth );
+use File::Temp qw();
+use Test::More;
+
+my $warn_msg;
+
+BEGIN {
+    $SIG{'__WARN__'} = sub {
+        $warn_msg = $_[0];
+        warn "# $_[0]";
+        return;
+    }
+}
+
+sub test_find_correct_paths_with_follow {
+    $warn_msg = '';
+    my $dir = File::Temp->newdir('file-find-XXXXXX', TMPDIR => 1, CLEANUP => 1);
+
+    find(
+        {
+            follow => 1,
+            wanted => sub { return },
+        },
+        $dir,
+    );
+
+    unlike(
+        $warn_msg,
+        qr/Couldn't chdir/,
+        'find: Derive absolute path correctly with follow => 1',
+    );
+}
+
+sub test_finddepth_correct_paths_with_follow {
+    $warn_msg = '';
+    my $dir = File::Temp->newdir('file-find-XXXXXX', TMPDIR => 1, CLEANUP => 1);
+
+    finddepth(
+        {
+            follow => 1,
+            wanted => sub { return },
+        },
+        $dir,
+    );
+
+    unlike(
+        $warn_msg,
+        qr/Couldn't chdir/,
+        'finddepth: Derive absolute path correctly with follow => 1',
+    );
+}
+sub run {
+    test_find_correct_paths_with_follow;
+    test_finddepth_correct_paths_with_follow;
+    done_testing;
+}
+
+run();
diff --git a/ext/File-Find/t/find.t b/ext/File-Find/t/find.t
@@ -1060,7 +1060,7 @@ if ($^O eq 'MSWin32') {
                             'wanted' => sub {
                                 -f or return; # the first call is for $root_dir itself.
                                 my $got = $File::Find::name;
-                                my $exp = "$root_dir$expected_first_file";
+                                (my $exp = "$root_dir$expected_first_file") =~ s|\\|/|g;
                                 print "# no_chdir=$no_chdir $root_dir '$got'\n";
                                 is($got, $exp,
                                    "Win32: Run 'find' with 'no_chdir' set to $no_chdir" );

diff --git a/t/porting/customized.dat b/t/porting/customized.dat
@@ -1,6 +1,7 @@
 # Regenerate this file using:
 #     cd t
 #     ./perl -I../lib porting/customized.t --regen
+AutoLoader cpan/AutoLoader/t/02AutoSplit.t bb90cda13b88599ad45de4b45799d5218afcb6d8
 ExtUtils::Constant cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Base.pm 7560e1018f806db5689dee78728ccb8374aea741
 ExtUtils::Constant cpan/ExtUtils-Constant/t/Constant.t 165e9c7132b003fd192d32a737b0f51f9ba4999e
 Filter::Util::Call pod/perlfilter.pod 545265af2f45741a0e59eecdd0cfc0c9e490c1e8