File-Copy-Recursive-0.45/000755 000766 000024 00000000000 13515615477 015503 5ustar00dmueystaff000000 000000 File-Copy-Recursive-0.45/Changes000644 000766 000024 00000017311 13515614716 016774 0ustar00dmueystaff000000 000000 Revision history for Perl extension File::Copy::Recursive. 0.45 UNRELEASED - PR #21: fix version 0.43 in Changes file (thanks karenetheridge) - PR #19: Added missing license meta name. (thanks manwar and karenetheridge) - PR #24: allow for dev = 0 on NetBSD (thanks plicease) - PR #25: Remove warning when copying a dir without write perm on the original. (thanks ehickeycp) - Issue #26: change issues from rt to github 0.44 Tue Apr 24 08:18:19 2018 - Issue #18: fix t/05.legacy-pathmk_unc.t for recent updates (thanks zdm) 0.43 Sat Apr 21 15:39:09 2018 - pull request #16 - strip down list of prerequisites to modules that are safe to use high on the CPAN river (thanks karenetheridge) 0.42 Fri Apr 20 23:42:41 2018 - rt 125136 - reinstate 5.8 compat by not using // operator in the new unc test (thanks SREZIC) - pull request #14 - Add .gitignore. (thanks jkeenan) - pull request #13 - File::Find::Rule is used in the test suite but not named as a prequisite in Makefile.PL. (thanks jkeenan) 0.41 Thu Apr 19 15:58:12 2018 - Issue #10 and #8: fix Makefile.PL; add github metadata (thanks karenetheridge and chorny) - Issue #11: Fix the test failure described in RT#123964 (thanks tomhukins and SREZIC) - Issue #9: Fixes for Windows (thanks chorny) - rt 124324 - fix v0.40 changelog date (thanks ANDK) - rt 124151 - pathrm with force on should guard against absolute paths (thanks chorny) - rt 124423 - have fcopy() work around File::Copy::copy() bug rt132866 (thanks DROLSKY) - Issue #12 and rt 124166 - set umask for reliability (thanks teoric and ether) - rt 43328 - add ULC test to verify pathmk() w/ ULC (thanks willi.weikum and LouisStrous) 0.40 Tue Jan 16 10:00:09 2018 - github Issue #5 - Deep directories pathmk - rt 123966 - switch to bsd_glob() since glob() will disappear in perl 5.30 - rt 123971 - skip symlink tests when the OS does not support symlinks - rt 123970 - use Path::Tiny instead of File::Slurp in tests - rt 117241 - add test for read only directories 0.39 Fri Dec 29 13:26:12 2017 - tidy code - Change into directory before emptying it - Stop emptying/removing a path if it is changed out from underneath us - pathrm() fixes - Actual unit tests! 0.38 Sun Dec 7 22:35:42 2008 - do rmove() symlink fixups like rcopy() from ver 0.37 - rt 29750 (added $DirPerms) - Added requested rcopy_glob() && rmove_glob() for convenience 0.37 Thu Oct 9 11:52:54 2008 - rt 38959 POD fix ups - improved rcopy() symlink logic and do &goto; to preserve the stack - added "tests" to the TODO list, patches welcome! 0.36 Wed Apr 16 15:32:36 2008 - made all bareword file handles be lexical variables if the perl is new enough to support it (5.6.0 and up, see 'Indirect Filehandles' in perlopentut) 0.35 Mon Aug 27 16:18:53 2007 - fixed rt 29008 0.34 Tue Aug 21 09:41:05 2007 - samecheck return; instead of croak; - remaining croak()'s to $! = .. return; 0.33 Thu May 10 12:19:36 2007 - Sorry missed this one w/ 0.32... rt 25529 0.32 Wed May 9 20:56:55 2007 - rt 26459 0.31 Wed Jan 24 16:42:15 2007 - Fixed "Uninitialized value in -e ... line 196" problem. (Thanks Ben Thomas) - Fixed similar issue in nearby code (use of $_[0] instead of $org) - removed pointless at best, vague problem at best !-e readlink() check from symlink patch from 21267 introduced in 0.26 0.30 Fri Dec 8 14:26:49 2006 - Added $BdTrgWrn to quiet warnings by default (rt 23861) - added backwards compat for pre 5.6 perls (rt 21800) - Added $SkipFlop (rt request 21503) 0.29 Tue Oct 31 12:21:20 2006 - Made fcopy() do samecheck if $RMTrgFil is used and is triggered to avoid it removing the file before it can be copied to itself. 0.28 Thu Sep 7 15:27:06 2006 - rebundled with make dist under COPY_EXTENDED_ATTRIBUTES_DISABLE=true for 21378, thnaks Robert Boone for that excellent solution! 0.27 Wed Sep 6 23:46:16 2006 - quick rename so it can be uploaded fresh due to pause upload mishap 0.26 Wed Sep 6 23:45:16 2006 - added local DIE SIG as per 21351 - handle symlinks whose target's are missing more gracefully - 21267 0.25 Mon Jul 3 10:20:50 2006 - [forgot to add this one... ??] 0.24 Thu Jun 22 13:32:55 2006 - fixed bug 20045 0.23 Thu Jun 1 08:40:53 2006 - fixed bug 19637 0.22 Thu May 11 08:18:36 2006 - fixed bug 19205 0.21 Mon Apr 24 12:28:11 2006 - made dircopy() use fcopy() instead of copy() for files so that it'd behave consistently and correctly - updated some POD 0.20 Tue Apr 11 15:29:37 2006 - fixed bug 18667 - added $CondCopy functionality to dircopy() (and subsequently dirmove() and rcopy() and rmove() when handling directpries) 0.19 Mon Feb 27 07:37:01 2006 - added missing "star check" to rcopy() (thanks Ben Thomas) - added "star check" to rmove() and had it removed if necessary, to make passing the same variables to rcopy and rmove will work ok - added untainting and slight "best practive" cleanup to a for loop 0.18 Sun Jan 29 13:34:37 2006 - added parens to the opendir() calls to avoid spurious 5.8.1 and < warnings, thanks Chris Scott for letting me know about it - fixed change log 0.17 mistype {(0 to ()} :) 0.17 Thu Jan 26 11:51:01 2006 - fixed pathempty() calling close() instead of closedir() (17295, thanks Stoian for bringing that out) - changed handles to variables as per "Perl Best Pratices" - change a readir to us single quote sinstead o double since no interpolation is being done 0.16 Mon Aug 29 08:06:14 2005 - fixed fcopy() + $RMTrgFil spurious behavior when target is a directory 0.15 Fri Aug 26 08:40:26 2005 - changed $RMTrgDir and $RMTrgFil to carp() instead of warn() and with slightly more useful message - fixed issue with VERSION() that conflicted with UNIVERSAL's VERSION functionality - added "TO DO" regarding an OO interface 0.14 Thu Aug 25 14:19:58 2005 - added $RMTrgDir and $RMTrgFil functionality 0.13 Wed Aug 24 14:41:14 2005 - added cp -rf star glob funtionality to better emulate cp -rf when using $CPRFComp - fixed possible "read-only" value error/warning when $CPRFComp is in effect 0.12 Wed Aug 24 09:18:01 2005 - Fixed absolute path bug in pathmk() 0.11 Sun Aug 21 16:04:10 2005 - Added the *move and path* functions - Added $CopyLoop - Made fcopy() recursively create its base directories if necessary like dircopy() did in 0.09 on 0.10 Sat Aug 6 17:01:12 2005 - fixed indent in "SEE ALSO" POD that made it render badly - Added $PFSCheck 0.09 Fri Aug 5 18:59:11 2005 - made dircopy handle symlinks properly - made dircopy recursivley create a multiple directory target dir if necessary - added $CPRFComp 0.08 Fri Jul 29 14:35:44 2005 - fixed side effect of 0.07 not returning properly 0.07 Mon Jul 18 18:32:36 2005 - changed dircopy to return if subsequent copy fails (IE liek permission denied) so that "or [warn|die] $!" will work recursively also 0.06 Fri Apr 15 11:25:27 2005 - cleaned up Makefile.PL - added symlink preservation support (Thanks to Troy Goodson for pointing out that need) 0.05 Mon Jan 24 19:10:50 2005 - removed Makefile.PL perl version restriction 0.04 Tue Jan 18 20:59:44 2005 - added File::Copy::Recursive::VERSION(), not sure why I missed it before ;p - removed use 5.008001; since its not dependant on any version 0.03 Mon Jan 17 19:11:19 2005 - fixed documentation misspelling 0.02 Tue Dec 7 06:45:42 2004 - added documentation about return values that was left out - changed return pardigm for fcopy() so if rcopy() was called in list context on a file you wouldn't get uninitialized value warnings. 0.01 Sun Dec 5 16:04:10 2004 - original version; created by h2xs 1.22 with options -AXc -n File::Copy::Recursive File-Copy-Recursive-0.45/MANIFEST000644 000766 000024 00000000461 13515615477 016635 0ustar00dmueystaff000000 000000 Changes lib/File/Copy/Recursive.pm Makefile.PL MANIFEST This list of files META.yml README README.md t/00.load.t t/01.legacy.t t/02.legacy-symtogsafe.t t/03.github-issue-5.t t/04.readonly-dir.t t/05.legacy-pathmk_unc.t META.json Module JSON meta-data (added by MakeMaker) File-Copy-Recursive-0.45/t/000755 000766 000024 00000000000 13515615476 015745 5ustar00dmueystaff000000 000000 File-Copy-Recursive-0.45/README000644 000766 000024 00000001733 13266720545 016363 0ustar00dmueystaff000000 000000 File/Copy/Recursive version 0.43 ================================ This module has 3 functions, one to copy files only, one to copy directories only and one to do either depending on the argument's type. The depth to which a directory structure is copied can be set with: $File::Copy::Recursive::Maxdepth setting it back to false or non numeric value will turn it back to unlimited. All functions attempt to preserve each copied file's mode unless you set $File::Copy::Recursive::KeepMode to false. See perldoc File::Copy::Recursive for more info INSTALLATION To install this module type the following: perl Makefile.PL make make test make install or perl -MCPAN -e 'install File::Copy::Recursive;' DEPENDENCIES This module requires these other modules and libraries: File::Copy File::Spec COPYRIGHT AND LICENCE Copyright (C) 2004 Daniel Muey This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. File-Copy-Recursive-0.45/README.md000644 000766 000024 00000001160 12651507324 016747 0ustar00dmueystaff000000 000000 # File::Copy::Recursive round 2 I have gotten much love from this module but it has suffered from neglect. Partly because I am busy and partly that the code is crusty (it was done back when package globals were all the rage–those of you with CGI tatoos know what I am talking about ;)). So I am finally making a plan to give this the attention it deserves. ## Goals 1. Fix the [RTs](https://rt.cpan.org/Dist/Display.html?Queue=File-Copy-Recursive) and write tests (Issue #3) (pull requests welcome!) 2. Modernize the code and interface–Issue #2 3. Do not break existing consumers of the legacy interface–Issue #1 File-Copy-Recursive-0.45/META.yml000644 000766 000024 00000001561 13515615476 016756 0ustar00dmueystaff000000 000000 --- abstract: 'Perl extension for recursively copying files and directories' author: - 'Daniel Muey ' build_requires: ExtUtils::MakeMaker: '0' File::Temp: '0' Path::Tiny: '0' Test::Deep: '0' Test::Fatal: '0' Test::File: '0' Test::More: '0.88' Test::Warnings: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150001' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: File-Copy-Recursive no_index: directory: - t - inc requires: Cwd: '0' File::Copy: '0' File::Glob: '0' File::Spec: '0' resources: bugtracker: https://github.com/drmuey/p5-File-Copy-Recursive/issues repository: https://github.com/drmuey/p5-File-Copy-Recursive.git version: '0.45' File-Copy-Recursive-0.45/lib/000755 000766 000024 00000000000 13515615476 016250 5ustar00dmueystaff000000 000000 File-Copy-Recursive-0.45/Makefile.PL000644 000766 000024 00000002304 13515614531 017442 0ustar00dmueystaff000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'File::Copy::Recursive', VERSION_FROM => 'lib/File/Copy/Recursive.pm', ABSTRACT_FROM => 'lib/File/Copy/Recursive.pm', AUTHOR => 'Daniel Muey ', LICENSE => 'perl_5', PREREQ_PM => { 'File::Copy' => 0, 'File::Spec' => 0, 'File::Glob' => 0, 'Cwd' => 0, }, TEST_REQUIRES => { 'Test::More' => '0.88', 'Test::Deep' => 0, 'Test::File' => 0, 'File::Temp' => 0, 'Test::Warnings' => 0, 'Path::Tiny' => 0, 'Test::Fatal' => 0, }, META_ADD => { 'meta-spec' => { version => 2 }, dynamic_config => 0, resources => { repository => { url => 'https://github.com/drmuey/p5-File-Copy-Recursive.git', web => 'https://github.com/drmuey/p5-File-Copy-Recursive', type => 'git', }, bugtracker => { web => 'https://github.com/drmuey/p5-File-Copy-Recursive/issues', }, }, }, ); File-Copy-Recursive-0.45/META.json000644 000766 000024 00000003150 13515615477 017123 0ustar00dmueystaff000000 000000 { "abstract" : "Perl extension for recursively copying files and directories", "author" : [ "Daniel Muey " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150001", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "File-Copy-Recursive", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Cwd" : "0", "File::Copy" : "0", "File::Glob" : "0", "File::Spec" : "0" } }, "test" : { "requires" : { "File::Temp" : "0", "Path::Tiny" : "0", "Test::Deep" : "0", "Test::Fatal" : "0", "Test::File" : "0", "Test::More" : "0.88", "Test::Warnings" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/drmuey/p5-File-Copy-Recursive/issues" }, "repository" : { "type" : "git", "url" : "https://github.com/drmuey/p5-File-Copy-Recursive.git", "web" : "https://github.com/drmuey/p5-File-Copy-Recursive" } }, "version" : "0.45" } File-Copy-Recursive-0.45/lib/File/000755 000766 000024 00000000000 13515615476 017127 5ustar00dmueystaff000000 000000 File-Copy-Recursive-0.45/lib/File/Copy/000755 000766 000024 00000000000 13515615476 020041 5ustar00dmueystaff000000 000000 File-Copy-Recursive-0.45/lib/File/Copy/Recursive.pm000644 000766 000024 00000065651 13515615241 022351 0ustar00dmueystaff000000 000000 package File::Copy::Recursive; use strict; BEGIN { # Keep older versions of Perl from trying to use lexical warnings $INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006; } use warnings; use Carp; use File::Copy; use File::Spec; #not really needed because File::Copy already gets it, but for good measure :) use Cwd (); use vars qw( @ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink $PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir $CondCopy $BdTrgWrn $SkipFlop $DirPerms ); require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir rcopy_glob rmove_glob); $VERSION = '0.45'; $MaxDepth = 0; $KeepMode = 1; $CPRFComp = 0; $CopyLink = eval { local $SIG{'__DIE__'}; symlink '', ''; 1 } || 0; $PFSCheck = 1; $RemvBase = 0; $NoFtlPth = 0; $ForcePth = 0; $CopyLoop = 0; $RMTrgFil = 0; $RMTrgDir = 0; $CondCopy = {}; $BdTrgWrn = 0; $SkipFlop = 0; $DirPerms = 0777; my $samecheck = sub { return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders... return if @_ != 2 || !defined $_[0] || !defined $_[1]; return if $_[0] eq $_[1]; my $one = ''; if ($PFSCheck) { $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) || ''; my $two = join( '-', ( stat $_[1] )[ 0, 1 ] ) || ''; if ( $one eq $two && $one ) { carp "$_[0] and $_[1] are identical"; return; } } if ( -d $_[0] && !$CopyLoop ) { $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) if !$one; my $abs = File::Spec->rel2abs( $_[1] ); my @pth = File::Spec->splitdir($abs); while (@pth) { if ( $pth[-1] eq '..' ) { # cheaper than Cwd::realpath() plus we don't want to resolve symlinks at this point, right? pop @pth; pop @pth unless -l File::Spec->catdir(@pth); next; } my $cur = File::Spec->catdir(@pth); last if !$cur; # probably not necessary, but nice to have just in case :) my $two = join( '-', ( stat $cur )[ 0, 1 ] ) || ''; if ( $one eq $two && $one ) { # $! = 62; # Too many levels of symbolic links carp "Caught Deep Recursion Condition: $_[0] contains $_[1]"; return; } pop @pth; } } return 1; }; my $glob = sub { my ( $do, $src_glob, @args ) = @_; local $CPRFComp = 1; require File::Glob; my @rt; for my $path ( File::Glob::bsd_glob($src_glob) ) { my @call = [ $do->( $path, @args ) ] or return; push @rt, \@call; } return @rt; }; my $move = sub { my $fl = shift; my @x; if ($fl) { @x = fcopy(@_) or return; } else { @x = dircopy(@_) or return; } if (@x) { if ($fl) { unlink $_[0] or return; } else { pathrmdir( $_[0] ) or return; } if ($RemvBase) { my ( $volm, $path ) = File::Spec->splitpath( $_[0] ); pathrm( File::Spec->catpath( $volm, $path, '' ), $ForcePth, $NoFtlPth ) or return; } } return wantarray ? @x : $x[0]; }; my $ok_todo_asper_condcopy = sub { my $org = shift; my $copy = 1; if ( exists $CondCopy->{$org} ) { if ( $CondCopy->{$org}{'md5'} ) { } if ($copy) { } } return $copy; }; sub fcopy { $samecheck->(@_) or return; if ( $RMTrgFil && ( -d $_[1] || -e $_[1] ) ) { my $trg = $_[1]; if ( -d $trg ) { my @trgx = File::Spec->splitpath( $_[0] ); $trg = File::Spec->catfile( $_[1], $trgx[$#trgx] ); } $samecheck->( $_[0], $trg ) or return; if ( -e $trg ) { if ( $RMTrgFil == 1 ) { unlink $trg or carp "\$RMTrgFil failed: $!"; } else { unlink $trg or return; } } } my ( $volm, $path ) = File::Spec->splitpath( $_[1] ); if ( $path && !-d $path ) { pathmk( File::Spec->catpath( $volm, $path, '' ), $NoFtlPth ); } if ( -l $_[0] && $CopyLink ) { my $target = readlink( shift() ); ($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does carp "Copying a symlink ($_[0]) whose target does not exist" if !-e $target && $BdTrgWrn; my $new = shift(); unlink $new if -l $new; symlink( $target, $new ) or return; } elsif ( -d $_[0] && -f $_[1] ) { return; } else { return if -d $_[0]; # address File::Copy::copy() bug outlined in https://rt.perl.org/Public/Bug/Display.html?id=132866 copy(@_) or return; my @base_file = File::Spec->splitpath( $_[0] ); my $mode_trg = -d $_[1] ? File::Spec->catfile( $_[1], $base_file[$#base_file] ) : $_[1]; chmod scalar( ( stat( $_[0] ) )[2] ), $mode_trg if $KeepMode; } return wantarray ? ( 1, 0, 0 ) : 1; # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings } sub rcopy { if ( -l $_[0] && $CopyLink ) { goto &fcopy; } goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*'; goto &fcopy; } sub rcopy_glob { $glob->( \&rcopy, @_ ); } sub dircopy { if ( $RMTrgDir && -d $_[1] ) { if ( $RMTrgDir == 1 ) { pathrmdir( $_[1] ) or carp "\$RMTrgDir failed: $!"; } else { pathrmdir( $_[1] ) or return; } } my $globstar = 0; my $_zero = $_[0]; my $_one = $_[1]; if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*' ) { $globstar = 1; $_zero = substr( $_zero, 0, ( length($_zero) - 1 ) ); } $samecheck->( $_zero, $_[1] ) or return; if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) { $! = 20; return; } if ( !-d $_[1] ) { pathmk( $_[1], $NoFtlPth ) or return; } else { if ( $CPRFComp && !$globstar ) { my @parts = File::Spec->splitdir($_zero); while ( $parts[$#parts] eq '' ) { pop @parts; } $_one = File::Spec->catdir( $_[1], $parts[$#parts] ); } } my $baseend = $_one; my $level = 0; my $filen = 0; my $dirn = 0; my $recurs; #must be my()ed before sub {} since it calls itself $recurs = sub { my ( $str, $end, $buf ) = @_; $filen++ if $end eq $baseend; $dirn++ if $end eq $baseend; $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0'; mkdir( $end, $DirPerms ) or return if !-d $end; if ( $MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth ) { chmod scalar( ( stat($str) )[2] ), $end if $KeepMode; return ( $filen, $dirn, $level ) if wantarray; return $filen; } $level++; my @files; if ( $] < 5.006 ) { opendir( STR_DH, $str ) or return; @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH) ); closedir STR_DH; } else { opendir( my $str_dh, $str ) or return; @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh) ); closedir $str_dh; } for my $file (@files) { my ($file_ut) = $file =~ m{ (.*) }xms; my $org = File::Spec->catfile( $str, $file_ut ); my $new = File::Spec->catfile( $end, $file_ut ); if ( -l $org && $CopyLink ) { my $target = readlink($org); ($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does carp "Copying a symlink ($org) whose target does not exist" if !-e $target && $BdTrgWrn; unlink $new if -l $new; symlink( $target, $new ) or return; } elsif ( -d $org ) { my $rc; if ( !-w $org && $KeepMode ) { local $KeepMode = 0; $rc = $recurs->( $org, $new, $buf ) if defined $buf; $rc = $recurs->( $org, $new ) if !defined $buf; chmod scalar( ( stat($org) )[2] ), $new; } else { $rc = $recurs->( $org, $new, $buf ) if defined $buf; $rc = $recurs->( $org, $new ) if !defined $buf; } if ( !$rc ) { if ($SkipFlop) { next; } else { return; } } $filen++; $dirn++; } else { if ( $ok_todo_asper_condcopy->($org) ) { if ($SkipFlop) { fcopy( $org, $new, $buf ) or next if defined $buf; fcopy( $org, $new ) or next if !defined $buf; } else { fcopy( $org, $new, $buf ) or return if defined $buf; fcopy( $org, $new ) or return if !defined $buf; } chmod scalar( ( stat($org) )[2] ), $new if $KeepMode; $filen++; } } } $level--; chmod scalar( ( stat($str) )[2] ), $end if $KeepMode; 1; }; $recurs->( $_zero, $_one, $_[2] ) or return; return wantarray ? ( $filen, $dirn, $level ) : $filen; } sub fmove { $move->( 1, @_ ) } sub rmove { if ( -l $_[0] && $CopyLink ) { goto &fmove; } goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*'; goto &fmove; } sub rmove_glob { $glob->( \&rmove, @_ ); } sub dirmove { $move->( 0, @_ ) } sub pathmk { my ( $vol, $dir, $file ) = File::Spec->splitpath( shift() ); my $nofatal = shift; $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0'; if ( defined($dir) ) { my (@dirs) = File::Spec->splitdir($dir); for ( my $i = 0; $i < scalar(@dirs); $i++ ) { my $newdir = File::Spec->catdir( @dirs[ 0 .. $i ] ); my $newpth = File::Spec->catpath( $vol, $newdir, "" ); mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal; mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal; } } if ( defined($file) ) { my $newpth = File::Spec->catpath( $vol, $dir, $file ); mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal; mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal; } 1; } sub pathempty { my $pth = shift; my ( $orig_dev, $orig_ino ) = ( lstat $pth )[ 0, 1 ]; return 2 if !-d _ || !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino ); #stat.inode is 0 on Windows my $starting_point = Cwd::cwd(); my ( $starting_dev, $starting_ino ) = ( lstat $starting_point )[ 0, 1 ]; chdir($pth) or Carp::croak("Failed to change directory to “$pth”: $!"); $pth = '.'; _bail_if_changed( $pth, $orig_dev, $orig_ino ); my @names; my $pth_dh; if ( $] < 5.006 ) { opendir( PTH_DH, $pth ) or return; @names = grep !/^\.\.?$/, readdir(PTH_DH); closedir PTH_DH; } else { opendir( $pth_dh, $pth ) or return; @names = grep !/^\.\.?$/, readdir($pth_dh); closedir $pth_dh; } _bail_if_changed( $pth, $orig_dev, $orig_ino ); for my $name (@names) { my ($name_ut) = $name =~ m{ (.*) }xms; my $flpth = File::Spec->catdir( $pth, $name_ut ); if ( -l $flpth ) { _bail_if_changed( $pth, $orig_dev, $orig_ino ); unlink $flpth or return; } elsif ( -d $flpth ) { _bail_if_changed( $pth, $orig_dev, $orig_ino ); pathrmdir($flpth) or return; } else { _bail_if_changed( $pth, $orig_dev, $orig_ino ); unlink $flpth or return; } } chdir($starting_point) or Carp::croak("Failed to change directory to “$starting_point”: $!"); _bail_if_changed( ".", $starting_dev, $starting_ino ); return 1; } sub pathrm { my ( $path, $force, $nofail ) = @_; my ( $orig_dev, $orig_ino ) = ( lstat $path )[ 0, 1 ]; return 2 if !-d _ || !defined($orig_dev) || !$orig_ino; # Manual test (I hate this function :/): # sudo mkdir /foo && perl -MFile::Copy::Recursive=pathrm -le 'print pathrm("/foo",1)' && sudo rm -rf /foo if ( $force && File::Spec->file_name_is_absolute($path) ) { Carp::croak("pathrm() w/ force on abspath is not allowed"); } my @pth = File::Spec->splitdir($path); my %fs_check; my $aggregate_path; for my $part (@pth) { $aggregate_path = defined $aggregate_path ? File::Spec->catdir( $aggregate_path, $part ) : $part; $fs_check{$aggregate_path} = [ ( lstat $aggregate_path )[ 0, 1 ] ]; } while (@pth) { my $cur = File::Spec->catdir(@pth); last if !$cur; # necessary ??? if ($force) { _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] ); if ( !pathempty($cur) ) { return unless $nofail; } } _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] ); if ($nofail) { rmdir $cur; } else { rmdir $cur or return; } pop @pth; } return 1; } sub pathrmdir { my $dir = shift; if ( -e $dir ) { return if !-d $dir; } else { return 2; } my ( $orig_dev, $orig_ino ) = ( lstat $dir )[ 0, 1 ]; return 2 if !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino ); pathempty($dir) or return; _bail_if_changed( $dir, $orig_dev, $orig_ino ); rmdir $dir or return; return 1; } sub _bail_if_changed { my ( $path, $orig_dev, $orig_ino ) = @_; my ( $cur_dev, $cur_ino ) = ( lstat $path )[ 0, 1 ]; if ( !defined $cur_dev || !defined $cur_ino ) { $cur_dev ||= "undef(path went away?)"; $cur_ino ||= "undef(path went away?)"; } else { $path = Cwd::abs_path($path); } if ( $orig_dev ne $cur_dev || $orig_ino ne $cur_ino ) { local $Carp::CarpLevel += 1; Carp::croak("directory $path changed: expected dev=$orig_dev ino=$orig_ino, actual dev=$cur_dev ino=$cur_ino, aborting"); } } 1; __END__ =head1 NAME File::Copy::Recursive - Perl extension for recursively copying files and directories =head1 SYNOPSIS use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove); fcopy($orig,$new[,$buf]) or die $!; rcopy($orig,$new[,$buf]) or die $!; dircopy($orig,$new[,$buf]) or die $!; fmove($orig,$new[,$buf]) or die $!; rmove($orig,$new[,$buf]) or die $!; dirmove($orig,$new[,$buf]) or die $!; rcopy_glob("orig/stuff-*", $trg [, $buf]) or die $!; rmove_glob("orig/stuff-*", $trg [,$buf]) or die $!; =head1 DESCRIPTION This module copies and moves directories recursively (or single files, well... singley) to an optional depth and attempts to preserve each file or directory's mode. =head1 EXPORT None by default. But you can export all the functions as in the example above and the path* functions if you wish. =head2 fcopy() This function uses File::Copy's copy() function to copy a file but not a directory. Any directories are recursively created if need be. One difference to File::Copy::copy() is that fcopy attempts to preserve the mode (see Preserving Mode below) The optional $buf in the synopsis is the same as File::Copy::copy()'s 3rd argument. This function returns the same as File::Copy::copy() in scalar context and 1,0,0 in list context to accomodate rcopy()'s list context on regular files. (See below for more info) =head2 dircopy() This function recursively traverses the $orig directory's structure and recursively copies it to the $new directory. $new is created if necessary (multiple non existent directories is ok (i.e. foo/bar/baz). The script logically and portably creates all of them if necessary). It attempts to preserve the mode (see Preserving Mode below) and by default it copies all the way down into the directory (see Managing Depth, below). If a directory is not specified it croaks just like fcopy croaks if its not a file that is specified. This function returns true or false: for true in scalar context it returns the number of files and directories copied, whereas in list context it returns the number of files and directories, number of directories only, depth level traversed. my $num_of_files_and_dirs = dircopy($orig,$new); my($num_of_files_and_dirs,$num_of_dirs,$depth_traversed) = dircopy($orig,$new); Normally it stops and returns if a copy fails. To continue on regardless, set $File::Copy::Recursive::SkipFlop to true. local $File::Copy::Recursive::SkipFlop = 1; That way it will copy everythging it can in a directory and won't stop because of permissions, etc... =head2 rcopy() This function will allow you to specify a file *or* a directory. It calls fcopy() if you passed file and dircopy() if you passed a directory. If you call rcopy() (or fcopy() for that matter) on a file in list context, the values will be 1,0,0 since no directories and no depth are used. This is important because if it's a directory in list context and there is only the initial directory the return value is 1,1,1. =head2 rcopy_glob() This function lets you specify a pattern suitable for perl's File::Glob::bsd_glob() as the first argument. Subsequently each path returned by perl's File::Glob::bsd_glob() gets rcopy()ied. It returns and array whose items are array refs that contain the return value of each rcopy() call. It forces behavior as if $File::Copy::Recursive::CPRFComp is true. =head2 fmove() Copies the file then removes the original. You can manage the path the original file is in according to $RemvBase. =head2 dirmove() Uses dircopy() to copy the directory then removes the original. You can manage the path the original directory is in according to $RemvBase. =head2 rmove() Like rcopy() but calls fmove() or dirmove() instead. =head2 rmove_glob() Like rcopy_glob() but calls rmove() instead of rcopy() =head3 $RemvBase Default is false. When set to true the *move() functions will not only attempt to remove the original file or directory but will remove the given path it is in. So if you: rmove('foo/bar/baz', '/etc/'); # "baz" is removed from foo/bar after it is successfully copied to /etc/ local $File::Copy::Recursive::Remvbase = 1; rmove('foo/bar/baz','/etc/'); # if baz is successfully copied to /etc/ : # first "baz" is removed from foo/bar # then "foo/bar is removed via pathrm() =head4 $ForcePth Default is false. When set to true it calls pathempty() before any directories are removed to empty the directory so it can be rmdir()'ed when $RemvBase is in effect. =head2 Creating and Removing Paths =head3 $NoFtlPth Default is false. If set to true rmdir(), mkdir(), and pathempty() calls in pathrm() and pathmk() do not return() on failure. If its set to true they just silently go about their business regardless. This isn't a good idea but it's there if you want it. =head3 $DirPerms Mode to pass to any mkdir() calls. Defaults to 0777 as per umask()'s POD. Explicitly having this allows older perls to be able to use FCR and might add a bit of flexibility for you. Any value you set it to should be suitable for oct(). =head3 Path functions These functions exist solely because they were necessary for the move and copy functions to have the features they do and not because they are of themselves the purpose of this module. That being said, here is how they work so you can understand how the copy and move functions work and use them by themselves if you wish. =head4 pathrm() Removes a given path recursively. It removes the *entire* path so be careful!!! Returns 2 if the given path is not a directory. File::Copy::Recursive::pathrm('foo/bar/baz') or die $!; # foo no longer exists Same as: rmdir 'foo/bar/baz' or die $!; rmdir 'foo/bar' or die $!; rmdir 'foo' or die $!; An optional second argument makes it call pathempty() before any rmdir()'s when set to true. File::Copy::Recursive::pathrm('foo/bar/baz', 1) or die $!; # foo no longer exists Same as:PFSCheck File::Copy::Recursive::pathempty('foo/bar/baz') or die $!; rmdir 'foo/bar/baz' or die $!; File::Copy::Recursive::pathempty('foo/bar/') or die $!; rmdir 'foo/bar' or die $!; File::Copy::Recursive::pathempty('foo/') or die $!; rmdir 'foo' or die $!; An optional third argument acts like $File::Copy::Recursive::NoFtlPth, again probably not a good idea. =head4 pathempty() Recursively removes the given directory's contents so it is empty. Returns 2 if the given argument is not a directory, 1 on successfully emptying the directory. File::Copy::Recursive::pathempty($pth) or die $!; # $pth is now an empty directory =head4 pathmk() Creates a given path recursively. Creates foo/bar/baz even if foo does not exist. File::Copy::Recursive::pathmk('foo/bar/baz') or die $!; An optional second argument if true acts just like $File::Copy::Recursive::NoFtlPth, which means you'd never get your die() if something went wrong. Again, probably a *bad* idea. =head4 pathrmdir() Same as rmdir() but it calls pathempty() first to recursively empty it first since rmdir can not remove a directory with contents. Just removes the top directory the path given instead of the entire path like pathrm(). Returns 2 if the given argument does not exist (i.e. it's already gone). Returns false if it exists but is not a directory. =head2 Preserving Mode By default a quiet attempt is made to change the new file or directory to the mode of the old one. To turn this behavior off set $File::Copy::Recursive::KeepMode to false; =head2 Managing Depth You can set the maximum depth a directory structure is recursed by setting: $File::Copy::Recursive::MaxDepth to a whole number greater than 0. =head2 SymLinks If your system supports symlinks then symlinks will be copied as symlinks instead of as the target file. Perl's symlink() is used instead of File::Copy's copy(). You can customize this behavior by setting $File::Copy::Recursive::CopyLink to a true or false value. It is already set to true or false depending on your system's support of symlinks so you can check it with an if statement to see how it will behave: if($File::Copy::Recursive::CopyLink) { print "Symlinks will be preserved\n"; } else { print "Symlinks will not be preserved because your system does not support it\n"; } If symlinks are being copied you can set $File::Copy::Recursive::BdTrgWrn to true to make it carp when it copies a link whose target does not exist. It's false by default. local $File::Copy::Recursive::BdTrgWrn = 1; =head2 Removing existing target file or directory before copying. This can be done by setting $File::Copy::Recursive::RMTrgFil or $File::Copy::Recursive::RMTrgDir for file or directory behavior respectively. 0 = off (This is the default) 1 = carp() $! if removal fails 2 = return if removal fails local $File::Copy::Recursive::RMTrgFil = 1; fcopy($orig, $target) or die $!; # if it fails it does warn() and keeps going local $File::Copy::Recursive::RMTrgDir = 2; dircopy($orig, $target) or die $!; # if it fails it does your "or die" This should be unnecessary most of the time but it's there if you need it :) =head2 Turning off stat() check By default the files or directories are checked to see if they are the same (i.e. linked, or two paths (absolute/relative or different relative paths) to the same file) by comparing the file's stat() info. It's a very efficient check that croaks if they are and shouldn't be turned off but if you must for some weird reason just set $File::Copy::Recursive::PFSCheck to a false value. ("PFS" stands for "Physical File System") =head2 Emulating cp -rf dir1/ dir2/ By default dircopy($dir1,$dir2) will put $dir1's contents right into $dir2 whether $dir2 exists or not. You can make dircopy() emulate cp -rf by setting $File::Copy::Recursive::CPRFComp to true. NOTE: This only emulates -f in the sense that it does not prompt. It does not remove the target file or directory if it exists. If you need to do that then use the variables $RMTrgFil and $RMTrgDir described in "Removing existing target file or directory before copying" above. That means that if $dir2 exists it puts the contents into $dir2/$dir1 instead of $dir2 just like cp -rf. If $dir2 does not exist then the contents go into $dir2 like normal (also like cp -rf). So assuming 'foo/file': dircopy('foo', 'bar') or die $!; # if bar does not exist the result is bar/file # if bar does exist the result is bar/file $File::Copy::Recursive::CPRFComp = 1; dircopy('foo', 'bar') or die $!; # if bar does not exist the result is bar/file # if bar does exist the result is bar/foo/file You can also specify a star for cp -rf glob type behavior: dircopy('foo/*', 'bar') or die $!; # if bar does not exist the result is bar/file # if bar does exist the result is bar/file $File::Copy::Recursive::CPRFComp = 1; dircopy('foo/*', 'bar') or die $!; # if bar does not exist the result is bar/file # if bar does exist the result is bar/file NOTE: The '*' is only like cp -rf foo/* and *DOES NOT EXPAND PARTIAL DIRECTORY NAMES LIKE YOUR SHELL DOES* (i.e. not like cp -rf fo* to copy foo/*). =head2 Allowing Copy Loops If you want to allow: cp -rf . foo/ type behavior set $File::Copy::Recursive::CopyLoop to true. This is false by default so that a check is done to see if the source directory will contain the target directory and croaks to avoid this problem. If you ever find a situation where $CopyLoop = 1 is desirable let me know. (i.e. it's a bad bad idea but is there if you want it) (Note: On Windows this was necessary since it uses stat() to determine sameness and stat() is essentially useless for this on Windows. The test is now simply skipped on Windows but I'd rather have an actual reliable check if anyone in Microsoft land would care to share) =head1 SEE ALSO L L =head1 TO DO I am currently working on and reviewing some other modules to use in the new interface so we can lose the horrid globals as well as some other undesirable traits and also more easily make available some long standing requests. Tests will be easier to do with the new interface and hence the testing focus will shift to the new interface and aim to be comprehensive. The old interface will work, it just won't be brought in until it is used, so it will add no overhead for users of the new interface. I'll add this after the latest version has been out for a while with no new features or issues found :) =head1 AUTHOR Daniel Muey, L =head1 COPYRIGHT AND LICENSE Copyright 2004 by Daniel Muey This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut File-Copy-Recursive-0.45/t/02.legacy-symtogsafe.t000644 000766 000024 00000011053 13266716201 021764 0ustar00dmueystaff000000 000000 use strict; use warnings; use Test::More; use Test::Fatal; use File::Copy::Recursive qw(pathempty pathrm pathrmdir); if ( !$File::Copy::Recursive::CopyLink ) { plan skip_all => "symlink tests not applicable on systems w/ out symlink support ($^O)"; } elsif ( !-x "/bin/mv" || !-x "/bin/mkdir" ) { # dragons! patches welcome plan skip_all => 'Only operate on systems w/ /bin/mv and /bin/mkdir, for reasons see the cource code comments'; } else { plan tests => 33; } use File::Temp; use Cwd; use File::Spec; my $orig_dir = Cwd::cwd(); my $dir = File::Temp->newdir(); our $catdir_toggle = sub { }; our @catdir_calls; chdir $dir || die "Could not chdir into temp directory: $!\n"; # so we can pathrm(), dragons! { ############################################################################## #### Wrap catdir() to control a symlink toggle in the path traversal loops. ## ############################################################################## no strict "refs"; no warnings "redefine", "once"; my $real_catdir = \&{ $File::Spec::ISA[0] . "::catdir" }; local *File::Spec::catdir = sub { my ( $self, @args ) = @_; push @catdir_calls, \@args; $catdir_toggle->(@args); goto &$real_catdir; }; mkdir "pathempty"; mkdir "pathempty/sanity"; pathempty("pathempty"); is( @catdir_calls, 1, "sanity check: catdir was actually called in the pathempty() loop" ); mkdir "pathrmdir"; mkdir "pathrmdir/sanity"; pathrmdir("$dir/pathrmdir"); is( @catdir_calls, 2, "sanity check: catdir was actually called in the pathrmdir() loop" ); mkdir "pathrm"; mkdir "pathrm/sanity"; pathrm("pathrm"); is( @catdir_calls, 3, "sanity check: catdir was actually called in the pathrm() loop" ); #################### #### Actual tests ## #################### for my $func (qw(pathrm pathempty pathrmdir)) { _test( $func, "cwd/foo/bar/baz", "bails when high level changes" ); _test( $func, "cwd/foo/bar", "bails when mid level changes" ); _test( $func, "cwd/foo", "bails when low level changes" ); _test( $func, "cwd", "bails when CWD level changes" ); _test( $func, "", "bails when below level changes" ); } } chdir $orig_dir || die "Could not chdir back to original directory: $!\n"; ############### #### helpers ## ############### sub _test { my ( $func, $toggle, $label ) = @_; _setup_tree($func); { local @catdir_calls = (); local $catdir_toggle = sub { return if $func eq 'pathrm' && @catdir_calls < 3; # let it do its first round, this mockage is gross … chdir $dir || die "could not toggle dir/symlink (chdir): $!"; my $parent = ""; if ($toggle) { $parent = $toggle; $parent =~ s{[^/]+$}{}; # use system call since the perl to do this will likely use File::Spec system("/bin/mkdir -p moved/$func/$parent") and die "could not toggle dir/symlink (mkdir): $?\n"; } # use system call since the perl to do this will likely use File::Spec system("/bin/mv $dir/$func/$toggle $dir/moved/$func/$toggle") and die "could not toggle dir/symlink (mv): $?\n"; symlink( "$dir/victim", "$dir/$func" . ( $toggle ? "/$toggle" : "" ) ) or die "could not toggle dir/symlink (sym): $!\n"; chdir "$func/cwd" || die "could not toggle dir/symlink (back into $func/cwd): $!\n"; }; like exception { no strict "refs"; $func->("foo/bar/baz") }, qr/directory .* changed: expected dev=.* ino=.*, actual dev=.* ino=.*, aborting/, "$func() detected symlink toggle: $label"; is( @catdir_calls, $func eq 'pathrm' ? 3 : 1, "sanity check: catdir was actually called in $func() ($label)" ); } _teardown_tree($func); } sub _teardown_tree { my ($base) = @_; chdir $dir || die "Could not chdir back into temp dir: $!\n"; pathrmdir($base); pathrmdir("moved/"); pathrmdir("victim/"); return; } sub _setup_tree { my ($base) = @_; for my $dir ( "moved", "victim", "victim/cwd", $base, "$base/cwd", "$base/cwd/foo", "$base/cwd/foo/bar", "$base/cwd/foo/bar/baz" ) { mkdir $dir || die "Could not make test tree ($dir): $!\n"; open my $fh, ">", "$dir/file.txt" || die "Could not make test file in ($dir): $!\n"; print {$fh} "oh hai\n"; close($fh); } chdir "$base/cwd" || die "Could not chdir into $base/cwd: $!\n"; return; } File-Copy-Recursive-0.45/t/01.legacy.t000644 000766 000024 00000035243 13266720475 017623 0ustar00dmueystaff000000 000000 use strict; use warnings; our $curr_unlink = sub { return CORE::unlink(@_) }; # I wish goto would work here :/ BEGIN { no warnings 'redefine'; *CORE::GLOBAL::unlink = sub { goto $curr_unlink }; } use Test::More; use Test::Deep; use Test::File; use Test::Warnings 'warnings'; use Path::Tiny; use File::Temp; use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir rcopy_glob rmove_glob); umask 022; # for consistent testing note "functionality w/ default globals"; { is( $File::Copy::Recursive::DirPerms, 0777, "DirPerms default is 0777" ); ok( !$File::Copy::Recursive::CPRFComp, "CPRFComp default is false" ); ok( !$File::Copy::Recursive::RMTrgFil, "RMTrgFil default is false" ); my $tmpd = _get_fresh_tmp_dir(); # dircopy() { my $rv = dircopy( "$tmpd/orig", "$tmpd/new" ); _is_deeply_path( "$tmpd/new", "$tmpd/orig", "dircopy() defaults as expected when target does not exist" ); mkdir "$tmpd/newnew"; my @dircopy_rv = dircopy( "$tmpd/orig", "$tmpd/newnew" ); _is_deeply_path( "$tmpd/newnew", "$tmpd/orig", "dircopy() defaults as expected when target does exist" ); $rv = dircopy( "$tmpd/orig/data", "$tmpd/new" ); ok( !$rv, "dircopy() returns false if source is not a directory" ); $rv = dircopy( "$tmpd/orig", "$tmpd/new/data" ); ok( !$rv, "dircopy() returns false if target is not a directory" ); } # dirmove() { my $rv = dirmove( "$tmpd/newnew", "$tmpd/moved" ); _is_deeply_path( "$tmpd/moved", "$tmpd/orig", "dirmove() defaults as expected when target does not exist" ); ok( !-d "$tmpd/newnew", "dirmove() removes source (when target does not exist)" ); mkdir "$tmpd/movedagain"; my @dirmove_rv = dirmove( "$tmpd/moved", "$tmpd/movedagain" ); _is_deeply_path( "$tmpd/movedagain", "$tmpd/orig", "dirmove() defaults as expected when target does exist" ); ok( !-d "$tmpd/moved", "dirmove() removes source (when target does exist)" ); $rv = dirmove( "$tmpd/orig/data", "$tmpd/new" ); ok( !$rv, "dirmove() returns false if source is not a directory" ); ok( -e "$tmpd/orig/data", "dirmove() does not delete source if source is not a directory" ); $rv = dirmove( "$tmpd/orig", "$tmpd/new/data" ); ok( !$rv, "dirmove() returns false if target is not a directory" ); ok( -e "$tmpd/orig", "dirmove() does not delete source if target is not a directory" ); } # fcopy() { # that fcopy copies files and symlinks is covered by the dircopy tests, specifically _is_deeply_path() my $rv = fcopy( "$tmpd/orig/data", "$tmpd/fcopy" ); is( path("$tmpd/orig/data")->slurp, path("$tmpd/fcopy")->slurp, "fcopy() defaults as expected when target does not exist" ); path("$tmpd/fcopyexisty")->spew("oh hai"); my @fcopy_rv = fcopy( "$tmpd/orig/data", "$tmpd/fcopyexisty" ); is( path("$tmpd/orig/data")->slurp, path("$tmpd/fcopyexisty")->slurp, "fcopy() defaults as expected when target does exist" ); $rv = fcopy( "$tmpd/orig", "$tmpd/fcopy" ); ok( !$rv, "fcopy() returns false if source is a directory" ); } # fmove() WiP { # that fmove copies files and symlinks is covered by the dirmove tests, specifically _is_deeply_path() path("$tmpd/data")->spew("oh hai"); my $rv = fmove( "$tmpd/data", "$tmpd/fmove" ); ok( $rv && !-e "$tmpd/data", "fmove() removes source file (target does not exist)" ); path("$tmpd/existy")->spew("42"); path("$tmpd/fmoveexisty")->spew("oh hai"); my @fmove_rv = fmove( "$tmpd/existy", "$tmpd/fmoveexisty" ); ok( $rv && !-e "$tmpd/existy", "fmove() removes source file (target does exist)" ); $rv = fmove( "$tmpd/orig", "$tmpd/fmove" ); ok( !$rv, "fmove() returns false if source is a directory" ); } # rcopy() { my $rv = rcopy( "$tmpd/orig/noexist", "$tmpd/rcopy/" ); ok !$rv, 'rcopy() returns false on non existant path'; no warnings "redefine"; my @dircopy_calls; my @fcopy_calls; local *File::Copy::Recursive::dircopy = sub { push @dircopy_calls, [@_] }; local *File::Copy::Recursive::fcopy = sub { push @fcopy_calls, [@_] }; File::Copy::Recursive::rcopy( "$tmpd/orig/", "$tmpd/rcopy/" ); is( @dircopy_calls, 1, 'rcopy() dispatches directory to dircopy()' ); File::Copy::Recursive::rcopy( "$tmpd/orig/*", "$tmpd/rcopy/" ); is( @dircopy_calls, 2, 'rcopy() dispatches directory glob to dircopy()' ); File::Copy::Recursive::rcopy( "$tmpd/empty", "$tmpd/rcopy/" ); is( @fcopy_calls, 1, 'rcopy() dispatches empty file to fcopy()' ); File::Copy::Recursive::rcopy( "$tmpd/data", "$tmpd/rcopy/" ); is( @fcopy_calls, 2, 'rcopy() dispatches file (w/ trailing new line)to fcopy()' ); File::Copy::Recursive::rcopy( "$tmpd/data_tnl", "$tmpd/rcopy/" ); is( @fcopy_calls, 3, 'rcopy() dispatches file (w/ no trailing new line) to fcopy()' ); SKIP: { skip "symlink tests not applicable on systems w/ out symlink support ($^O)", 3 unless $File::Copy::Recursive::CopyLink; File::Copy::Recursive::rcopy( "$tmpd/symlink", "$tmpd/rcopy/" ); is( @fcopy_calls, 4, 'rcopy() dispatches symlink to fcopy()' ); File::Copy::Recursive::rcopy( "$tmpd/symlink-broken", "$tmpd/rcopy/" ); is( @fcopy_calls, 5, 'rcopy() dispatches broken symlink to fcopy()' ); File::Copy::Recursive::rcopy( "$tmpd/symlink-loopy", "$tmpd/rcopy/" ); is( @fcopy_calls, 6, 'rcopy() dispatches loopish symlink to fcopy()' ); } } # rmove() { my $rv = rmove( "$tmpd/orig/noexist", "$tmpd/rmove/" ); ok !$rv, 'rmove() returns false on non existant path'; no warnings "redefine"; my @dirmove_calls; my @fmove_calls; local *File::Copy::Recursive::dirmove = sub { push @dirmove_calls, [@_] }; local *File::Copy::Recursive::fcopy = sub { push @fmove_calls, [@_] }; File::Copy::Recursive::rmove( "$tmpd/orig/", "$tmpd/rmove/" ); is( @dirmove_calls, 1, 'rmove() dispatches directory to dirmove()' ); File::Copy::Recursive::rmove( "$tmpd/orig/*", "$tmpd/rmove/" ); is( @dirmove_calls, 2, 'rmove() dispatches directory glob to dirmove()' ); File::Copy::Recursive::rmove( "$tmpd/empty", "$tmpd/rmove/" ); is( @fmove_calls, 1, 'rmove() dispatches empty file to fcopy()' ); File::Copy::Recursive::rmove( "$tmpd/data", "$tmpd/rmove/" ); is( @fmove_calls, 2, 'rmove() dispatches file (w/ trailing new line)to fcopy()' ); File::Copy::Recursive::rmove( "$tmpd/data_tnl", "$tmpd/rmove/" ); is( @fmove_calls, 3, 'rmove() dispatches file (w/ no trailing new line) to fcopy()' ); SKIP: { skip "symlink tests not applicable on systems w/ out symlink support ($^O)", 3 unless $File::Copy::Recursive::CopyLink; File::Copy::Recursive::rmove( "$tmpd/symlink", "$tmpd/rmove/" ); is( @fmove_calls, 4, 'rmove() dispatches symlink to fcopy()' ); File::Copy::Recursive::rmove( "$tmpd/symlink-broken", "$tmpd/rmove/" ); is( @fmove_calls, 5, 'rmove() dispatches broken symlink to fcopy()' ); File::Copy::Recursive::rmove( "$tmpd/symlink-loopy", "$tmpd/rmove/" ); is( @fmove_calls, 6, 'rmove() dispatches loopish symlink to fcopy()' ); } } # rcopy_glob() { my @rcopy_srcs; no warnings "redefine"; local *File::Copy::Recursive::rcopy = sub { push @rcopy_srcs, $_[0] }; rcopy_glob( "$tmpd/orig/*l*", "$tmpd/rcopy_glob" ); is( @rcopy_srcs, $File::Copy::Recursive::CopyLink ? 4 : 1, "rcopy_glob() calls rcopy for each file in the glob" ); } # rmove_glob() { my @rmove_srcs; no warnings "redefine"; local *File::Copy::Recursive::rmove = sub { push @rmove_srcs, $_[0] }; rmove_glob( "$tmpd/orig/*l*", "$tmpd/rmove_glob" ); is( @rmove_srcs, $File::Copy::Recursive::CopyLink ? 4 : 1, "rmove_glob() calls rmove for each file in the glob" ); } # pathempty() { ok( -e "$tmpd/new/data", "file exists" ); my $rv = pathempty("$tmpd/new"); is( $rv, 1, "correct return value for pathempty" ); ok( !-e "$tmpd/new/data", "file was removed" ); ok( -d "$tmpd/new", "directory still exists" ); } # pathrmdir() { my $rv = pathrmdir("$tmpd/orig"); is( $rv, 1, "correct return value for pathrmdir" ); ok( !-d "$tmpd/orig", "directory was removed" ); } # PATCHES WELCOME! # TODO: tests for sameness behavior and it use in all of these functions # TODO: @rv behavior in all of these functions # TODO: test for util functions; pathmk pathrm pathempty pathrmdir } note "functionality w/ 'value' globals"; { local $File::Copy::Recursive::DirPerms = 0751; my $tmpd = _get_fresh_tmp_dir(); mkdir( "$tmpd/what", 0777 ); File::Copy::Recursive::pathmk("$tmpd/what/what/what"); file_mode_isnt( "$tmpd/what", 0751, 'DirPerms in pathmk() does not effect existing dir' ); file_mode_is( "$tmpd/what/what", 0751, 'DirPerms in pathmk() effects initial new dir' ); file_mode_is( "$tmpd/what/what/what", 0751, 'DirPerms in pathmk() effects subsequent new dir' ); local $File::Copy::Recursive::KeepMode = 0; # overrides $DirPerms in dircopy() File::Copy::Recursive::dircopy( "$tmpd/orig", "$tmpd/new" ); for my $dir ( _get_dirs() ) { $dir =~ s/orig/new/; file_mode_is( "$tmpd/$dir", 0751, "DirPerms in dircopy() effects dir ($dir)" ); } } note "functionality w/ 'behavior' globals"; { { local $File::Copy::Recursive::CPRFComp = 1; my $tmpd = _get_fresh_tmp_dir(); File::Copy::Recursive::dircopy( "$tmpd/orig", "$tmpd/new" ); _is_deeply_path( "$tmpd/new", "$tmpd/orig", "CPRFComp being true effects dircopy() as expected when target does not exist" ); mkdir "$tmpd/existy"; File::Copy::Recursive::dircopy( "$tmpd/orig", "$tmpd/existy" ); _is_deeply_path( "$tmpd/existy/orig", "$tmpd/orig", "CPRFComp being true effects dircopy() as expected when target exists" ); File::Copy::Recursive::dircopy( "$tmpd/orig/*", "$tmpd/newnew" ); _is_deeply_path( "$tmpd/newnew", "$tmpd/orig", "CPRFComp being true w/ glob path effects dircopy() as expected when target does not exist" ); mkdir "$tmpd/existify"; File::Copy::Recursive::dircopy( "$tmpd/orig/*", "$tmpd/existify" ); _is_deeply_path( "$tmpd/existify", "$tmpd/orig", "CPRFComp being true w/ glob path effects dircopy() as expected when target exists" ); } { my $tmpd = _get_fresh_tmp_dir(); local $File::Copy::Recursive::RMTrgFil = 1; local $curr_unlink = sub { $! = 5; return; }; mkdir "$tmpd/derp"; path("$tmpd/derp/data")->spew("I exist therefor I am."); my @warnings = warnings { my $rv = File::Copy::Recursive::fcopy( "$tmpd/orig/data", "$tmpd/derp/data" ); ok( $rv, "fcopy() w/ \$RMTrgFil = 1 to file-returned true" ); }; cmp_deeply \@warnings, [ re(qr/RMTrgFil failed/) ], "fcopy() w/ \$RMTrgFil = 1 to file-warned"; @warnings = warnings { my $rv = File::Copy::Recursive::fcopy( "$tmpd/orig/data", "$tmpd/derp" ); ok( $rv, "fcopy() w/ \$RMTrgFil = 1 to dir-returned true" ); }; cmp_deeply \@warnings, [ re(qr/RMTrgFil failed/) ], "fcopy() w/ \$RMTrgFil = 1 to dir-warned"; } { my $tmpd = _get_fresh_tmp_dir(); local $File::Copy::Recursive::RMTrgFil = 2; local $curr_unlink = sub { $! = 5; return; }; mkdir "$tmpd/derp"; path("$tmpd/derp/data")->spew("I exist therefor I am."); my @warnings = warnings { my $rv = File::Copy::Recursive::fcopy( "$tmpd/orig/data", "$tmpd/derp/data" ); ok( !$rv, "fcopy() w/ \$RMTrgFil = 2 to file-returned false" ); }; cmp_deeply \@warnings, [], "fcopy() w/ \$RMTrgFil = 2 to file-no warning"; @warnings = warnings { my $rv = File::Copy::Recursive::fcopy( "$tmpd/orig/data", "$tmpd/derp" ); ok( !$rv, "fcopy() w/ \$RMTrgFil = 2 to dir-returned false" ); }; cmp_deeply \@warnings, [], "fcopy() w/ \$RMTrgFil = 2 to dir-no warning"; } # TODO (this is one reason why globals are not awesome :/) # $MaxDepth # $KeepMode # $CopyLink # $BdTrgWrn # $PFSCheck # $RemvBase # ForcePth # $NoFtlPth # $ForcePth # $CopyLoop # $RMTrgDir # $CondCopy # $BdTrgWrn # $SkipFlop } done_testing; ############### #### helpers ## ############### sub _get_dirs { return (qw(orig orig/foo orig/foo/bar orig/foo/baz orig/foo/bar/wop)); } sub _get_fresh_tmp_dir { my $tmpd = File::Temp->newdir; for my $dir ( _get_dirs() ) { mkdir "$tmpd/$dir" or die "Could not mkdir($tmpd/$dir) :$!\n"; path("$tmpd/$dir/empty")->spew(""); path("$tmpd/$dir/data")->spew("oh hai\n$tmpd/$dir"); path("$tmpd/$dir/data_tnl")->spew("oh hai\n$tmpd/$dir\n"); if ($File::Copy::Recursive::CopyLink) { symlink( "data", "$tmpd/$dir/symlink" ); symlink( "noexist", "$tmpd/$dir/symlink-broken" ); symlink( "..", "$tmpd/$dir/symlink-loopy" ); } } return $tmpd; } sub _is_deeply_path { my ( $got_dir, $expected_dir, $test_name ) = @_; my $got_tree_hr = _get_tree_hr($got_dir); my $expected_tree_hr = _get_tree_hr($expected_dir); is_deeply( $got_tree_hr, $expected_tree_hr, $test_name ); for my $path ( sort keys %{$got_tree_hr} ) { if ( $got_tree_hr->{$path} eq "symlink" ) { is( readlink("$got_dir/$path"), readlink("$expected_dir/$path"), " - symlink target preserved (…$path)" ); } elsif ( $got_tree_hr->{$path} eq "file" ) { is( path("$got_dir/$path")->slurp, path("$expected_dir/$path")->slurp, " - file contents preserved (…$path)" ); } } } sub _get_tree_hr { my ($dir) = @_; return if !-d $dir; my %tree; my $fetch = path($dir)->iterator; $dir =~ s#\\#\/#g if $^O eq 'MSWin32'; #->iterator returns paths with '/' while ( my $next_path = $fetch->() ) { my $normalized_next_path = $next_path; $normalized_next_path =~ s/\Q$dir\E//; $tree{$normalized_next_path} = -l $next_path ? "symlink" : -f $next_path ? "file" : -d $next_path ? "directory" : "¯\_(ツ)_/¯"; } return \%tree; } File-Copy-Recursive-0.45/t/05.legacy-pathmk_unc.t000644 000766 000024 00000004536 13267627173 021761 0ustar00dmueystaff000000 000000 use strict; use warnings; use Cwd; use File::Copy::Recursive qw(pathmk pathempty); use File::Temp (); use Path::Tiny; use Test::More; if ( $^O ne 'MSWin32' ) { plan skip_all => 'Test irrelevant on non-windows OSs'; } else { plan tests => 6; } diag("Testing legacy File::Copy::Recursive::pathmk() $File::Copy::Recursive::VERSION"); is( _translate_to_unc('C:/foo/bar.txt'), '//127.0.0.1/C$/foo/bar.txt', 'sanity check: _translate_to_unc w/ /' ); is( _translate_to_unc('C:\\foo\\bar.txt'), '\\\\127.0.0.1\\C$\\foo\\bar.txt', 'sanity check: _translate_to_unc w/ \\' ); my $tempdir = File::Temp->newdir(); my @members = _all_files_in($tempdir); is_deeply( \@members, [], 'sanity check: created empty temp dir' ); pathmk("$tempdir\\foo\\bar\\baz"); # create regular path @members = _all_files_in($tempdir); ok( -d "$tempdir\\foo\\bar\\baz", "pathmk(regular path) creates path" ); pathempty($tempdir); @members = _all_files_in($tempdir); is_deeply( \@members, [], 'sanity check: temp dir empty again' ); my $uncpath = _translate_to_unc($tempdir); pathmk("$uncpath\\foo\\bar\\baz"); # create UNC path @members = _all_files_in($tempdir); ok( -d "$tempdir\\foo\\bar\\baz", "pathmk(unc path) creates path" ); ############### #### helpers ## ############### sub _all_files_in { my $dir = shift; my $state = path($dir)->visit( sub { my ( $path, $state ) = @_; push @{ $state->{files} }, $path; }, { recurse => 1 }, ); return map { "$_" } @{ $state->{files} || [] }; } sub _translate_to_unc { my ($path) = @_; die "Should be called on Windows only!" unless $^O eq 'MSWin32'; if ( $path =~ m|^\w:([/\\])| ) { # an absolute path with a Windows-style drive letter my $sep = $1; # C:\path\foo.txt corresponds to \\127.0.0.1\C$\path\foo.txt (if \ # is regarded as a regular character, not an escape character). # Prefix UNC part, using path separator from original $path =~ s|^(\w):|$sep${sep}127.0.0.1${sep}$1\$|; } else { # a relative path my ($sep) = $path =~ m|([\\/])|; # locate path separator $sep ||= '\\'; # default to backslash $path = translate_to_unc( Cwd::getcwd() . $sep . $path ); # assumes that Cwd::getcwd() returns a path with a drive letter! } $path; } File-Copy-Recursive-0.45/t/04.readonly-dir.t000644 000766 000024 00000001722 13515615240 020734 0ustar00dmueystaff000000 000000 use strict; use warnings; use Test::More 0.88; use Test::Warnings 'warnings'; use Test::Deep; use File::Temp; use Path::Tiny; use File::Copy::Recursive 'dircopy'; if ( $^O eq 'MSWin32' ) { plan skip_all => "test uses chmod which may or may not do what we want here, patches welcome!"; } my $dir = File::Temp->newdir; for my $pth (qw(src/ src/top src/top/sub1 src/top/sub2)) { mkdir "$dir/$pth"; } path("$dir/src/top/sub1/file1.2")->spew("hello-1.2"); path("$dir/src/top/sub2/file2.2")->spew("hello-2.2"); path("$dir/src/top/sub2/file2.1")->spew(""); `chmod -w $dir/src/top/sub2`; SKIP: { skip "test read only", 3, if -w "$dir/src/top/sub2"; my @warnings = warnings { dircopy( "$dir/src", "$dir/dest" ) }; is( scalar( path("$dir/src/top/sub2")->children ), 2, "readonly direct0ry contents are copied" ); is( scalar( path("$dir/src/top/sub1")->children ), 1, "writable directory contents are copied" ); } `chmod +w $dir/src/top/sub2`; done_testing; File-Copy-Recursive-0.45/t/00.load.t000644 000766 000024 00000000105 13266367102 017254 0ustar00dmueystaff000000 000000 use Test::More tests => 1; BEGIN { use_ok('File::Copy::Recursive') } File-Copy-Recursive-0.45/t/03.github-issue-5.t000644 000766 000024 00000001275 13266367103 021124 0ustar00dmueystaff000000 000000 #!/usr/bin/perl # # Test for Github Issue #5 # pathmk doesn't make deep directories # # Created by Joelle Maslak # use strict; use warnings; use Test::More; use File::Temp; use File::Copy::Recursive qw(pathmk); my $tmpd = File::Temp->newdir; note("Temp Dir: $tmpd"); # pathmk() pathmk("$tmpd/1"); ok( ( -d "$tmpd/1" ), "Directories (1 directory deep) are created" ); pathmk("$tmpd/2/2"); ok( ( -d "$tmpd/2/2" ), "Deep directories (2 directories deep) are created" ); pathmk("$tmpd/3/3/3"); ok( ( -d "$tmpd/3/3/3" ), "Deep directories (3 directories deep) are created" ); pathmk("$tmpd/4/4/4/4"); ok( ( -d "$tmpd/4/4/4/4" ), "Deep directories (4 directories deep) are created" ); done_testing;