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
