Cwd's pure perl abs_path and its test disagree on what's ok #11931
Comments
From @ikegamiCreated by @ikegami[ Applies to 5.10.1, 5.12.2, 5.14.2, blead, etc ] Whenever I build Perl on my web host, I get a failure in Cwd. # Failed test at t/cwd.t line 209. C<abs_path> is a function that returns an absolute path with symbolic links You can test this yourself using the attached script (extracted from cwd.t) I don't know if C<_perl_abs_path> should croak or if the test shouldn't - Eric Perl Info |
From @ikegamiOn Fri, Feb 3, 2012 at 10:03 PM, Eric Brine <perlbug-followup@perl.org>wrote:
Oops, now attached. |
From @ikegami |
From @jkeenanOn Fri Feb 03 19:03:14 2012, ikegami@adaelis.com wrote:
I get your point, but when I tried to replicate the problem on my I split your test file into two separate programs so that I could create In 'a_109760_cwdtest.pl', I remove the test directories and symlink if In the first pass, I leave directory permissions untouched and run The output is therefore: $ prove -v b_109760_cwdtest.pl In the second pass, I run the first program, then chmod u-r .., then run ########## $ chmod u-r .. $ prove -v b_109760_cwdtest.pl 1..1 Test Summary Report b_109760_cwdtest.pl (Wstat: 65280 Tests: 1 Failed: 0) I read this as saying that, once the higher directory had been rendered ######### So I doubt the problem is *only* in Cwd::_perl_abs_path(). Thank you very much. |
|
The RT System itself - Status changed from 'new' to 'open' |
From gottreu@gmail.comThis is a bug report for perl from gottreu@gmail.com, From 5f28c1a5e9dd996eeec4fc4aade74a400a3af87e Mon Sep 17 00:00:00 2001 This is a multi-part message in MIME format. AUTHORS | 1 + --------------1.7.10.4 Inline Patchdiff --git a/AUTHORS b/AUTHORS
index 44f52e2..b00e7e5 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -163,6 +163,7 @@ Brian Carlson <brian.carlson@cpanel.net>
Brian Clarke <clarke@appliedmeta.com>
brian d foy <brian.d.foy@gmail.com>
Brian Fraser <fraserbn@gmail.com>
+Brian Gottreu <gottreu@gmail.com>
Brian Greenfield <briang@cpan.org>
Brian Grossman
Brian Harrison <brie@corp.home.net>
diff --git a/dist/Cwd/t/cwd.t b/dist/Cwd/t/cwd.t
index f7b03ed..3c83855 100644
--- a/dist/Cwd/t/cwd.t
+++ b/dist/Cwd/t/cwd.t
@@ -40,6 +40,17 @@ my $tests = 31;
# _perl_abs_path() currently only works when the directory separator
# is '/', so don't test it when it won't work.
my $EXTRA_ABSPATH_TESTS = ($Config{prefix} =~ m/\//) && $^O ne 'cygwin';
+# _perl_abs_path() uses readdir() on all the directories in the path
+# passed to it. If perl is built under /home (for example) and /home is
+# set to executable but not readable, then the extra abspath tests will
+# fail even though the perl built is perfectly fine.
+if($EXTRA_ABSPATH_TESTS) {
+ my @dirs = File::Spec->splitdir(cwd());
+ for(0..$#dirs) {
+ my $parent_dir = File::Spec->catdir(@dirs[0..$_]);
+ $EXTRA_ABSPATH_TESTS = 0 unless -r $parent_dir;
+ }
+}
$tests += 4 if $EXTRA_ABSPATH_TESTS;
plan tests => $tests;
--------------1.7.10.4--
---
Site configuration information for perl 5.19.1: Configured by gottreu at Thu Jun 13 11:58:47 CDT 2013. Summary of my perl5 (revision 5 version 19 subversion 1) configuration: Locally applied patches: @INC for perl 5.19.1: Environment for perl 5.19.1: |
From @jkeenanOn Thu Jun 13 13:10:46 2013, gottreu wrote:
Thanks for the patch. Can you elaborate a bit as to how it addresses Thank you very much. |
From @ikegamiOn Thu, Jun 13, 2013 at 10:21 PM, James E Keenan via RT <
Looking into your earlier comments, and testing to see if the patch |
From gottreu@gmail.com
It sort of didn't. It didn't solve the actual problem of _perl_abs_path() This new patch is an actual fix. I just translated the bsd_realpath() C This is a bug report for perl from gottreu@gmail.com, From a380df6c6c1f9e17832236d07838efac3007a838 Mon Sep 17 00:00:00 2001 This is a multi-part message in MIME format. AUTHORS | 1 + --------------1.7.10.4 Inline Patchdiff --git a/AUTHORS b/AUTHORS
index 44f52e2..b00e7e5 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -163,6 +163,7 @@ Brian Carlson <brian.carlson@cpanel.net>
Brian Clarke <clarke@appliedmeta.com>
brian d foy <brian.d.foy@gmail.com>
Brian Fraser <fraserbn@gmail.com>
+Brian Gottreu <gottreu@gmail.com>
Brian Greenfield <briang@cpan.org>
Brian Grossman
Brian Harrison <brie@corp.home.net>
diff --git a/dist/Cwd/Cwd.pm b/dist/Cwd/Cwd.pm
index 5cbb9d8..062e03c 100644
--- a/dist/Cwd/Cwd.pm
+++ b/dist/Cwd/Cwd.pm
@@ -536,82 +536,63 @@ sub chdir {
}
-sub _perl_abs_path
-{
- my $start = @_ ? shift : '.';
- my($dotdots, $cwd, @pst, @cst, $dir, @tst);
-
- unless (@cst = stat( $start ))
- {
- _carp("stat($start): $!");
- return '';
+sub _perl_abs_path {
+ # NOTE that this routine assumes that '/' is the only directory separator.
+ my $path = @_ ? shift : '.';
+ my $resolved;
+ my $next_token;
+ my $left;
+ my $symlinks;
+ return '/' if $path eq '/';
+ if($path =~ m{^/(.+)}) {
+ $resolved = '/';
+ $left = $1;
}
-
- unless (-d _) {
- # Make sure we can be invoked on plain files, not just directories.
- # NOTE that this routine assumes that '/' is the only directory separator.
-
- my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
- or return cwd() . '/' . $start;
-
- # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
- if (-l $start) {
- my $link_target = readlink($start);
- die "Can't resolve link $start: $!" unless defined $link_target;
-
- require File::Spec;
- $link_target = $dir . '/' . $link_target
- unless File::Spec->file_name_is_absolute($link_target);
-
- return abs_path($link_target);
- }
-
- return $dir ? abs_path($dir) . "/$file" : "/$file";
+ else {
+ $resolved = cwd();
+ $left = $path;
}
-
- $cwd = '';
- $dotdots = $start;
- do
- {
- $dotdots .= '/..';
- @pst = @cst;
- local *PARENT;
- unless (opendir(PARENT, $dotdots))
- {
- # probably a permissions issue. Try the native command.
- require File::Spec;
- return File::Spec->rel2abs( $start, _backtick_pwd() );
- }
- unless (@cst = stat($dotdots))
- {
- _carp("stat($dotdots): $!");
- closedir(PARENT);
- return '';
- }
- if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
- {
- $dir = undef;
- }
- else
- {
- do
- {
- unless (defined ($dir = readdir(PARENT)))
- {
- _carp("readdir($dotdots): $!");
- closedir(PARENT);
- return '';
- }
- $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
- }
- while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
- $tst[1] != $pst[1]);
- }
- $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
- closedir(PARENT);
- } while (defined $dir);
- chop($cwd) unless $cwd eq '/'; # drop the trailing /
- $cwd;
+ while($left ne '' and $left =~ m{^(.*?)(?:/|$)(.*)}) {
+ $next_token = $1;
+ $left = $2;
+ $resolved .= '/' unless $resolved =~ m{/$};
+ if($next_token eq '') { next; }
+ if($next_token eq '.') { next; }
+ if($next_token eq '..') {
+ if($resolved ne '/') {
+ $resolved =~ s{/[^/]+/$}{/};
+ }
+ next;
+ }
+ my $resolved_parent = $resolved;
+ $resolved .= $next_token;
+ my @sb;
+ @sb = lstat($resolved);
+ unless(@sb) {
+ return undef if $path =~ m{/$};
+ return $resolved if $left eq '' and -x $resolved_parent;
+ return undef;
+ }
+ if(-l $resolved) {
+ my $symlink;
+ return undef if ++$symlinks > 50;
+ $symlink = readlink($resolved);
+ unless($symlink) { return undef; }
+ if($symlink =~ m{^/}) {
+ $resolved = '/';
+ }
+ elsif(length($resolved) > 1) {
+ $resolved =~ s{/[^/]+$}{};
+ }
+ if($left ne '') {
+ $symlink .= '/' unless $symlink =~ m{/$};
+ $symlink .= $left;
+ }
+ $left = $symlink;
+ }
+ }
+ $resolved =~ s{/$}{} if length($resolved) > 1;
+ return $resolved;
}
--------------1.7.10.4--
---
Site configuration information for perl 5.19.1: Configured by gottreu at Thu Jun 13 17:46:12 CDT 2013. Summary of my perl5 (revision 5 version 19 subversion 1) configuration: Locally applied patches: @INC for perl 5.19.1: Environment for perl 5.19.1: |
From @ikegamiOn Sat, Feb 23, 2013 at 8:35 PM, James E Keenan via RT <
b_109760_cwdtest.pl ..
I don't get that. I get something similar if I run "b" twice without ok 1 - symlink to test_dir created But if I execute the commands you executed in the order you said you did, I ok 1 - symlink to test_dir created Brian's first patch ("Skip _perl_abs_path() tests when they will fail with I don't have time to look at his alternate/second patch right now. - Eric |
From gottreu@gmail.comAttached is a test (dist/Cwd/t/abs_path.t) that makes sure _perl_abs_path() and abs_path() return |
From gottreu@gmail.com#!./perl -w use strict; # XXX All the crossplatform stuff is cargo-cultedly copied from cwd.t chdir 't'; use Config; use lib File::Spec->catdir('t', 'lib'); # _perl_abs_path() currently only works when the directory separator my @real_dirs = qw( my @real_files = qw( my %valid_links = qw( _base_/link-bin /bin my %broken_links = qw( _base_/link-nothing0 nothing _base_/link-loop link-loop _base_/link-non-existant non-existant my @reg_paths = qw( my @link_paths = qw( _base_/link-ok2/file1 #my $tests = 1 + list_files("don't run cwd()"); my SKIP: { skip "No native pwd command found to test against", 1 unless $pwd_cmd; local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; # Win32's cd returns native C:\ style # When in UNIX report mode, need to convert to compare it. # Darwin's getcwd(3) (which Cwd.xs:bsd_realpath() uses which $cwd = cwd; eval { SKIP: { sub list_reg_files { sub list_symlinks { sub compare_perl_and_xs { sub create_files { sub delete_files { |
Migrated from rt.perl.org#109760 (status was 'open')
Searchable as RT109760$
The text was updated successfully, but these errors were encountered: