Bug #53178 for File-Path: bug when only 1 path present and no \%opts

What the OP did not show was that he was probably using an object as the $path. This *is* a horrible bug, and it happens when the single argument to the routines is an object that is a blessed hash, like a Path::Class object. I have attached a test and a fix. The fix will treat only an unblessed hashref as a set of arguments, not a blessed one. -- rjbs

From bc6516f2677387e9e82233d7c7da97350356fabd Mon Sep 17 00:00:00 2001 From: Ricardo Signes <rjbs@cpan.org> Date: Tue, 19 Jul 2011 10:39:59 -0400 Subject: [PATCH 1/2] add a failing test for Path::Class use --- t/Path-Class.t | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 files changed, 49 insertions(+), 0 deletions(-) create mode 100644 t/Path-Class.t diff --git a/t/Path-Class.t b/t/Path-Class.t new file mode 100644 index 0000000..c3542d6 --- /dev/null +++ b/t/Path-Class.t @@ -0,0 +1,49 @@ +use strict; +use warnings; +use Test::More; + +eval "require Path::Class"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +use File::Path qw(remove_tree make_path); +Path::Class->import; + +my $name = 'test'; +my $dir = dir($name); + +sub test { + my ($dir, $pass_arg) = @_; + + my $args = [ $dir, ($pass_arg ? {} : ()) ]; + my $desc = sprintf( + 'dir isa %s, second arg is %s', + (ref($dir) || 'string'), + ($pass_arg ? '{}' : 'not passed') + ); + + return ($args, $desc); +} + +for my $mk_dir ($name, dir($name)) { + for my $mk_pass_arg (0, 1) { + + for my $rm_dir ($name, dir($name)) { + for my $rm_pass_arg (0, 1) { + remove_tree($name) if -e $name; + + my ($mk_args, $mk_desc) = test($mk_dir, $mk_pass_arg); + make_path(@$mk_args); + + if (ok( -d $dir, "we made $dir ($mk_desc)")) { + my ($rm_args, $rm_desc) = test($rm_dir, $rm_pass_arg); + remove_tree(@$rm_args); + ok( ! -d $dir, "...then we removed $dir ($rm_desc)"); + } else { + fail("...can't remove it if we didn't create it"); + } + } + } + } +} + +done_testing; -- 1.7.4.4

From 6620faa02586eb41db7deea4a12e6545150cb58a Mon Sep 17 00:00:00 2001 From: Ricardo Signes <rjbs@cpan.org> Date: Tue, 19 Jul 2011 10:46:48 -0400 Subject: [PATCH 2/2] do not treat blessed hashes as argument hashes --- Path.pm | 15 +++++++++++---- 1 files changed, 11 insertions(+), 4 deletions(-) diff --git a/Path.pm b/Path.pm index 387cdb1..790405b 100644 --- a/Path.pm +++ b/Path.pm @@ -6,6 +6,7 @@ use strict; use Cwd 'getcwd'; use File::Basename (); use File::Spec (); +use Scalar::Util (); BEGIN { if ($] < 5.006) { @@ -58,13 +59,19 @@ sub _error { } } +sub __is_arg { + my ($arg) = @_; + return (Scalar::Util::reftype($arg) || '') eq 'HASH' + && ! Scalar::Util::blessed($arg); +} + sub make_path { - push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH'); + push @_, {} unless @_ and __is_arg($_[-1]); goto &mkpath; } sub mkpath { - my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH')); + my $old_style = !(@_ and __is_arg($_[-1])); my $arg; my $paths; @@ -162,7 +169,7 @@ sub _mkpath { } sub remove_tree { - push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH'); + push @_, {} unless @_ and __is_arg($_[-1]); goto &rmtree; } @@ -185,7 +192,7 @@ sub _is_subdir { } sub rmtree { - my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH')); + my $old_style = !(@_ and __is_arg($_[-1])); my $arg; my $paths; -- 1.7.4.4