r71156 - in /branches/upstream/libfile-remove-perl/current: Changes MANIFEST META.yml lib/File/Remove.pm t/02_directories.t t/03_deep_readonly.t t/04_can_delete.t t/05_links.t t/07_cwd.t t/08_spaces.t xt/pmv.t

ansgar at users.alioth.debian.org ansgar at users.alioth.debian.org
Fri Mar 11 13:24:47 UTC 2011


Author: ansgar
Date: Fri Mar 11 13:24:15 2011
New Revision: 71156

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=71156
Log:
[svn-upgrade] new version libfile-remove-perl (1.48)

Added:
    branches/upstream/libfile-remove-perl/current/t/08_spaces.t
Modified:
    branches/upstream/libfile-remove-perl/current/Changes
    branches/upstream/libfile-remove-perl/current/MANIFEST
    branches/upstream/libfile-remove-perl/current/META.yml
    branches/upstream/libfile-remove-perl/current/lib/File/Remove.pm
    branches/upstream/libfile-remove-perl/current/t/02_directories.t
    branches/upstream/libfile-remove-perl/current/t/03_deep_readonly.t
    branches/upstream/libfile-remove-perl/current/t/04_can_delete.t
    branches/upstream/libfile-remove-perl/current/t/05_links.t
    branches/upstream/libfile-remove-perl/current/t/07_cwd.t
    branches/upstream/libfile-remove-perl/current/xt/pmv.t

Modified: branches/upstream/libfile-remove-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/Changes?rev=71156&op=diff
==============================================================================
--- branches/upstream/libfile-remove-perl/current/Changes (original)
+++ branches/upstream/libfile-remove-perl/current/Changes Fri Mar 11 13:24:15 2011
@@ -1,4 +1,13 @@
 Revision history for Perl extension File-Remove
+
+1.48 Fri 11 Mar 2011 - Adam Kennedy
+	- Promoting dev code to production version
+	- Fixed a major bug in the 1.46 logic that works out what to change the
+	  cwd to when deleting while inside a directory.
+
+1.47_01 Fri 18 Feb 2011 - Adam Kennedy
+	- Add test counts to all test scripts
+	- Added a test for space-safe globs
 
 1.46 Fri 18 Feb 2011 - Adam Kennedy
 	- No changes from 1.45_01

Modified: branches/upstream/libfile-remove-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/MANIFEST?rev=71156&op=diff
==============================================================================
--- branches/upstream/libfile-remove-perl/current/MANIFEST (original)
+++ branches/upstream/libfile-remove-perl/current/MANIFEST Fri Mar 11 13:24:15 2011
@@ -21,6 +21,7 @@
 t/05_links.t
 t/06_curly.t
 t/07_cwd.t
+t/08_spaces.t
 xt/meta.t
 xt/pmv.t
 xt/pod.t

Modified: branches/upstream/libfile-remove-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/META.yml?rev=71156&op=diff
==============================================================================
--- branches/upstream/libfile-remove-perl/current/META.yml (original)
+++ branches/upstream/libfile-remove-perl/current/META.yml Fri Mar 11 13:24:15 2011
@@ -28,4 +28,4 @@
   ChangeLog: http://fisheye2.atlassian.com/changelog/cpan/trunk/File-Remove
   license: http://dev.perl.org/licenses/
   repository: http://svn.ali.as/cpan/trunk/File-Remove
-version: 1.46
+version: 1.48

Modified: branches/upstream/libfile-remove-perl/current/lib/File/Remove.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/lib/File/Remove.pm?rev=71156&op=diff
==============================================================================
--- branches/upstream/libfile-remove-perl/current/lib/File/Remove.pm (original)
+++ branches/upstream/libfile-remove-perl/current/lib/File/Remove.pm Fri Mar 11 13:24:15 2011
@@ -6,7 +6,8 @@
 use vars qw{ $VERSION @ISA @EXPORT_OK };
 use vars qw{ $DEBUG $unlink $rmdir    };
 BEGIN {
-	$VERSION   = '1.46';
+	$VERSION   = '1.48';
+	# $VERSION   = eval $VERSION;
 	@ISA       = qw{ Exporter };
 	@EXPORT_OK = qw{ remove rm clear trash };
 }
@@ -225,9 +226,12 @@
 # Do we need to move to a different directory to delete a directory,
 # and if so which.
 sub _moveto {
+	my $remove = File::Spec->rel2abs(shift);
+	my $cwd    = @_ ? shift : Cwd::cwd();
+
 	# Do everything in absolute terms
-	my $cwd    = Cwd::abs_path( Cwd::cwd() );
-	my $remove = Cwd::abs_path( File::Spec->rel2abs(shift) );
+	$remove = Cwd::abs_path( $remove );
+	$cwd    = Cwd::abs_path( $cwd    );
 
 	# If we are on a different volume we don't need to move
 	my ( $cv, $cd ) = File::Spec->splitpath( $cwd,    1 );
@@ -237,10 +241,9 @@
 	# If we have to move, it's to one level above the deletion
 	my @cd = File::Spec->splitdir($cd);
 	my @rd = File::Spec->splitdir($rd);
-	pop @rd;
-
-	# Is the current directory inside of the moveto directory?
-	unless ( @cd > @rd ) {
+
+	# Is the current directory the same as or inside the remove directory?
+	unless ( @cd >= @rd ) {
 		return '';
 	}
 	foreach ( 0 .. $#rd ) {
@@ -248,6 +251,7 @@
 	}
 
 	# Confirmed, the current working dir is in the removal dir
+	pop @rd;
 	return File::Spec->catpath(
 		$rv,
 		File::Spec->catdir(@rd),

Modified: branches/upstream/libfile-remove-perl/current/t/02_directories.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/t/02_directories.t?rev=71156&op=diff
==============================================================================
--- branches/upstream/libfile-remove-perl/current/t/02_directories.t (original)
+++ branches/upstream/libfile-remove-perl/current/t/02_directories.t Fri Mar 11 13:24:15 2011
@@ -6,7 +6,7 @@
 	$^W = 1;
 }
 
-use Test::More   qw(no_plan); # tests => 2;
+use Test::More tests => 152;
 use File::Remove qw{ remove trash };
 
 
@@ -147,5 +147,3 @@
 
 	UNDELETE: 1;
 }
-
-1;

Modified: branches/upstream/libfile-remove-perl/current/t/03_deep_readonly.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/t/03_deep_readonly.t?rev=71156&op=diff
==============================================================================
--- branches/upstream/libfile-remove-perl/current/t/03_deep_readonly.t (original)
+++ branches/upstream/libfile-remove-perl/current/t/03_deep_readonly.t Fri Mar 11 13:24:15 2011
@@ -8,7 +8,7 @@
 	$^W = 1;
 }
 
-use Test::More qw(no_plan);
+use Test::More tests => 12;
 use File::Spec::Functions ':ALL';
 use File::Copy   ();
 use File::Remove ();

Modified: branches/upstream/libfile-remove-perl/current/t/04_can_delete.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/t/04_can_delete.t?rev=71156&op=diff
==============================================================================
--- branches/upstream/libfile-remove-perl/current/t/04_can_delete.t (original)
+++ branches/upstream/libfile-remove-perl/current/t/04_can_delete.t Fri Mar 11 13:24:15 2011
@@ -8,7 +8,7 @@
 	$^W = 1;
 }
 
-use Test::More qw(no_plan);
+use Test::More tests => 12;
 use File::Spec::Functions ':ALL';
 use File::Copy   ();
 use File::Remove ();
@@ -40,12 +40,12 @@
 	chmod( 0400, $f3 );
 	ok( -f $f3, "Created $f3 ok" );
 	ok( -r $f3, "Created $f3 -r" );
-    SKIP: {
-	if ( $^O ne 'MSWin32' and $< == 0 ) {
-		skip("This test doesn't work as root", 1);
-	}
-   	ok( ! -w $f3, "Created $f3 ! -w" );	
-    };
+	SKIP: {
+		if ( $^O ne 'MSWin32' and $< == 0 ) {
+			skip("This test doesn't work as root", 1);
+		}
+		ok( ! -w $f3, "Created $f3 ! -w" );	
+	};
 }
 
 sub clear_directory {

Modified: branches/upstream/libfile-remove-perl/current/t/05_links.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/t/05_links.t?rev=71156&op=diff
==============================================================================
--- branches/upstream/libfile-remove-perl/current/t/05_links.t (original)
+++ branches/upstream/libfile-remove-perl/current/t/05_links.t Fri Mar 11 13:24:15 2011
@@ -62,5 +62,3 @@
 ok( File::Remove::remove(\1, $testdir), "remove \\1: $testdir" );
 
 ok( ! -e $testdir,         "!-e: $testdir" );
-
-1;

Modified: branches/upstream/libfile-remove-perl/current/t/07_cwd.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/t/07_cwd.t?rev=71156&op=diff
==============================================================================
--- branches/upstream/libfile-remove-perl/current/t/07_cwd.t (original)
+++ branches/upstream/libfile-remove-perl/current/t/07_cwd.t Fri Mar 11 13:24:15 2011
@@ -6,7 +6,7 @@
 	$^W = 1;
 }
 
-use Test::More tests => 9;
+use Test::More tests => 13;
 use File::Spec::Functions ':ALL';
 use File::Remove ();
 use Cwd          ();
@@ -25,6 +25,46 @@
 ok( -d $cwd,  "$cwd directory exists" );
 ok( -d $foo,  "$foo directory exists" );
 ok( -f $file, "$file file exists"     );
+
+# Test that _moveto behaves as expected
+SCOPE: {
+	is(
+		File::Remove::_moveto(
+			File::Spec->catdir($base, 't'), # remove
+			File::Spec->catdir($base), # cwd
+		),
+		'',
+		'_moveto returns correct for normal case',
+	);
+
+	my $moveto1 = File::Remove::_moveto(
+		File::Spec->catdir($base, 't'), # remove
+		File::Spec->catdir($base, 't'), # cwd
+	);
+	$moveto1 =~ s/\\/\//g;
+	is( $moveto1, $base, '_moveto returns correct for normal case' );
+
+	my $moveto2 = File::Remove::_moveto(
+		File::Spec->catdir($base, 't'),        # remove
+		File::Spec->catdir($base, 't', 'cwd'), # cwd
+	);
+	$moveto2 =~ s/\\/\//g;
+	is( $moveto2, $base, '_moveto returns correct for normal case' );
+
+	# Regression: _moveto generates false positives
+	# cwd:      /tmp/cpan2/PITA-Image/PITA-Image-0.50
+	# remove:   /tmp/eBtQxTPGHC
+	# moveto:   /tmp
+	# expected: ''
+	is(
+		File::Remove::_moveto(
+			File::Spec->catdir($base, 't'),           # remove
+			File::Spec->catdir($base, 'lib', 'File'), # cwd
+		),
+		'',
+		'_moveto returns null as expected',
+	);
+}
 
 # Change the current working directory into the first
 # test directory and store the absolute path.

Added: branches/upstream/libfile-remove-perl/current/t/08_spaces.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/t/08_spaces.t?rev=71156&op=file
==============================================================================
--- branches/upstream/libfile-remove-perl/current/t/08_spaces.t (added)
+++ branches/upstream/libfile-remove-perl/current/t/08_spaces.t Fri Mar 11 13:24:15 2011
@@ -1,0 +1,87 @@
+#!/usr/bin/perl
+
+# Test that File::Remove (with or without globbing) supports the use of
+# spaces in the path to delete.
+
+use strict;
+BEGIN {
+	$|  = 1;
+	$^W = 1;
+}
+
+use Test::More qw(no_plan);
+use File::Spec::Functions ':ALL';
+use File::Copy   ();
+use File::Remove ();
+
+
+
+
+
+#####################################################################
+# Set up for the test
+
+my $t  = catdir( curdir(), 't' );
+my $s  = catdir(  $t, 'spaced path' );
+my $f1 = catfile( $s, 'foo1.txt'    );
+my $f2 = catfile( $s, 'foo2.txt'    );
+my $f3 = catfile( $s, 'bar.txt'     );
+
+sub create_directory {
+	mkdir($s,0777) or die "Failed to create $s";
+	ok( -d $s, "Created $s ok" );
+	ok( -r $s, "Created $s -r" );
+	ok( -w $s, "Created $s -w" );
+	open( FILE, ">$f1" ) or die "Failed to create $f1";
+	print FILE "Test\n";
+	close FILE;
+	open( FILE, ">$f2" ) or die "Failed to create $f2";
+	print FILE "Test\n";
+	close FILE;
+	open( FILE, ">$f3" ) or die "Failed to create $f3";
+	print FILE "Test\n";
+	close FILE;
+}
+
+sub clear_directory {
+	if ( -e $f1 ) {
+		unlink( $f1 )      or die "unlink: $f1 failed";
+		! -e $f1           or die "unlink didn't work";
+	}
+	if ( -e $f2 ) {
+		unlink( $f2 )      or die "unlink: $f2 failed";
+		! -e $f2           or die "unlink didn't work";
+	}
+	if ( -e $f3 ) {
+		unlink( $f3 )      or die "unlink: $f3 failed";
+		! -e $f3           or die "unlink didn't work";
+	}
+	if ( -e $s ) {
+		rmdir( $s )       or die "rmdir: $s failed";
+		! -e $s           or die "rmdir didn't work";
+	}
+}
+
+# Make sure there is no directory from a previous run
+clear_directory();
+
+# Create the directory
+create_directory();
+
+# Schedule cleanup
+END {
+	clear_directory();
+}
+
+
+
+
+
+#####################################################################
+# Main Testing
+
+# Expand a glob that should match the foo files
+my @match = File::Remove::expand('t/spaced path/foo*');
+is( scalar(@match), 2, 'Found two results' );
+ok( $match[0] =~ /foo1.txt/, 'Found foo1' );
+ok( $match[1] =~ /foo2.txt/, 'Found foo2' );

Modified: branches/upstream/libfile-remove-perl/current/xt/pmv.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-remove-perl/current/xt/pmv.t?rev=71156&op=diff
==============================================================================
--- branches/upstream/libfile-remove-perl/current/xt/pmv.t (original)
+++ branches/upstream/libfile-remove-perl/current/xt/pmv.t Fri Mar 11 13:24:15 2011
@@ -9,7 +9,7 @@
 }
 
 my @MODULES = (
-	'Perl::MinimumVersion 1.25',
+	'Perl::MinimumVersion 1.27',
 	'Test::MinimumVersion 0.101080',
 );
 




More information about the Pkg-perl-cvs-commits mailing list