[perl #17751] File::Spec::Win32::canonpath patch try#3

Message-ID: <3DA39FAC.85471200@lingo.kiev.ua>

p4raw-id: //depot/perl@17997

diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm
index 791b004..7c22758 100644 (file)
--- a/lib/File/Spec/Win32.pm
+++ b/lib/File/Spec/Win32.pm
@@ -113,11 +113,16 @@ sub path {
 
 No physical check on the filesystem, but a logical cleanup of a
 path. On UNIX eliminated successive slashes and successive "/.".
+On Win32 makes 
+
+       dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
+       dir1\dir2\dir3\...\dir4   -> \dir\dir4
 
 =cut
 
 sub canonpath {
     my ($self,$path) = @_;
+    my $orig_path = $path;
     $path =~ s/^([a-z]:)/\u$1/s;
     $path =~ s|/|\\|g;
     $path =~ s|([^\\])\\+|$1\\|g;                  # xx\\\\xx  -> xx\xx
@@ -125,6 +130,38 @@ sub canonpath {
     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # .\xx      -> xx
     $path =~ s|\\\Z(?!\n)||
              unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s;   # xx\       -> xx
+       # xx1/xx2/xx3/../../xx -> xx1/xx
+       $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
+       $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g;    # ...\ is 2 levels up
+       return $path if $path =~ m|^\.\.|;      # skip relative paths
+       return $path unless $path =~ /\.\./;    # too few .'s to cleanup
+       return $path if $path =~ /\.\.\.\./;    # too many .'s to cleanup
+       return $path if $orig_path =~ m|^\Q/../\E|
+                               and $orig_path =~ m|\/$|;  # don't do /../dirs/ 
+                                                                                  # when called from rel2abs()
+                                                                                  # for ../dirs/
+       my ($vol,$dirs,$file) = $self->splitpath($path);
+       my @dirs = $self->splitdir($dirs);
+       my (@base_dirs, @path_dirs);
+       my $dest = \@base_dirs;
+       for my $dir (@dirs){
+               $dest = \@path_dirs if $dir eq $self->updir;
+               push @$dest, $dir;
+       }
+       # for each .. in @path_dirs pop one item from 
+       # @base_dirs
+       while (my $dir = shift @path_dirs){ 
+               unless ($dir eq $self->updir){
+                       unshift @path_dirs, $dir;
+                       last;
+               }
+               pop @base_dirs;
+       }
+       $path = $self->catpath( 
+               $vol, 
+               $self->catdir(@base_dirs, @path_dirs), 
+               $file
+    );
     return $path;
 }
 

diff --git a/lib/File/Spec/t/Spec.t b/lib/File/Spec/t/Spec.t
index 35b2e6f..b6331ce 100644 (file)
--- a/lib/File/Spec/t/Spec.t
+++ b/lib/File/Spec/t/Spec.t
@@ -202,8 +202,12 @@ if ($^O eq 'MacOS') {
 [ "Win32->canonpath('////')",           '\\\\\\'              ],
 [ "Win32->canonpath('//')",             '\\'                  ],
 [ "Win32->canonpath('/.')",             '\\.'                 ],
-[ "Win32->canonpath('//a/b/../../c')",  '\\\\a\\b\\..\\..\\c' ],
-[ "Win32->canonpath('//a/../../c')",    '\\\\a\\..\\..\\c'    ],
+[ "Win32->canonpath('//a/b/../../c')",  '\\\\a\\b\\c'         ],
+[ "Win32->canonpath('//a/b/c/../d')",   '\\\\a\\b\\d'         ],
+[ "Win32->canonpath('//a/b/c/../../d')",'\\\\a\\b\\d'         ],
+[ "Win32->canonpath('//a/b/c/.../d')",  '\\\\a\\b\\d'         ],
+[ "Win32->canonpath('/a/b/c/../../d')", '\\a\\d'              ],
+[ "Win32->canonpath('/a/b/c/.../d')",   '\\a\\d'              ],
 
 ## Hmmm, we should test missing and relative base paths some day...
 ## would need to cd to a known place, get the cwd() and use it I
@@ -226,13 +230,12 @@ if ($^O eq 'MacOS') {
 [ "Win32->rel2abs('temp','C:/')",                       'C:\\temp'                        ],
 [ "Win32->rel2abs('temp','C:/a')",                      'C:\\a\\temp'                     ],
 [ "Win32->rel2abs('temp','C:/a/')",                     'C:\\a\\temp'                     ],
-[ "Win32->rel2abs('../','C:/')",                        'C:\\..'                          ],
-[ "Win32->rel2abs('../','C:/a')",                       'C:\\a\\..'                       ],
+[ "Win32->rel2abs('../','C:/')",                        'C:\\'                            ],
+[ "Win32->rel2abs('../','C:/a')",                       'C:\\'                            ],
 [ "Win32->rel2abs('temp','//prague_main/work/')",       '\\\\prague_main\\work\\temp'     ],
-[ "Win32->rel2abs('../temp','//prague_main/work/')",    '\\\\prague_main\\work\\..\\temp' ],
+[ "Win32->rel2abs('../temp','//prague_main/work/')",    '\\\\prague_main\\work\\temp'     ],
 [ "Win32->rel2abs('temp','//prague_main/work')",        '\\\\prague_main\\work\\temp'     ],
-[ "Win32->rel2abs('../','//prague_main/work')",         '\\\\prague_main\\work\\..'       ],
-
+[ "Win32->rel2abs('../','//prague_main/work')",         '\\\\prague_main\\work'           ],
 
 [ "VMS->catfile('a','b','c')",         '[.a.b]c'  ],
 [ "VMS->catfile('a','b','[]c')",       '[.a.b]c'  ],