File-Copy-Recursive-Reduced-0.008/0000755000175000017500000000000014600302103016423 5ustar jkeenanjkeenanFile-Copy-Recursive-Reduced-0.008/META.json0000664000175000017500000000344214600302103020051 0ustar jkeenanjkeenan{ "abstract" : "Recursive copying of files and directories within Perl 5 toolchain", "author" : [ "James E Keenan (jkeenan@cpan.org)" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "File-Copy-Recursive-Reduced", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "File::Copy" : "0", "File::Find" : "0", "File::Path" : "0", "File::Spec" : "0", "perl" : "5.008000" } }, "test" : { "requires" : { "Capture::Tiny" : "0", "File::Path" : "0", "File::Spec" : "0", "File::Temp" : "0", "Path::Tiny" : "0", "Test::Simple" : "0.44" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=File-Copy-Recursive-Reduced" }, "homepage" : "http://thenceforward.net/perl/modules/File-Copy-Recursive-Reduced/", "repository" : { "type" : "git", "url" : "https://github.com/jkeenan/file-copy-recursive-reduced.git", "web" : "https://github.com/jkeenan/file-copy-recursive-reduced" } }, "version" : "0.008", "x_serialization_backend" : "JSON::PP version 4.16" } File-Copy-Recursive-Reduced-0.008/Changes0000644000175000017500000000327314600301564017735 0ustar jkeenanjkeenanRevision history for Perl module File::Copy::Recursive::Reduced 0.008 Mon Mar 25 09:59:23 AM EDT 2024 - Encoding directive added to POD, contributed by gregor herrmann from Debian. - Corrections in test files to guard against CPANtesters who run tests with PERL_AUTHOR_TESTING turned on. 0.007 Sat Sep 16 07:48:17 AM EDT 2023 - Corrections (in test files only) to better accommodate Windows path separators, mostly provided by Håkon Hægland. 0.006 Fri Apr 20 10:21:48 EDT 2018 - File::Copy::Recursive 0.41 has been released to CPAN and addresses the problem which was the focus of File::Copy::Recursive::Reduced. Hence, FCR2 is now feature-complete. 0.005 Thu Apr 19 21:03:28 EDT 2018 - Implement copying of symlinks within all three public functions. At this point we should be able to make substitutions for File::Copy::Recursive's fcopy(), dircopy() and rcopy() functions in a large proportion of toolchain libraries, particularly in test suites. 0.004 Thu Apr 19 11:20:52 EDT 2018 - Introduce rcopy(), a stripped-down replacement for File::Copy::Recursive::rcopy(). (But no support for symlinks yet in this or any other exportable function.) 0.003 Tue Apr 17 09:14:19 EDT 2018 - No changes in functionality; changes only to documentation. 0.002 Mon Apr 16 17:51:13 EDT 2018 - Object-oriented interface replaced; module now exports fcopy() and dircopy() on demand. - Should be usable as replacement for File::Copy::Recursive in the test suite for CPAN-Reporter. 0.001 Tue Apr 10 22:03:22 2018 - Original version; created by ExtUtils::ModuleMaker 0.56; - Not yet ready for use. File-Copy-Recursive-Reduced-0.008/lib/0000755000175000017500000000000014600302103017171 5ustar jkeenanjkeenanFile-Copy-Recursive-Reduced-0.008/lib/File/0000755000175000017500000000000014600302103020050 5ustar jkeenanjkeenanFile-Copy-Recursive-Reduced-0.008/lib/File/Copy/0000755000175000017500000000000014600302103020762 5ustar jkeenanjkeenanFile-Copy-Recursive-Reduced-0.008/lib/File/Copy/Recursive/0000755000175000017500000000000014600302103022731 5ustar jkeenanjkeenanFile-Copy-Recursive-Reduced-0.008/lib/File/Copy/Recursive/Reduced.pm0000644000175000017500000004130314600301454024653 0ustar jkeenanjkeenanpackage File::Copy::Recursive::Reduced; use strict; use warnings; use parent qw( Exporter ); our @EXPORT_OK = qw( dircopy fcopy rcopy ); our $VERSION = '0.008'; use File::Copy; use File::Find; use File::Path qw( mkpath ); use File::Spec; our $Link = eval { local $SIG{'__DIE__'}; link '', ''; 1 } || 0; our $CopyLink = eval { local $SIG{'__DIE__'}; symlink '', ''; 1 } || 0; our $DirPerms = 0777; =encoding UTF-8 =head1 NAME File::Copy::Recursive::Reduced - Recursive copying of files and directories within Perl 5 toolchain =head1 SYNOPSIS use File::Copy::Recursive::Reduced qw(fcopy dircopy); fcopy($orig,$new) or die $!; dircopy($orig,$new) or die $!; =head1 DESCRIPTION This library is intended as a not-quite-drop-in replacement for certain functionality provided by L. The library provides methods similar enough to that distribution's C, C and C functions to be usable in those CPAN distributions often described as being part of the Perl toolchain. =head2 Rationale F (hereinafter referred to as B) is heavily used in other CPAN libraries. Out of over 30,000 other CPAN distributions studied in early 2018, it ranks by one calculation as the 129th highest distribution in terms of its total direct and indirect reverse dependencies. In current parlance, it sits C Hence, it ought to work correctly and be installable on all operating systems where Perl is well supported. However, as of early April 2018, FCR version 0.40 wass failing to pass its tests against either Perl 5.26 or Perl 5 blead on important operating systems including Windows, FreeBSD and NetBSD (L). As a consequence, CPAN installers such as F and F were failing to install it (unless one resorted to the C<--force> option). This prevented distributions dependent (directly or indirectly) on FCR from being installed as well. Some patches had been provided to the L for this problem. However, as late as April 18 2018 those patches had not yet been applied. This posed a critical problem for the ability to assess the impact of the soon-to-be-released perl-5.28.0 on CPAN distributions (the so-called "Blead Breaks CPAN" ("BBC") problem) on platforms other than Linux. F (hereinafter referred to as B) is intended to provide a minimal subset of FCR's functionality -- just enough to get the Perl toolchain working on the platforms where FCR is currently failing. Functions will be added to FCR2 only insofar as investigation shows that they can replace usage of FCR functions in toolchain and other heavily used modules. No attempt will be made to reproduce all the functionality currently provided or claimed to be provided by FCR. On April 19 2018, FCR's author, Daniel Muey, released version 0.41 to CPAN. This version included a patch submitted by Tom Hukins which corrected the problem addressed by FCR2. FCR once again built and tested correctly on FreeBSD. That meant that its 6000-plus reverse dependencies can once again be reached by F and other installers. That in turn means that we can conduct exhaustive BBC investigations on FreeBSD and other platforms. With that correction in FCR, the original rationale for FCR2 has been superseded. I will continue to maintain the code and respond to bug reports, but am suspending active development. I now deem FCR2 feature-complete. =head1 SUBROUTINES The current version of FCR2 provides three exportable and publicly supported subroutines partially equivalent to the similarly named subroutines exported by FCR. =head2 C =over 4 =item * Purpose A stripped-down replacement for C. Copies a file to a new location, recursively creating directories as needed. Does not copy directories. Unlike C, C attempts to preserve the mode of the original file. =item * Arguments fcopy($orig, $new) or die $!; List of two required arguments: =over 4 =item * Absolute path to the file being copied; and =item * Absolute path to the location to which the file is being copied. =back Four cases should be noted: =over 4 =item 1 Create copy within same directory but new basename fcopy('/path/to/filename', '/path/to/newfile'); The second argument must be the absolute path to the new file. (Otherwise the file will be created in the current working directory, which is almost certainly what you do not want.) =item 2 Create copy within different, already B directory, same basename fcopy('/path/to/filename', '/path/to/existing/directory'); The second argument can be merely the path to the existing directory; will create F. =item 3 Create copy within different, not yet existing directory, same basename fcopy('/path/to/filename', '/path/not/yet/existing/directory/filename'); The second argument will be interpreted as the complete path to the newly created file. The basename must be included even if it is the same as in the first argument. Will create F. =item 4 Create copy within different, not yet existing directory, different basename fcopy('/path/to/filename', '/path/not/yet/existing/directory/newfile'); The second argument will be interpreted as the complete path to the newly created file. Will create F. =back =item * Return Value Returns C<1> upon success; C<0> upon failure. Returns an undefined value if, for example, function cannot validate arguments. =item * Comment Since C internally uses C to perform the copying, the arguments are subject to the same qualifications as that function's arguments. Call F for discussion of those arguments. =back =cut sub fcopy { return unless @_ == 2; my ($from, $to) = @_; #return unless _samecheck($from, $to); return unless _basic_samecheck($from, $to); # TODO: Explore whether we should check (-e $from) here. # If we don't have a starting point, it shouldn't make any sense to go # farther. return unless _dev_ino_check($from, $to); return _fcopy($from, $to); } sub _fcopy { my ($from, $to) = @_; my ( $volm, $path ) = File::Spec->splitpath($to); # TODO: Explore whether it's possible for $path to be Perl-false in # following line. If not, remove. if ( $path && !-d $path ) { pathmk(File::Spec->catpath($volm, $path, '')); } if ( -l $from && $CopyLink ) { my $target = readlink( $from ); # FCR: mass-untaint is OK since we have to allow what the file system does ($target) = $target =~ m/(.*)/; warn "Copying a symlink ($from) whose target does not exist" if !-e $target; my $new = $to; unlink $new if -l $new; symlink( $target, $new ) or return; } elsif (-d $from && -f $to) { return; } else { copy($from, $to) or return; my @base_file = File::Spec->splitpath( $from ); my $mode_trg = -d $to ? File::Spec->catfile( $to, $base_file[$#base_file] ) : $to; chmod scalar((stat($from))[2]), $mode_trg; } return 1; } sub pathmk { my ( $vol, $dir, $file ) = File::Spec->splitpath( shift() ); # TODO: Exploration whether $dir can be undef at this point. # If possible, then we should probably return immediately. 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 ); return unless -d $newpth; } } # TODO: Exploration whether $file can be undef at this point. # If possible, then we should probably return immediately. if ( defined($file) ) { my $newpth = File::Spec->catpath( $vol, $dir, $file ); mkdir( $newpth ); return unless -d $newpth; } return 1; } =head2 C =over 4 =item * Purpose A stripped-down replacement for C. Given the path to the directory specified by the first argument, the function copies all of the files and directories beneath it to the directory specified by the second argument. =item * Arguments my $count = dircopy($orig, $new); warn "dircopy() returned undefined value" unless defined $count; =item * Return Value Upon completion, returns the count of directories and files created -- which might be C<0>. Should the function not complete (but not C), an undefined value will be returned. That generally indicates problems with argument validation. This approach is taken for consistency with C. In list context the return value is a one-item list holding the same value as returned in scalar context. The three-item list return value of C is not supported. =item * Restrictions None of C's bells and whistles. No guaranteed preservation of file or directory modes. No restriction on maximum depth. No nothing; this is fine-tuned to the needs of Perl toolchain modules and their test suites. =back =cut sub dircopy { # I'm not supporting the buffer limitation, at this point I can insert a # check for the correct number of arguments: 2 # FCR2 dircopy does not support buffer limit as third argument return unless @_ == 2; # Check the definedness and string inequality of the arguments now; # Failure to do it now means that if $_[0] is not defined, you'll get an # uninitalized value warning in the first line that calls 'substr' below. return unless _basic_samecheck(@_); # See local file globstar-investigation.pl # What the block above does is to trim the 'from' argument so that, if user # said 'dircopy(/path/to/directory/*, /path/to/copy)', the first argument # is effectively reduced to '/path/to/directory/' but inside $globstar is # set to true. Have to see what impact of $globstar true is. return _dircopy(@_); } sub _dircopy { 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 ) ); } # Note also that, in the above, $_[0] and $_[1], while assigned to # variables, are not shifted-in. Hence they retain their original values. # TODO: Investigate whether replacing $_[1] from this point forward with a # 'my' variable would be harmful. # Both arguments must now be defined (though not necessarily true -- yet); # they can't be equal; they can't be "dev-ino" equal on non-Win32 systems. # Verify that. return unless _dev_ino_check( $_zero, $_[1] ); if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) { $! = 20; return; } # If the second argument is not an already existing directory, # then, create that directory now (the top-level 'to'). if ( !-d $_[1] ) { pathmk( $_[1] ) or return; } # If the second argument is an existing directory ... # ... $globstar false is the typical case, i.e., no '/*' at end of 2nd argument 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 ) = @_; $filen++ if $end eq $baseend; $dirn++ if $end eq $baseend; # On each pass of the recursive coderef, create the directory in the # 2nd argument or return (undef) if that does not succeed mkdir( $end ) or return if !-d $end; $level++; opendir( my $str_dh, $str ) or return; my @entities = grep( $_ ne '.' && $_ ne '..', readdir($str_dh) ); closedir $str_dh; for my $entity (@entities) { my ($entity_ut) = $entity =~ m{ (.*) }xms; my $from = File::Spec->catfile( $str, $entity_ut ); my $to = File::Spec->catfile( $end, $entity_ut ); if ( -l $from && $CopyLink ) { my $target = readlink($from); # mass-untaint is OK since we have to allow what the file system does ($target) = $target =~ m/(.*)/; warn "Copying a symlink ($from) whose target does not exist" if !-e $target; unlink $to if -l $to; symlink( $target, $to ) or return; } elsif ( -d $from ) { my $rc; $rc = $recurs->( $from, $to ); return unless $rc; $filen++; $dirn++; } else { fcopy( $from, $to ) or return; $filen++; } } # End 'for' loop around @entities $level--; 1; }; # END definition of $recurs $recurs->( $_zero, $_one ) or return; return $filen; } sub _basic_samecheck { my ($from, $to) = @_; return if !defined $from || !defined $to; return if $from eq $to; return 1; } sub _dev_ino_check { my ($from, $to) = @_; return 1 if $^O eq 'MSWin32'; # perldoc perlport: "(Win32) "dev" and "ino" are not meaningful." # Will probably have to add restrictions for VMS and other OSes. my $one = join( '-', ( stat $from )[ 0, 1 ] ) || ''; my $two = join( '-', ( stat $to )[ 0, 1 ] ) || ''; if ( $one and $one eq $two ) { warn "$from and $to are identical"; return; } return 1; } =head2 C =over 4 =item * Purpose A stripped-down replacement for C. As is the case with that FCR function, C is more or less a wrapper around C or C, depending on the nature of the first argument. =item * Arguments rcopy($orig, $new) or die $!; List of two required arguments: =over 4 =item * Absolute path to the entity (file or directory) being copied; and =item * Absolute path to the location to which the entity is being copied. =back =item * Return Value Returns C<1> upon success; C<0> upon failure. Returns an undefined value if, for example, function cannot validate arguments. =item * Comment Please read the documentation for C or C, depending on the nature of the first argument. =back =cut sub rcopy { return unless @_ == 2; my ($from, $to) = @_; return unless _basic_samecheck($from, $to); # TODO: Explore whether we should check (-e $from) here. # If we don't have a starting point, it shouldn't make any sense to go # farther. return unless _dev_ino_check($from, $to); # symlinks not yet supported #return if -l $_[0]; goto &fcopy if -l $_[0] && $CopyLink; goto &_dircopy if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*'; goto &_fcopy; } =head2 File::Copy::Recursive Subroutines Not Supported in File::Copy::Recursive::Reduced As of the current version, FCR2 has no publicly documented, exportable subroutines equivalent to the following FCR exportable subroutines: rcopy_glob fmove rmove rmove_glob dirmove pathempty pathrm pathrmdir Consideration is being given to supporting C. =head1 BUGS AND SUPPORT Please report any bugs by mail to C or through the web interface at L. =head1 ACKNOWLEDGEMENTS Notwithstanding the fact that this distribution is being released to address certain problems in File-Copy-Recursive, credit must be given to FCR author L for ingenious conception and execution. The implementation of the subroutines provided by FCR2 follows that found in FCR to a significant extent. Thanks also to Tom Hukins for supplying the patch which corrects FCR's problems and which has been incorporated into FCR2 as well. Thanks to Håkon Hægland for paying attention to how this library performs on Windows and other platforms to which the author does not have access. =head1 AUTHOR James E Keenan CPAN ID: JKEENAN jkeenan@cpan.org http://thenceforward.net/perl =head1 COPYRIGHT This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. Copyright James E Keenan 2018-2023. All rights reserved. =head1 SEE ALSO perl(1). File::Copy::Recursive(3). =cut 1; __END__ File-Copy-Recursive-Reduced-0.008/LICENSE0000644000175000017500000005010113263266562017453 0ustar jkeenanjkeenanTerms of Perl itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --------------------------------------------------------------------------- The General Public License (GPL) Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS --------------------------------------------------------------------------- The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End File-Copy-Recursive-Reduced-0.008/Makefile.PL0000644000175000017500000000435714600301077020417 0ustar jkeenanjkeenanuse ExtUtils::MakeMaker; require 5.008; my $mm_ver = ExtUtils::MakeMaker->VERSION; WriteMakefile( NAME => 'File::Copy::Recursive::Reduced', VERSION_FROM => 'lib/File/Copy/Recursive/Reduced.pm', # finds \$VERSION AUTHOR => 'James E Keenan (jkeenan@cpan.org)', ABSTRACT => 'Recursive copying of files and directories within Perl 5 toolchain', MIN_PERL_VERSION => '5.8.0', # Modules needed to compile, build or actually run this distribution: PREREQ_PM => { 'File::Copy' => 0, 'File::Find' => 0, 'File::Path' => 0, 'File::Spec' => 0, }, # Modern EU::MM enables us to identify modules required only for the test # suite. ( $mm_ver < 6.63_03 ? 'BUILD_REQUIRES' : 'TEST_REQUIRES' ) => { 'Test::Simple' => 0.44, 'Capture::Tiny' => 0, 'File::Path' => 0, 'File::Spec' => 0, 'File::Temp' => 0, 'Path::Tiny' => 0, }, # Modern EU::MM enables 'make dist' to write good META.json (and META.yml) ($mm_ver < 6.46 ? () : (META_MERGE => { 'meta-spec' => { version => 2 }, dynamic_config => 1, resources => { homepage => 'http://thenceforward.net/perl/modules/File-Copy-Recursive-Reduced/', repository => { url => 'https://github.com/jkeenan/file-copy-recursive-reduced.git', web => 'https://github.com/jkeenan/file-copy-recursive-reduced', type => 'git', }, bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=File-Copy-Recursive-Reduced', }, }, })), ($mm_ver < 6.31 ? () : (LICENSE => 'perl_5')), ); __END__ File::Copy => 0, File::Spec => 0, Test::Deep => 0, Test::File => 0, File::Temp => 0, Test::Warn => 0, File::Glob => 0, Test::Exception => 0, Cwd => 0, File::Spec => 0, Path::Tiny => 0, File-Copy-Recursive-Reduced-0.008/Todo0000644000175000017500000000036314501044110017256 0ustar jkeenanjkeenanTODO list for Perl module File::Copy::Recursive::Reduced - Determine whether we can support KeepMode in dircopy(). - Determine whether we can copy symlinks in both fcopy() and dircopy(). If so, then we can support FCR rcopy() as well. File-Copy-Recursive-Reduced-0.008/META.yml0000664000175000017500000000203714600302103017700 0ustar jkeenanjkeenan--- abstract: 'Recursive copying of files and directories within Perl 5 toolchain' author: - 'James E Keenan (jkeenan@cpan.org)' build_requires: Capture::Tiny: '0' ExtUtils::MakeMaker: '0' File::Path: '0' File::Spec: '0' File::Temp: '0' Path::Tiny: '0' Test::Simple: '0.44' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: File-Copy-Recursive-Reduced no_index: directory: - t - inc requires: File::Copy: '0' File::Find: '0' File::Path: '0' File::Spec: '0' perl: '5.008000' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=File-Copy-Recursive-Reduced homepage: http://thenceforward.net/perl/modules/File-Copy-Recursive-Reduced/ repository: https://github.com/jkeenan/file-copy-recursive-reduced.git version: '0.008' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' File-Copy-Recursive-Reduced-0.008/MANIFEST0000644000175000017500000000056014600302103017555 0ustar jkeenanjkeenanChanges lib/File/Copy/Recursive/Reduced.pm LICENSE Makefile.PL MANIFEST This list of files MANIFEST.SKIP README t/001-fcopy.t t/002-dircopy.t t/003-rcopy.t t/lib/Helper.pm t/lib/MockHomeDir.pm Todo META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) File-Copy-Recursive-Reduced-0.008/MANIFEST.SKIP0000644000175000017500000000057314501313353020337 0ustar jkeenanjkeenan^blib/ ^Makefile$ ^Makefile\.[a-z]+$ ^pm_to_blib$ CVS/.* ,v$ ^tmp/ \.old$ \.bak$ \.tmp$ \.swp$ ~$ ^# \.shar$ \.tar$ \.tgz$ \.tar\.gz$ \.zip$ \.DS_Store$ _uu$ \.svn cover_db/ coverage/ html/ learn/ research/ superseded/ svndiff/ ^.cvsignore ^init ^results ^htmlify .git/ ^MYMETA.* nytprof/ nytprof.out .version_info.pl dump \.gitignore \.appveyor.yml ^README.md ^.README.pod tmp/ File-Copy-Recursive-Reduced-0.008/README0000644000175000017500000000443614501044110017313 0ustar jkeenanjkeenanREADME for Perl extension File-Copy-Recursive-Reduced File-Copy-Recursive-Reduced is a Perl library which provides subroutines exported on request which are intended to serve as drop-in replacements for certain subroutines found in CPAN distribution File-Copy-Recursive (FCR). What Problem Does This Library Address? As of early April 2018, FCR was failing to install on several important operating systems including FreeBSD and Windows. As a consequence, other CPAN distributions which had a direct or indirect dependency on FCR (*e.g.*, CPAN-Reporter, DateTime, Dist-Zilla) were failing to install on those platforms as well. Such failures were "silent" in the sense that CPANtesters installations generate no report authors when a distribution's upstream dependencies fail to install. No report to the CPANtesters database means no email notification to CPAN authors. So many authors were unaware that their distributions were failing to install on important platforms. Uncertainty as to when FCR would be fixed led to the creation of File-Copy-Recursive-Reduced (FCR2). Certain CPAN distributions adopted it in place of FCR. With the April 19 2018 release of FCR version 0.41, the problems that motivated the creation of FCR2 have been addressed. FCR2 is now feature-complete. It exports three functions on demand which are substantially equivalent to their FCR equivalents: * "fcopy()" * "dircopy()" * "rcopy()" After installation, call perldoc File::Copy::Recursive::Reduced for more usage details. These functions are quite appropriate in situations such as test suites where the user has full knowledge of the files, directories and symlinks to be recursively copied and does not need to manipulate the environment by setting localized versions of FCR's package global variables. Install This library can be installed in the customary way, *i.e.,* by a CPAN installer program such as cpan or cpanm or by satisfying its prerequisites (Capture::Tiny and Path::Tiny, for the test suite only) and then calling: perl Makefile.PL make make test make install For further information, after installation call "perldoc File::Copy::Recursive::Reduced". File-Copy-Recursive-Reduced-0.008/t/0000755000175000017500000000000014600302103016666 5ustar jkeenanjkeenanFile-Copy-Recursive-Reduced-0.008/t/lib/0000755000175000017500000000000014600302103017434 5ustar jkeenanjkeenanFile-Copy-Recursive-Reduced-0.008/t/lib/MockHomeDir.pm0000644000175000017500000000143013263505074022151 0ustar jkeenanjkeenanpackage MockHomeDir; use strict; BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use File::Spec; use File::Temp qw/tempdir/; $INC{"File/HomeDir.pm"} = 1; # fake load # tester might have these set -- we need them unset so we use our # own temporary dir & config during our tests delete $ENV{PERL_CPAN_REPORTER_DIR}; delete $ENV{PERL_CPAN_REPORTER_CONFIG}; my $temp_home = tempdir( "CPAN-Reporter-testhome-XXXXXXXX", TMPDIR => 1, CLEANUP => 1 ) or die "Couldn't create a temporary config directory: $!\nIs your temp drive full?"; my $home_dir = File::Spec->rel2abs( $temp_home ); sub home_dir { $home_dir } package File::HomeDir; our $VERSION = 999; sub my_documents { return $home_dir }; sub my_home { return $home_dir }; sub my_data { return $home_dir }; 1; File-Copy-Recursive-Reduced-0.008/t/lib/Helper.pm0000644000175000017500000001766514501044110021231 0ustar jkeenanjkeenanpackage Helper; use strict; use warnings; our (@EXPORT_OK, @ISA); use Exporter (); @ISA = 'Exporter'; @EXPORT_OK = ( qw| create_tfile create_tfile_and_name_for_new_file_in_same_dir get_mode create_tsubdir get_fresh_tmp_dir touch_a_file_and_test touch_directories_and_test touch_left_path_and_test prepare_left_side_directories make_mixed_directory make_imperfect_mixed_directory | ); use File::Basename ( qw| basename dirname | ); use File::Path ( qw| mkpath | ); use File::Spec; use File::Temp ( qw| tempdir | ); use Path::Tiny; sub create_tfile { my $tdir = shift; my $filename = shift || 'old'; my $f = File::Spec->catfile($tdir, $filename); open my $OUT, '>', $f or die "Unable to open for writing: $!"; binmode $OUT; print $OUT "\n"; close $OUT or die "Unable to close after writing: $!"; return $f; } sub create_tfile_and_name_for_new_file_in_same_dir { my $tdir = shift; my $new_filename = shift || 'new_file'; my $old = create_tfile($tdir); my $new = File::Spec->catfile($tdir, $new_filename); return ($old, $new); } sub get_mode { my $file = shift; return sprintf("%04o" => ((stat($file))[2] & 07777)); } sub create_tsubdir { my $tdir = shift; my $old = File::Spec->catdir($tdir, 'old_dir'); my $rv = mkdir($old); die "Unable to create temporary subdirectory for testing: $!" unless $rv; return $old; } sub get_fresh_tmp_dir { # Adapted from FCR t/01.legacy.t my $tmpd = shift || tempdir( CLEANUP => 1 ); for my $dir ( _get_dirs($tmpd) ) { my @created = mkpath($dir, { mode => 0711 }); die "Unable to create directory $dir for testing: $!" unless @created; path("$dir/empty")->spew(""); path("$dir/data")->spew("oh hai\n$dir"); path("$dir/data_tnl")->spew("oh hai\n$dir\n"); no warnings 'once'; if ($File::Copy::Recursive::Reduced::CopyLink) { symlink( "data", "$dir/symlink" ); symlink( "noexist", "$dir/symlink-broken" ); symlink( "..", "$dir/symlink-loopy" ); } use warnings; } return $tmpd; } sub _get_dirs { # Adapted from FCR t/01.legacy.t my $tempd = shift; my @dirs = ( [ qw| orig | ], [ qw| orig foo | ], [ qw| orig foo bar | ], [ qw| orig foo baz | ], [ qw| orig foo bar bletch | ], ); my @catdirs = (); for my $set (@dirs) { push @catdirs, File::Spec->catdir($tempd, @{$set}); } return @catdirs; } sub touch_a_file_and_test { my $f = shift; open my $OUT, '>', $f or die "Unable to open $f for writing"; print $OUT "\n"; close $OUT or die "Unable to close $f after writing"; Test::More::ok(-f $f, "Created $f for testing"); return 1; } sub touch_directories_and_test { my ($topdir, $tdir_names) = @_; my @tdirs = (); for my $d (@{$tdir_names}) { my $s = File::Spec->catdir($topdir, $d); mkpath($s) or die "Unable to mkpath $s: $!"; Test::More::ok(-d $s, "Directory $s created"); push @tdirs, $s; } return @tdirs; } sub touch_left_path_and_test { my @dirs = @_; my $ldir = File::Spec->catdir(@dirs); mkpath($ldir) or die "Unable to mkpath $ldir: $!"; Test::More::ok(-d $ldir, "Directory $ldir created"); return $ldir; } sub prepare_left_side_directories { my ($topdir, $dirname, $subdirs) = @_; my $tdir = File::Spec->catdir($topdir, $dirname); mkpath($tdir) or die "Unable to mkpath $tdir"; Test::More::ok(-d $tdir, "Directory $tdir created"); my $old = File::Spec->catdir($tdir); my $oldtree = File::Spec->catdir($tdir, @{$subdirs}); my @created = mkpath($oldtree, { mode => 0711 }); die "Unable to create directory $oldtree for testing: $!" unless -d $oldtree; Test::More::ok(-d $oldtree, "Directory $oldtree created for testing"); return ($old, $oldtree); } sub make_mixed_directory { my $topdir = shift; my @dirnames = qw( alpha beta gamma ); my @subdirs = (); for my $d (@dirnames) { my $p = File::Spec->catdir($topdir, $d); mkpath $p or die "Unable to mkpath $p"; push @subdirs, $p; } my @next_dirnames = qw( albemarle beverly ); my @nextdirs = (); my @files_created = (); for my $d (@subdirs) { for my $e (@next_dirnames) { my $p = File::Spec->catdir($d, $e); mkpath $p or die "Unable to mkpath $p"; push @nextdirs, $p; my @fnames = qw( f1 f2 ); if ($e eq $next_dirnames[0]) { my $f1 = File::Spec->catfile($p, $fnames[0]); my $f2 = File::Spec->catfile($p, $fnames[1]); for my $f ($f1, $f2) { open my $OUT, '>', $f or die "Unable to open for writing"; print $OUT "\n"; close $OUT or die "Unable to close after writing"; push @files_created, $f; } } } } my @symlinks_created = (); for my $f (@files_created) { my $base = basename($f); my $dirs = dirname($f); if ($base eq 'f1') { my @dirs = File::Spec->splitdir($dirs); my $orig = File::Spec->catfile($f); my $newdir = File::Spec->catdir(@dirs[0 .. ($#dirs -1)], 'beverly'); my $symlink = File::Spec->catfile($newdir, 'l1'); symlink $orig, $symlink or die "Unable to symlink"; push @symlinks_created, $symlink; } } my @dirs_created = (@subdirs, @nextdirs); my $rv = { dirs => \@dirs_created, files => \@files_created, symlinks => \@symlinks_created, }; #require Data::Dump; #Data::Dump::dd($rv); return $rv; } sub make_imperfect_mixed_directory { my $topdir = shift; my @dirnames = qw( alpha beta gamma ); my @subdirs = (); for my $d (@dirnames) { my $p = File::Spec->catdir($topdir, $d); mkpath $p or die "Unable to mkpath $p"; push @subdirs, $p; } my @next_dirnames = qw( albemarle beverly ); my @nextdirs = (); my %files_created = (); for my $d (@subdirs) { for my $e (@next_dirnames) { my $p = File::Spec->catdir($d, $e); mkpath $p or die "Unable to mkpath $p"; push @nextdirs, $p; my @fnames = qw( f1 f2 ); if ($e eq $next_dirnames[0]) { my $f1 = File::Spec->catfile($p, $fnames[0]); my $f2 = File::Spec->catfile($p, $fnames[1]); for my $f ($f1, $f2) { open my $OUT, '>', $f or die "Unable to open for writing"; print $OUT "\n"; close $OUT or die "Unable to close after writing"; #push @files_created, $f; $files_created{$f}++; } } } } my @symlinks_created = (); for my $f (keys %files_created) { my $base = basename($f); my $dirs = dirname($f); if ($base eq 'f1') { my @dirs = File::Spec->splitdir($dirs); my $orig = File::Spec->catfile($f); my $newdir = File::Spec->catdir(@dirs[0 .. ($#dirs -1)], 'beverly'); my $symlink = File::Spec->catfile($newdir, 'l1'); symlink $orig, $symlink or die "Unable to symlink"; push @symlinks_created, $symlink; } } # delete 1 file which is the target of a symlink # "/tmp/Gi_iWAqYXz/old/alpha/albemarle/f1" for my $f (keys %files_created) { my $g = File::Spec->catfile($topdir, $dirnames[0], $next_dirnames[0], 'f1'); if ($f =~ m{\Q$g\E$}) { unlink $g or die "Unable to unlink $g"; delete $files_created{$f}; last; } } my @dirs_created = (@subdirs, @nextdirs); my $rv = { dirs => \@dirs_created, files => [ keys %files_created ], symlinks => \@symlinks_created, }; return $rv; } 1; File-Copy-Recursive-Reduced-0.008/t/001-fcopy.t0000644000175000017500000002573314600276543020525 0ustar jkeenanjkeenan# -*- perl -*- # t/001-fcopy.t - tests of fcopy() method use strict; use warnings; use Test::More tests => 85; use File::Copy::Recursive::Reduced qw( fcopy ); use Capture::Tiny qw(capture_stderr); use File::Path qw(mkpath); use File::Spec; use File::Temp qw(tempdir); use Path::Tiny; use lib qw( t/lib ); use MockHomeDir; use Helper ( qw| create_tfile_and_name_for_new_file_in_same_dir create_tfile get_fresh_tmp_dir |); my ($from, $to, $rv); note("fcopy(): Test faulty or inappropriate arguments"); $rv = fcopy(); ok(! defined $rv, "fcopy() returned undef when not provided correct number of arguments"); $rv = fcopy('foo'); ok(! defined $rv, "fcopy() returned undef when not provided correct number of arguments"); $rv = fcopy('foo', 'bar', 'baz', 'bletch'); ok(! defined $rv, "fcopy() returned undef when not provided correct number of arguments"); $rv = fcopy(undef, 'foo'); ok(! defined $rv, "fcopy() returned undef when first argument was undefined"); $rv = fcopy('foo', undef); ok(! defined $rv, "fcopy() returned undef when second argument was undefined"); $rv = fcopy('foo', 'foo'); ok(! defined $rv, "fcopy() returned undef when provided 2 identical arguments"); SKIP: { skip "System does not support hard links", 3 unless $File::Copy::Recursive::Reduced::Link; my $tdir = tempdir( CLEANUP => 1 ); my ($old, $new) = create_tfile_and_name_for_new_file_in_same_dir($tdir); my $rv = link($old, $new) or die "Unable to link: $!"; ok($rv, "Able to hard link $old and $new"); my $stderr = capture_stderr { $rv = fcopy($old, $new); }; ok(! defined $rv, "fcopy() returned undef when provided arguments with identical dev and ino"); SKIP: { skip 'identical-dev-ino check not applicable on Windows', 1 if ($^O eq 'MSWin32') ; like($stderr, qr/\Q$old and $new are identical\E/, "fcopy(): got expected warning when provided arguments with identical dev and ino"); } } SKIP: { skip "System does not support symlinks", 11 unless $File::Copy::Recursive::Reduced::CopyLink; # System supports symlinks my ($tdir, $old, $new, $symlink, $rv); $tdir = tempdir( CLEANUP => 1 ); $old = create_tfile($tdir); $symlink = File::Spec->catfile($tdir, 'sym'); $rv = symlink($old, $symlink) or die "Unable to symlink $symlink to target $old for testing: $!"; ok(-l $symlink, "fcopy(): $symlink is indeed a symlink"); is(readlink($symlink), $old, "Symlink $symlink points to $old"); $new = File::Spec->catfile($tdir, 'new'); $rv = fcopy($symlink, $new); ok(defined $rv, "fcopy() returned defined value when copying from symlink"); ok($rv, "fcopy() returned true value when copying from symlink"); ok(-f $new, "fcopy(): $new is a file"); ok(-l $new, "fcopy(): but $new is also another symlink"); my ($xold, $xnew, $xsymlink, $stderr); $xold = create_tfile($tdir); $xsymlink = File::Spec->catfile($tdir, 'xsym'); $rv = symlink($xold, $xsymlink) or die "Unable to symlink $xsymlink to target $xold for testing: $!"; ok(-l $xsymlink, "fcopy(): $xsymlink is indeed a symlink"); is(readlink($xsymlink), $xold, "Symlink $xsymlink points to $xold"); $xnew = File::Spec->catfile($tdir, 'xnew'); unlink $xold or die "Unable to unlink $xold during testing: $!"; $stderr = capture_stderr { $rv = fcopy($xsymlink, $xnew); }; ok(defined $rv, "fcopy() returned defined value when copying from symlink"); ok($rv, "fcopy() returned true value when copying from symlink"); like($stderr, qr/Copying a symlink \(\Q$xsymlink\E\) whose target does not exist/, "fcopy(): Got expected warning when copying from symlink whose target does not exist"); } { my ($tdir, $tdir2, $old, $new, $rv); $tdir = tempdir( CLEANUP => 1 ); $tdir2 = tempdir( CLEANUP => 1 ); $new = create_tfile($tdir2, 'new_file'); $rv = fcopy($tdir, $new); ok(! defined $rv, "RTC 123964: fcopy() returned undefined value when first argument was a directory"); } note("fcopy(): Test good arguments"); sub basic_tests { note("Copy file within existing same directory, new basename"); my ($tdir, $old, $new, $rv, $stderr); $tdir = tempdir( CLEANUP => 1 ); ($old, $new) = create_tfile_and_name_for_new_file_in_same_dir($tdir); note("AAA: 1st: $old"); note(" 2nd: $new"); $rv = fcopy($old, $new); ok($rv, "fcopy() returned true value: $rv"); ok(-f $new, "$old copied to $new, which is file"); note("Copy file to existing different directory, same basename"); my ($tdir2, $basename, $expected_new_file); $tdir2 = tempdir( CLEANUP => 1 ); $basename = 'thirdfile'; $old = create_tfile($tdir, $basename); $expected_new_file = File::Spec->catfile($tdir2, $basename); note("BBB: 1st: $old"); note(" 2nd: $tdir2"); $rv = fcopy($old, $tdir2); ok($rv, "fcopy() returned true value: $rv"); ok(-f $expected_new_file, "$old copied to $expected_new_file, which is file"); note("Copy file to different directory not yet existing;"); note(" basename must be explicitly provided at end of 2nd argument"); my (@subdirs, $newdir); $basename = 'fourth_file'; $old = create_tfile($tdir, $basename); @subdirs = ('alpha', 'beta', 'gamma'); $newdir = File::Spec->catdir($tdir2, @subdirs); $expected_new_file = File::Spec->catfile($newdir, $basename); note("CCC: 1st: $old"); note(" 2nd: $expected_new_file"); $rv = fcopy($old, $expected_new_file); ok($rv, "fcopy() returned true value: $rv"); ok(-f $expected_new_file, "$old copied to $expected_new_file, which is file"); return 1; } sub more_basic_tests { my ($tdir, $adir, $bdir) = @_; mkdir($adir); mkdir($bdir); for my $d ($tdir, $adir, $bdir) { ok(-d $d, "$d located") or die "Can't find $d"; } for (1..4) { my $f = 'file'. $_; my $af = "$adir/$f";; open my $OUT, '>', $af or die "Unable to open to write"; print $OUT "\n"; close $OUT or die "Unable to close after write"; ok(-f $af, "Created dummy file $af"); } my ($base, $orig, $newbase, $new, $expect, $rv, $newdir, @subdirs); note("Case 1: " . q|fcopy('/path/to/filename', '/path/to/newfile');|); $base = 'file1'; $orig = File::Spec->catfile($adir, $base); $newbase = 'newfile'; $new = $expect = File::Spec->catfile($adir, $newbase); ok(! -e $expect, "$expect does not yet exist"); $rv = fcopy($orig, $new); ok(defined $rv, "fcopy() returned defined value"); ok(-f $expect, "$expect has been created"); note("Case 2: " . q|fcopy('/path/to/filename', '/path/to/existing/directory');|); $base = 'file2'; $orig = File::Spec->catfile($adir, $base); $new = $bdir; $expect = File::Spec->catfile($bdir, $base); ok(! -e $expect, "$expect does not yet exist"); $rv = fcopy($orig, $new); ok(defined $rv, "fcopy() returned defined value"); ok(-f $expect, "$expect has been created"); note("Case 3: " . q|fcopy('/path/to/filename', '/path/not/yet/existing/directory/filename')|); $base = 'file3'; $orig = File::Spec->catfile($adir, $base); @subdirs = qw( alpha beta ); $newdir = File::Spec->catdir($bdir, @subdirs); $new = $expect = File::Spec->catfile($newdir, $base); ok(! -e $expect, "$expect does not yet exist"); $rv = fcopy($orig, $new); ok(defined $rv, "fcopy() returned defined value"); ok(-f $expect, "$expect has been created"); { my $interdir = $bdir; for my $d (@subdirs) { $interdir = File::Spec->catdir($interdir, $d); ok(-d $interdir, "Intermediate directory $interdir created"); } } note("Case 4: " . q|fcopy('/path/to/filename', #'/path/not/yet/existing/directory/newfile');|); $base = 'file4'; $orig = File::Spec->catfile($adir, $base); @subdirs = qw( gamma delta ); $newdir = File::Spec->catdir($bdir, @subdirs); $newbase = 'newfile'; $new = $expect = File::Spec->catfile($newdir, $newbase); ok(! -e $expect, "$expect does not yet exist"); $rv = fcopy($orig, $new); ok(defined $rv, "fcopy() returned defined value"); ok(-f $expect, "$expect has been created"); { my $interdir = $bdir; for my $d (@subdirs) { $interdir = File::Spec->catdir($interdir, $d); ok(-d $interdir, "Intermediate directory $interdir created"); } } return 1; } { note("Basic tests of fcopy()"); basic_tests(); my $tdir = tempdir(CLEANUP => 1); my $adir = "$tdir/albemarle"; my $bdir = "$tdir/beverly"; more_basic_tests($tdir, $adir, $bdir); } SKIP: { skip "Set PERL_AUTHOR_TESTING to true to compare with FCR::fcopy()", 29 unless $ENV{PERL_AUTHOR_TESTING}; my $rv = eval { require File::Copy::Recursive; }; SKIP: { skip "Must install File::Copy::Recursive for certain tests", 29 unless $rv; no warnings ('redefine'); local *fcopy = \&File::Copy::Recursive::fcopy; use warnings; note("COMPARISON: Basic tests of File::Copy::Recursive::fcopy()"); basic_tests(); my $tdir = tempdir(CLEANUP => 1); my $adir = "$tdir/albemarle"; my $bdir = "$tdir/beverly"; more_basic_tests($tdir, $adir, $bdir); } } { note("Tests from FCR t/01.legacy.t"); my ($tdir, $old, $new, $symlink, $rv); my $tmpd = get_fresh_tmp_dir(); ok(-d $tmpd, "$tmpd exists"); $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" ); # This is the test that fails on FreeBSD # https://rt.cpan.org/Ticket/Display.html?id=123964 $rv = fcopy( "$tmpd/orig", "$tmpd/fcopy" ); ok(!$rv, "RTC 123964: fcopy() returns false if source is a directory"); } { note("Tests using FCR's fcopy() from CPAN::Reporter's test suite"); # t/66_have_tested.t # t/72_rename_history.t my $config_dir = File::Spec->catdir( MockHomeDir::home_dir, ".cpanreporter" ); my $config_file = File::Spec->catfile( $config_dir, "config.ini" ); my $history_file = File::Spec->catfile( $config_dir, "reports-sent.db" ); my $sample_history_file = File::Spec->catfile(qw/t history reports-sent-longer.db/); mkpath( $config_dir ); ok( -d $config_dir, "temporary config dir created" ); # CPAN::Reporter:If old history exists, convert it # I'm not really sure what the point of this test is. SKIP: { skip "$sample_history_file does not exist", 1 unless -e $sample_history_file; fcopy($sample_history_file, $history_file); ok( -f $history_file, "copied sample old history file to config directory"); } } __END__ File-Copy-Recursive-Reduced-0.008/t/002-dircopy.t0000644000175000017500000003717414600276641021060 0ustar jkeenanjkeenan# -*- perl -*- # t/002-dircopy.t - tests of dircopy() method use strict; use warnings; use Test::More tests => 115; use File::Copy::Recursive::Reduced qw(dircopy); use Capture::Tiny qw(capture_stderr); use File::Find; use File::Path qw(mkpath); use File::Spec; use File::Temp qw(tempdir); use lib qw( t/lib ); use MockHomeDir; use Helper ( qw| create_tfile create_tfile_and_name_for_new_file_in_same_dir create_tsubdir touch_a_file_and_test touch_directories_and_test touch_left_path_and_test prepare_left_side_directories make_mixed_directory make_imperfect_mixed_directory | ); my ($from, $to, $rv); { note("dircopy(): Argument validation"); $rv = dircopy(); ok(! defined $rv, "dircopy() returned undef when not provided correct number of arguments"); $rv = dircopy('foo'); ok(! defined $rv, "dircopy() returned undef when not provided correct number of arguments"); $rv = dircopy('foo', 'bar', 'baz', 'bletch'); ok(! defined $rv, "dircopy() returned undef when not provided correct number of arguments"); $rv = dircopy(undef, 'foo'); ok(! defined $rv, "dircopy() returned undef when first argument was undefined"); $rv = dircopy('foo', undef); ok(! defined $rv, "dircopy() returned undef when second argument was undefined"); $rv = dircopy('foo', 'foo'); ok(! defined $rv, "dircopy() returned undef when provided 2 identical arguments"); SKIP: { skip "System does not support hard links", 3 unless $File::Copy::Recursive::Reduced::Link; my $tdir = tempdir( CLEANUP => 1 ); my ($old, $new) = create_tfile_and_name_for_new_file_in_same_dir($tdir); my $rv = link($old, $new) or die "Unable to link: $!"; ok($rv, "Able to hard link $old and $new"); my $stderr = capture_stderr { $rv = dircopy($old, $new); }; ok(! defined $rv, "dircopy() returned undef when provided arguments with identical dev and ino"); SKIP: { skip 'identical-dev-ino check not applicable on Windows', 1 if ($^O eq 'MSWin32') ; like($stderr, qr/\Q$old and $new are identical\E/, "dircopy(): got expected warning when provided arguments with identical dev and ino"); } } { note("Either first argument is not a directory or\nsecond argument exists already and is not a directory"); my ($tdir, $old, $new, $rv); $tdir = tempdir( CLEANUP => 1 ); $old = create_tfile($tdir); $new = 'foo'; $rv = dircopy($old, $new); ok(! defined $rv, "dircopy() returned undef when first argument was not a directory"); cmp_ok($!, '>=', 0, "\$ERRNO set: " . $!); undef $!; ok(! $!, "\$ERRORNO has been cleared"); $old = create_tsubdir($tdir); $new = create_tfile($tdir, 'new'); $rv = dircopy($old, $new); ok(! defined $rv, "dircopy() returned undef when second argument -- not a directory -- already existed"); cmp_ok($!, '>=', 0, "\$ERRNO set: " . $!); undef $!; } } note("Begin tests with valid arguments"); { note("Second argument (directory) does not yet exist"); my $topdir = tempdir(CLEANUP => 1); my ($tdir, $tdir2); $tdir = File::Spec->catdir($topdir, 'alpha'); mkpath($tdir) or die "Unable to mkpath $tdir"; ok(-d $tdir, "Directory $tdir created"); my $f1 = create_tfile($tdir, 'foo'); my $f2 = create_tfile($tdir, 'bar'); $tdir2 = File::Spec->catdir($topdir, 'beta'); ok(! -d $tdir2, "Directory $tdir2 does not yet exist"); my ($from, $to); $from = $tdir; $to = $tdir2; $rv = dircopy($from, $to); ok(defined $rv, "dircopy() returned defined value"); ok(-d $tdir2, "Directory $tdir2 has been created"); } { note("Copying of subdirs containing no files"); my $topdir = tempdir(CLEANUP => 1); my @tdir_names = ('xray', 'yeller'); my @tdirs = touch_directories_and_test($topdir, \@tdir_names); my @subdir_names = ('alpha', 'beta', 'gamma'); my $ldir = touch_left_path_and_test($tdirs[0], @subdir_names); my @expected_subdirs = (); my $intermed = $tdirs[1]; for my $d (@subdir_names) { $intermed = File::Spec->catdir($intermed, $d); push @expected_subdirs, $intermed; } for my $d (@expected_subdirs) { ok(! -d $d, "Directory $d does not yet exist"); } my ($from, $to); $from = $tdirs[0]; $to = $tdirs[1]; $rv = dircopy($from, $to); ok(defined $rv, "dircopy() returned defined value"); for my $d (@expected_subdirs) { ok(-d $d, "Directory $d has been created"); } } { note("Copying of subdirs containing 1 file at bottom level"); my $topdir = tempdir(CLEANUP => 1); my @tdir_names = ('xray', 'yeller'); my @tdirs = touch_directories_and_test($topdir, \@tdir_names); my @subdir_names = ('alpha', 'beta', 'gamma'); my $ldir = touch_left_path_and_test($tdirs[0], @subdir_names); my $fname = 'foo'; my $f1 = create_tfile($ldir, $fname); ok(-f $f1, "File $f1 created at bottom level"); my @expected_subdirs = (); my $intermed = $tdirs[1]; for my $d (@subdir_names) { $intermed = File::Spec->catdir($intermed, $d); push @expected_subdirs, $intermed; } for my $d (@expected_subdirs) { ok(! -d $d, "Directory $d does not yet exist"); } my $expected_file = File::Spec->catfile($expected_subdirs[-1], $fname); ok(! -f $expected_file, "File $expected_file does not yet exist"); my ($from, $to); $from = $tdirs[0]; $to = $tdirs[1]; $rv = dircopy($from, $to); ok(defined $rv, "dircopy() returned defined value"); for my $d (@expected_subdirs) { ok(-d $d, "Directory $d has been created"); } ok(-f $expected_file, "File $expected_file has been created"); } { note("Copying of subdirs containing 1 file at non-bottom level"); my $topdir = tempdir(CLEANUP => 1); my @tdir_names = ('xray', 'yeller'); my @tdirs = touch_directories_and_test($topdir, \@tdir_names); my @subdir_names = ('alpha', 'beta', 'gamma'); my $ldir = touch_left_path_and_test($tdirs[0], @subdir_names); my $fname = 'foo'; my $f1 = create_tfile(File::Spec->catdir($tdirs[0], @subdir_names[0..1]), $fname); ok(-f $f1, "File $f1 created at non-bottom level"); my @expected_subdirs = (); my $intermed = $tdirs[1]; for my $d (@subdir_names) { $intermed = File::Spec->catdir($intermed, $d); push @expected_subdirs, $intermed; } for my $d (@expected_subdirs) { ok(! -d $d, "Directory $d does not yet exist"); } my $expected_file = File::Spec->catfile($expected_subdirs[-2], $fname); ok(! -f $expected_file, "File $expected_file does not yet exist"); my ($from, $to); $from = $tdirs[0]; $to = $tdirs[1]; $rv = dircopy($from, $to); ok(defined $rv, "dircopy() returned defined value"); for my $d (@expected_subdirs) { ok(-d $d, "Directory $d has been created"); } ok(-f $expected_file, "File $expected_file has been created"); } { my $tdir = tempdir(CLEANUP => 1); my $tdir2 = tempdir(CLEANUP => 1); my $f1 = create_tfile($tdir, 'foo'); my $f2 = create_tfile($tdir, 'bar'); $from = $tdir; $to = $tdir2; $rv = dircopy($from, $to); ok(defined $rv, "dircopy() returned defined value"); $from = "$tdir/*"; $to = $tdir2; $rv = dircopy($from, $to); ok(defined $rv, "dircopy() returned defined value when first argument ends with '/*'"); } my @dirnames = ( qw| able baker camera dogtag elmore fargo golfer hatrack impish jolt karma lily mandate namesake oleo partner quorum robot sterling tamarack ultra victor windy xray yellow zebra | ); { note("Basic tests of File::Copy::Recursive::Reduced::dircopy()"); basic_dircopy_tests(@dirnames); SKIP: { skip "System does not support symlinks", 13 unless $File::Copy::Recursive::Reduced::CopyLink; note("Copy directory which holds symlinks"); mixed_block(); mixed_imperfect_block(); } } SKIP: { skip "Set PERL_AUTHOR_TESTING to true to compare with FCR::dircopy()", 26 unless $ENV{PERL_AUTHOR_TESTING}; my $rv = eval { require File::Copy::Recursive; }; SKIP: { skip "Must install File::Copy::Recursive for certain tests", 26 unless $rv; no warnings ('redefine'); local *dircopy = \&File::Copy::Recursive::dircopy; use warnings; note("COMPARISON: Basic tests of File::Copy::Recursive::dircopy()"); basic_dircopy_tests(@dirnames); SKIP: { skip "System does not support symlinks", 6 unless $File::Copy::Recursive::Reduced::CopyLink; note("Copy directory which holds symlinks"); mixed_block(); } } } #################### SUBROUTINES #################### sub basic_dircopy_tests { my @dirnames = @_; { note("Multiple directories; no files"); my $topdir = tempdir(CLEANUP => 1); my ($tdir, $tdir2, $old, $oldtree, $new, $rv, $expected); my @subdirs = @dirnames[0..4]; # Prepare left side ($old, $oldtree) = prepare_left_side_directories($topdir, 'alpha', \@subdirs); # Prepare right side $tdir2 = File::Spec->catdir($topdir, 'beta'); $expected = File::Spec->catdir($tdir2, @subdirs); # Test my ($from, $to) = ($old, $tdir2); $rv = dircopy($from, $to); ok($rv, "dircopy() returned true value"); ok(-d $tdir2, "dircopy(): directory $tdir2 created"); ok(-d $expected, "dircopy(): directory $expected created"); } { note("Multiple directories; files at bottom level"); my $topdir = tempdir(CLEANUP => 1); my ($tdir, $tdir2, $old, $oldtree, $new, $rv, $expected); my (@basenames); my @subdirs = @dirnames[5..7]; # Prepare left side ($old, $oldtree) = prepare_left_side_directories($topdir, 'alpha', \@subdirs); @basenames = qw| foo bar |; for my $b (@basenames) { my $f = touch_a_file_and_test(File::Spec->catfile($oldtree, $b)); } # Prepare right side $tdir2 = File::Spec->catdir($topdir, 'beta'); $expected = File::Spec->catdir($tdir2, @subdirs); # Test my ($from, $to) = ($old, $tdir2); $rv = dircopy($from, $to); ok(-d $expected, "dircopy(): directory $expected created"); # test for creation of files for my $b (@basenames) { my $f = File::Spec->catfile($expected, $b); ok(-f $f, "dircopy(): file $f created"); } } { note("Multiple directories; files at intermediate levels"); my $topdir = tempdir(CLEANUP => 1); my ($tdir, $tdir2, $old, $oldtree, $new, $rv, $expected); my @subdirs = @dirnames[8..11]; # Prepare left side ($old, $oldtree) = prepare_left_side_directories($topdir, 'alpha', \@subdirs); my $f = File::Spec->catfile(@subdirs[0..1], 'foo'); my $g = File::Spec->catfile(@subdirs[0..2], 'bar'); for my $h ($f, $g) { touch_a_file_and_test(File::Spec->catfile($old, $h)); } # Prepare right side $tdir2 = File::Spec->catdir($topdir, 'beta'); $expected = File::Spec->catdir($tdir2, @subdirs); my @expected_files = ( File::Spec->catfile($tdir2, @subdirs[0..1], 'foo'), File::Spec->catfile($tdir2, @subdirs[0..2], 'bar'), ); # Test my ($from, $to) = ($old, $tdir2); $rv = dircopy($from, $to); ok($rv, "dircopy() returned true value"); ok(-d $expected, "dircopy(): directory $expected created"); # test for creation of files for my $b (@expected_files) { ok(-f $b, "dircopy(): file $b created"); } } } # END definition of basic_dircopy_tests() sub mixed_block { my $tdir = tempdir(CLEANUP => 1); my $old = File::Spec->catdir($tdir, 'old'); mkpath $old or die "Unable to mkpath $old"; ok(-d $old, "Created $old for testing"); my $rv = make_mixed_directory($old); ok($rv, "make_mixed_directory() returned true value"); is(ref($rv), 'HASH', "make_mixed_directory() returned hashref"); my $counts = { dirs => scalar @{$rv->{dirs}}, files => scalar @{$rv->{files}}, symlinks => scalar @{$rv->{symlinks}}, }; my $exp = { dirs => 9, files => 6, symlinks => 3, }; is_deeply($counts, $exp, "Got expected number of directories, files and symlinks for testing"); my $new = File::Spec->catdir($tdir, 'new'); $rv = dircopy($old, $new) or die "Unable to dircopy"; ok(defined $rv, "dircopy() returned defined value"); my %seen = (); my $wanted = sub { # NOTE: File::Find returns path with forward slashes on Windows # so we need to convert to canonical path before comparing my $name = File::Spec->canonpath($File::Find::name); unless ($name eq $new) { $seen{dirs}{$name}++ if -d $name; if (-l $name) { $seen{symlinks}{$name}++; } elsif (-f $name) { $seen{files}{$name}++; } } }; find($wanted, $new); #require Data::Dump; #Data::Dump::pp(\%seen); my $created_counts = { dirs => scalar keys %{$seen{dirs}}, files => scalar keys %{$seen{files}}, symlinks => scalar keys %{$seen{symlinks}}, }; is_deeply($created_counts, $counts, "Got expected number of directories, files and symlinks by copying"); } # END definition of mixed_block() sub mixed_imperfect_block { my $tdir = tempdir(CLEANUP => 1); my $old = File::Spec->catdir($tdir, 'old'); mkpath $old or die "Unable to mkpath $old"; ok(-d $old, "Created $old for testing"); my $rv = make_imperfect_mixed_directory($old); ok($rv, "make_imperfect_mixed_directory() returned true value"); is(ref($rv), 'HASH', "make_imperfect_mixed_directory() returned hashref"); my $counts = { dirs => scalar @{$rv->{dirs}}, files => scalar @{$rv->{files}}, symlinks => scalar @{$rv->{symlinks}}, }; my $exp = { dirs => 9, files => 5, symlinks => 3, }; is_deeply($counts, $exp, "Got expected number of directories, files and symlinks for testing"); my $new = File::Spec->catdir($tdir, 'new'); my $stderr = capture_stderr { $rv = dircopy($old, $new) or die "Unable to dircopy"; }; ok(defined $rv, "dircopy() returned defined value"); like( $stderr, qr/Copying a symlink.*?whose target does not exist/, "Got expected warning when copying a symlink whose target does not exist" ); my %seen = (); my $wanted = sub { # NOTE: File::Find returns path with forward slashes on Windows # so we need to convert to canonical path before comparing my $name = File::Spec->canonpath($File::Find::name); unless ($name eq $new) { $seen{dirs}{$name}++ if -d $name; if (-l $name) { $seen{symlinks}{$name}++; } elsif (-f $name) { $seen{files}{$name}++; } } }; find($wanted, $new); #require Data::Dump; #Data::Dump::pp(\%seen); my $created_counts = { dirs => scalar keys %{$seen{dirs}}, files => scalar keys %{$seen{files}}, symlinks => scalar keys %{$seen{symlinks}}, }; is_deeply($created_counts, $counts, "Got expected number of directories, files and symlinks by copying"); } # END definition of mixed_imperfect_block() File-Copy-Recursive-Reduced-0.008/t/003-rcopy.t0000644000175000017500000005636214600277367020552 0ustar jkeenanjkeenan# -*- perl -*- # t/003-rcopy.t - tests of rcopy() method use strict; use warnings; use Test::More tests => 188; use File::Copy::Recursive::Reduced qw( rcopy ); use Capture::Tiny qw(capture_stderr); use File::Find; use File::Path qw(mkpath); use File::Spec; use File::Temp qw(tempdir); use Path::Tiny; use lib qw( t/lib ); use MockHomeDir; use Helper ( qw| create_tfile_and_name_for_new_file_in_same_dir create_tfile get_fresh_tmp_dir create_tsubdir touch_a_file_and_test touch_directories_and_test touch_left_path_and_test prepare_left_side_directories make_mixed_directory |); my ($from, $to, $rv); note("rcopy(): Test faulty or inappropriate arguments"); $rv = rcopy(); ok(! defined $rv, "rcopy() returned undef when not provided correct number of arguments"); $rv = rcopy('foo'); ok(! defined $rv, "rcopy() returned undef when not provided correct number of arguments"); $rv = rcopy('foo', 'bar', 'baz', 'bletch'); ok(! defined $rv, "rcopy() returned undef when not provided correct number of arguments"); $rv = rcopy(undef, 'foo'); ok(! defined $rv, "rcopy() returned undef when first argument was undefined"); $rv = rcopy('foo', undef); ok(! defined $rv, "rcopy() returned undef when second argument was undefined"); $rv = rcopy('foo', 'foo'); ok(! defined $rv, "rcopy() returned undef when provided 2 identical arguments"); SKIP: { skip "System does not support hard links", 3 unless $File::Copy::Recursive::Reduced::Link; my $tdir = tempdir( CLEANUP => 1 ); my ($old, $new) = create_tfile_and_name_for_new_file_in_same_dir($tdir); my $rv = link($old, $new) or die "Unable to link: $!"; ok($rv, "Able to hard link $old and $new"); my $stderr = capture_stderr { $rv = rcopy($old, $new); }; ok(! defined $rv, "rcopy() returned undef when provided arguments with identical dev and ino"); SKIP: { skip 'identical-dev-ino check not applicable on Windows', 1 if ($^O eq 'MSWin32') ; like($stderr, qr/\Q$old and $new are identical\E/, "rcopy(): got expected warning when provided arguments with identical dev and ino"); } } SKIP: { skip "System does not support symlinks", 11 unless $File::Copy::Recursive::Reduced::CopyLink; # System supports symlinks my ($tdir, $old, $new, $symlink, $rv); $tdir = tempdir( CLEANUP => 1 ); $old = create_tfile($tdir); $symlink = File::Spec->catfile($tdir, 'sym'); $rv = symlink($old, $symlink) or die "Unable to symlink $symlink to target $old for testing: $!"; ok(-l $symlink, "rcopy(): $symlink is indeed a symlink"); is(readlink($symlink), $old, "Symlink $symlink points to $old"); $new = File::Spec->catfile($tdir, 'new'); $rv = rcopy($symlink, $new); ok(defined $rv, "fcopy() returned defined value when copying from symlink"); ok($rv, "fcopy() returned true value when copying from symlink"); ok(-f $new, "fcopy(): $new is a file"); ok(-l $new, "fcopy(): but $new is also another symlink"); my ($xold, $xnew, $xsymlink, $stderr); $xold = create_tfile($tdir); $xsymlink = File::Spec->catfile($tdir, 'xsym'); $rv = symlink($xold, $xsymlink) or die "Unable to symlink $xsymlink to target $xold for testing: $!"; ok(-l $xsymlink, "rcopy(): $xsymlink is indeed a symlink"); is(readlink($symlink), $old, "Symlink $symlink points to $old"); $xnew = File::Spec->catfile($tdir, 'xnew'); unlink $xold or die "Unable to unlink $xold during testing: $!"; $stderr = capture_stderr { $rv = rcopy($xsymlink, $xnew); }; ok(defined $rv, "fcopy() returned defined value when copying from symlink"); ok($rv, "fcopy() returned true value when copying from symlink"); like($stderr, qr/Copying a symlink \(\Q$xsymlink\E\) whose target does not exist/, "fcopy(): Got expected warning when copying from symlink whose target does not exist"); } { my ($tdir, $tdir2, $old, $new, $rv); $tdir = tempdir( CLEANUP => 1 ); $tdir2 = tempdir( CLEANUP => 1 ); $new = create_tfile($tdir2, 'new_file'); $rv = rcopy($tdir, $new); ok(! defined $rv, "RTC 123964: rcopy() returned undefined value when first argument was a directory"); } note("rcopy(): Test good arguments"); sub basic_rcopy_file_tests { note("Copy file within existing same directory, new basename"); my ($tdir, $old, $new, $rv, $stderr); $tdir = tempdir( CLEANUP => 1 ); ($old, $new) = create_tfile_and_name_for_new_file_in_same_dir($tdir); note("AAA: 1st: $old"); note(" 2nd: $new"); $rv = rcopy($old, $new); ok($rv, "rcopy() returned true value: $rv"); ok(-f $new, "$old copied to $new, which is file"); note("Copy file to existing different directory, same basename"); my ($tdir2, $basename, $expected_new_file); $tdir2 = tempdir( CLEANUP => 1 ); $basename = 'thirdfile'; $old = create_tfile($tdir, $basename); $expected_new_file = File::Spec->catfile($tdir2, $basename); note("BBB: 1st: $old"); note(" 2nd: $tdir2"); $rv = rcopy($old, $tdir2); ok($rv, "rcopy() returned true value: $rv"); ok(-f $expected_new_file, "$old copied to $expected_new_file, which is file"); note("Copy file to different directory not yet existing;"); note(" basename must be explicitly provided at end of 2nd argument"); my (@subdirs, $newdir); $basename = 'fourth_file'; $old = create_tfile($tdir, $basename); @subdirs = ('alpha', 'beta', 'gamma'); $newdir = File::Spec->catdir($tdir2, @subdirs); $expected_new_file = File::Spec->catfile($newdir, $basename); note("CCC: 1st: $old"); note(" 2nd: $expected_new_file"); $rv = rcopy($old, $expected_new_file); ok($rv, "rcopy() returned true value: $rv"); ok(-f $expected_new_file, "$old copied to $expected_new_file, which is file"); return 1; } sub more_basic_rcopy_file_tests { my ($tdir, $adir, $bdir) = @_; mkdir($adir); mkdir($bdir); for my $d ($tdir, $adir, $bdir) { ok(-d $d, "$d located") or die "Can't find $d"; } for (1..4) { my $f = 'file'. $_; my $af = "$adir/$f";; open my $OUT, '>', $af or die "Unable to open to write"; print $OUT "\n"; close $OUT or die "Unable to close after write"; ok(-f $af, "Created dummy file $af"); } my ($base, $orig, $newbase, $new, $expect, $rv, $newdir, @subdirs); note("Case 1: " . q|rcopy('/path/to/filename', '/path/to/newfile');|); $base = 'file1'; $orig = File::Spec->catfile($adir, $base); $newbase = 'newfile'; $new = $expect = File::Spec->catfile($adir, $newbase); ok(! -e $expect, "$expect does not yet exist"); $rv = rcopy($orig, $new); ok(defined $rv, "rcopy() returned defined value"); ok(-f $expect, "$expect has been created"); note("Case 2: " . q|rcopy('/path/to/filename', '/path/to/existing/directory');|); $base = 'file2'; $orig = File::Spec->catfile($adir, $base); $new = $bdir; $expect = File::Spec->catfile($bdir, $base); ok(! -e $expect, "$expect does not yet exist"); $rv = rcopy($orig, $new); ok(defined $rv, "rcopy() returned defined value"); ok(-f $expect, "$expect has been created"); note("Case 3: " . q|rcopy('/path/to/filename', '/path/not/yet/existing/directory/filename')|); $base = 'file3'; $orig = File::Spec->catfile($adir, $base); @subdirs = qw( alpha beta ); $newdir = File::Spec->catdir($bdir, @subdirs); $new = $expect = File::Spec->catfile($newdir, $base); ok(! -e $expect, "$expect does not yet exist"); $rv = rcopy($orig, $new); ok(defined $rv, "rcopy() returned defined value"); ok(-f $expect, "$expect has been created"); { my $interdir = $bdir; for my $d (@subdirs) { $interdir = File::Spec->catdir($interdir, $d); ok(-d $interdir, "Intermediate directory $interdir created"); } } note("Case 4: " . q|rcopy('/path/to/filename', #'/path/not/yet/existing/directory/newfile');|); $base = 'file4'; $orig = File::Spec->catfile($adir, $base); @subdirs = qw( gamma delta ); $newdir = File::Spec->catdir($bdir, @subdirs); $newbase = 'newfile'; $new = $expect = File::Spec->catfile($newdir, $newbase); ok(! -e $expect, "$expect does not yet exist"); $rv = rcopy($orig, $new); ok(defined $rv, "rcopy() returned defined value"); ok(-f $expect, "$expect has been created"); { my $interdir = $bdir; for my $d (@subdirs) { $interdir = File::Spec->catdir($interdir, $d); ok(-d $interdir, "Intermediate directory $interdir created"); } } return 1; } { note("Basic tests of rcopy()"); basic_rcopy_file_tests(); my $tdir = tempdir(CLEANUP => 1); my $adir = "$tdir/albemarle"; my $bdir = "$tdir/beverly"; more_basic_rcopy_file_tests($tdir, $adir, $bdir); } SKIP: { skip "Set PERL_AUTHOR_TESTING to true to compare with FCR::rcopy()", 29 unless $ENV{PERL_AUTHOR_TESTING}; my $rv = eval { require File::Copy::Recursive; }; SKIP: { skip "Must install File::Copy::Recursive for certain tests", 29 unless $rv; no warnings ('redefine'); local *rcopy = \&File::Copy::Recursive::rcopy; use warnings; note("COMPARISON: Basic tests of File::Copy::Recursive::rcopy()"); basic_rcopy_file_tests(); my $tdir = tempdir(CLEANUP => 1); my $adir = "$tdir/albemarle"; my $bdir = "$tdir/beverly"; more_basic_rcopy_file_tests($tdir, $adir, $bdir); } } { note("Tests from FCR t/01.legacy.t"); my ($tdir, $old, $new, $symlink, $rv); my $tmpd = get_fresh_tmp_dir(); ok(-d $tmpd, "$tmpd exists"); $rv = rcopy( "$tmpd/orig/data", "$tmpd/rcopy" ); is( path("$tmpd/orig/data")->slurp, path("$tmpd/rcopy")->slurp, "rcopy() defaults as expected when target does not exist" ); path("$tmpd/rcopyexisty")->spew("oh hai"); my @rcopy_rv = rcopy( "$tmpd/orig/data", "$tmpd/rcopyexisty"); is( path("$tmpd/orig/data")->slurp, path("$tmpd/rcopyexisty")->slurp, "rcopy() defaults as expected when target does exist" ); # This is the test that fails on FreeBSD # https://rt.cpan.org/Ticket/Display.html?id=123964 $rv = rcopy( "$tmpd/orig", "$tmpd/rcopy" ); ok(!$rv, "RTC 123964: rcopy() returns false if source is a directory"); } { note("Tests using FCR's rcopy() from CPAN::Reporter's test suite"); # t/66_have_tested.t # t/72_rename_history.t my $config_dir = File::Spec->catdir( MockHomeDir::home_dir, ".cpanreporter" ); my $config_file = File::Spec->catfile( $config_dir, "config.ini" ); my $history_file = File::Spec->catfile( $config_dir, "reports-sent.db" ); my $sample_history_file = File::Spec->catfile(qw/t history reports-sent-longer.db/); mkpath( $config_dir ); ok( -d $config_dir, "temporary config dir created" ); # CPAN::Reporter:If old history exists, convert it # I'm not really sure what the point of this test is. SKIP: { skip "$sample_history_file does not exist", 1 unless -e $sample_history_file; rcopy($sample_history_file, $history_file); ok( -f $history_file, "copied sample old history file to config directory"); } } { note("rcopy(): Argument validation"); $rv = rcopy(); ok(! defined $rv, "rcopy() returned undef when not provided correct number of arguments"); $rv = rcopy('foo'); ok(! defined $rv, "rcopy() returned undef when not provided correct number of arguments"); $rv = rcopy('foo', 'bar', 'baz', 'bletch'); ok(! defined $rv, "rcopy() returned undef when not provided correct number of arguments"); $rv = rcopy(undef, 'foo'); ok(! defined $rv, "rcopy() returned undef when first argument was undefined"); $rv = rcopy('foo', undef); ok(! defined $rv, "rcopy() returned undef when second argument was undefined"); $rv = rcopy('foo', 'foo'); ok(! defined $rv, "rcopy() returned undef when provided 2 identical arguments"); SKIP: { skip "System does not support hard links", 3 unless $File::Copy::Recursive::Reduced::Link; my $tdir = tempdir( CLEANUP => 1 ); my ($old, $new) = create_tfile_and_name_for_new_file_in_same_dir($tdir); my $rv = link($old, $new) or die "Unable to link: $!"; ok($rv, "Able to hard link $old and $new"); my $stderr = capture_stderr { $rv = rcopy($old, $new); }; ok(! defined $rv, "rcopy() returned undef when provided arguments with identical dev and ino"); SKIP: { skip 'identical-dev-ino check not applicable on Windows', 1 if ($^O eq 'MSWin32') ; like($stderr, qr/\Q$old and $new are identical\E/, "rcopy(): got expected warning when provided arguments with identical dev and ino"); } } } note("Begin tests with valid arguments"); { note("Second argument (directory) does not yet exist"); my $topdir = tempdir(CLEANUP => 1); my ($tdir, $tdir2); $tdir = File::Spec->catdir($topdir, 'alpha'); mkpath($tdir) or die "Unable to mkpath $tdir"; ok(-d $tdir, "Directory $tdir created"); my $f1 = create_tfile($tdir, 'foo'); my $f2 = create_tfile($tdir, 'bar'); $tdir2 = File::Spec->catdir($topdir, 'beta'); ok(! -d $tdir2, "Directory $tdir2 does not yet exist"); my ($from, $to); $from = $tdir; $to = $tdir2; $rv = rcopy($from, $to); ok(defined $rv, "rcopy() returned defined value"); ok(-d $tdir2, "Directory $tdir2 has been created"); } { note("Copying of subdirs containing no files"); my $topdir = tempdir(CLEANUP => 1); my @tdir_names = ('xray', 'yeller'); my @tdirs = touch_directories_and_test($topdir, \@tdir_names); my @subdir_names = ('alpha', 'beta', 'gamma'); my $ldir = touch_left_path_and_test($tdirs[0], @subdir_names); my @expected_subdirs = (); my $intermed = $tdirs[1]; for my $d (@subdir_names) { $intermed = File::Spec->catdir($intermed, $d); push @expected_subdirs, $intermed; } for my $d (@expected_subdirs) { ok(! -d $d, "Directory $d does not yet exist"); } my ($from, $to); $from = $tdirs[0]; $to = $tdirs[1]; $rv = rcopy($from, $to); ok(defined $rv, "rcopy() returned defined value"); for my $d (@expected_subdirs) { ok(-d $d, "Directory $d has been created"); } } { note("Copying of subdirs containing 1 file at bottom level"); my $topdir = tempdir(CLEANUP => 1); my @tdir_names = ('xray', 'yeller'); my @tdirs = touch_directories_and_test($topdir, \@tdir_names); my @subdir_names = ('alpha', 'beta', 'gamma'); my $ldir = touch_left_path_and_test($tdirs[0], @subdir_names); my $fname = 'foo'; my $f1 = create_tfile($ldir, $fname); ok(-f $f1, "File $f1 created at bottom level"); my @expected_subdirs = (); my $intermed = $tdirs[1]; for my $d (@subdir_names) { $intermed = File::Spec->catdir($intermed, $d); push @expected_subdirs, $intermed; } for my $d (@expected_subdirs) { ok(! -d $d, "Directory $d does not yet exist"); } my $expected_file = File::Spec->catfile($expected_subdirs[-1], $fname); ok(! -f $expected_file, "File $expected_file does not yet exist"); my ($from, $to); $from = $tdirs[0]; $to = $tdirs[1]; $rv = rcopy($from, $to); ok(defined $rv, "rcopy() returned defined value"); for my $d (@expected_subdirs) { ok(-d $d, "Directory $d has been created"); } ok(-f $expected_file, "File $expected_file has been created"); } { note("Copying of subdirs containing 1 file at non-bottom level"); my $topdir = tempdir(CLEANUP => 1); my @tdir_names = ('xray', 'yeller'); my @tdirs = touch_directories_and_test($topdir, \@tdir_names); my @subdir_names = ('alpha', 'beta', 'gamma'); my $ldir = touch_left_path_and_test($tdirs[0], @subdir_names); my $fname = 'foo'; my $f1 = create_tfile(File::Spec->catdir($tdirs[0], @subdir_names[0..1]), $fname); ok(-f $f1, "File $f1 created at non-bottom level"); my @expected_subdirs = (); my $intermed = $tdirs[1]; for my $d (@subdir_names) { $intermed = File::Spec->catdir($intermed, $d); push @expected_subdirs, $intermed; } for my $d (@expected_subdirs) { ok(! -d $d, "Directory $d does not yet exist"); } my $expected_file = File::Spec->catfile($expected_subdirs[-2], $fname); ok(! -f $expected_file, "File $expected_file does not yet exist"); my ($from, $to); $from = $tdirs[0]; $to = $tdirs[1]; $rv = rcopy($from, $to); ok(defined $rv, "rcopy() returned defined value"); for my $d (@expected_subdirs) { ok(-d $d, "Directory $d has been created"); } ok(-f $expected_file, "File $expected_file has been created"); } { my $tdir = tempdir(CLEANUP => 1); my $tdir2 = tempdir(CLEANUP => 1); my $f1 = create_tfile($tdir, 'foo'); my $f2 = create_tfile($tdir, 'bar'); $from = $tdir; $to = $tdir2; $rv = rcopy($from, $to); ok(defined $rv, "rcopy() returned defined value"); $from = "$tdir/*"; $to = $tdir2; $rv = rcopy($from, $to); ok(defined $rv, "rcopy() returned defined value when first argument ends with '/*'"); } my @dirnames = ( qw| able baker camera dogtag elmore fargo golfer hatrack impish jolt karma lily mandate namesake oleo partner quorum robot sterling tamarack ultra victor windy xray yellow zebra | ); sub basic_rcopy_dir_tests { my @dirnames = @_; { note("Multiple directories; no files"); my $topdir = tempdir(CLEANUP => 1); my ($tdir, $tdir2, $old, $oldtree, $new, $rv, $expected); my @subdirs = @dirnames[0..4]; # Prepare left side ($old, $oldtree) = prepare_left_side_directories($topdir, 'alpha', \@subdirs); # Prepare right side $tdir2 = File::Spec->catdir($topdir, 'beta'); $expected = File::Spec->catdir($tdir2, @subdirs); # Test my ($from, $to) = ($old, $tdir2); $rv = rcopy($from, $to); ok($rv, "rcopy() returned true value"); ok(-d $tdir2, "rcopy(): directory $tdir2 created"); ok(-d $expected, "rcopy(): directory $expected created"); } { note("Multiple directories; files at bottom level"); my $topdir = tempdir(CLEANUP => 1); my ($tdir, $tdir2, $old, $oldtree, $new, $rv, $expected); my (@basenames); my @subdirs = @dirnames[5..7]; # Prepare left side ($old, $oldtree) = prepare_left_side_directories($topdir, 'alpha', \@subdirs); @basenames = qw| foo bar |; for my $b (@basenames) { my $f = touch_a_file_and_test(File::Spec->catfile($oldtree, $b)); } # Prepare right side $tdir2 = File::Spec->catdir($topdir, 'beta'); $expected = File::Spec->catdir($tdir2, @subdirs); # Test my ($from, $to) = ($old, $tdir2); $rv = rcopy($from, $to); ok(-d $expected, "rcopy(): directory $expected created"); # test for creation of files for my $b (@basenames) { my $f = File::Spec->catfile($expected, $b); ok(-f $f, "rcopy(): file $f created"); } } { note("Multiple directories; files at intermediate levels"); my $topdir = tempdir(CLEANUP => 1); my ($tdir, $tdir2, $old, $oldtree, $new, $rv, $expected); my @subdirs = @dirnames[8..11]; # Prepare left side ($old, $oldtree) = prepare_left_side_directories($topdir, 'alpha', \@subdirs); my $f = File::Spec->catfile(@subdirs[0..1], 'foo'); my $g = File::Spec->catfile(@subdirs[0..2], 'bar'); for my $h ($f, $g) { touch_a_file_and_test(File::Spec->catfile($old, $h)); } # Prepare right side $tdir2 = File::Spec->catdir($topdir, 'beta'); $expected = File::Spec->catdir($tdir2, @subdirs); my @expected_files = ( File::Spec->catfile($tdir2, @subdirs[0..1], 'foo'), File::Spec->catfile($tdir2, @subdirs[0..2], 'bar'), ); # Test my ($from, $to) = ($old, $tdir2); $rv = rcopy($from, $to); ok($rv, "rcopy() returned true value"); ok(-d $expected, "rcopy(): directory $expected created"); # test for creation of files for my $b (@expected_files) { ok(-f $b, "rcopy(): file $b created"); } } } # END definition of basic_rcopy_dir_tests() sub rcopy_mixed_block { my $tdir = tempdir(CLEANUP => 1); my $old = File::Spec->catdir($tdir, 'old'); mkpath $old or die "Unable to mkpath $old"; ok(-d $old, "Created $old for testing"); my $rv = make_mixed_directory($old); ok($rv, "make_mixed_directory() returned true value"); is(ref($rv), 'HASH', "make_mixed_directory() returned hashref"); my $counts = { dirs => scalar @{$rv->{dirs}}, files => scalar @{$rv->{files}}, symlinks => scalar @{$rv->{symlinks}}, }; my $exp = { dirs => 9, files => 6, symlinks => 3, }; is_deeply($counts, $exp, "Got expected number of directories, files and symlinks for testing"); my $new = File::Spec->catdir($tdir, 'new'); $rv = rcopy($old, $new) or die "Unable to rcopy"; ok(defined $rv, "rcopy() returned defined value"); my %seen = (); my $wanted = sub { # NOTE: File::Find returns path with forward slashes on Windows # so we need to convert to canonical path before comparing my $name = File::Spec->canonpath($File::Find::name); unless ($name eq $new) { $seen{dirs}{$name}++ if -d $name; if (-l $name) { $seen{symlinks}{$name}++; } elsif (-f $name) { $seen{files}{$name}++; } } }; find($wanted, $new); #require Data::Dump; #Data::Dump::pp(\%seen); my $created_counts = { dirs => scalar keys %{$seen{dirs}}, files => scalar keys %{$seen{files}}, symlinks => scalar keys %{$seen{symlinks}}, }; is_deeply($created_counts, $counts, "Got expected number of directories, files and symlinks by copying"); } # END definition of rcopy_mixed_block() { note("Basic tests of File::Copy::Recursive::Reduced::rcopy()"); basic_rcopy_dir_tests(@dirnames); SKIP: { skip "System does not support symlinks", 6 unless $File::Copy::Recursive::Reduced::CopyLink; note("Copy directory which holds symlinks"); rcopy_mixed_block(); } } SKIP: { skip "Set PERL_AUTHOR_TESTING to true to compare with FCR::rcopy()", 26 unless $ENV{PERL_AUTHOR_TESTING}; my $rv = eval { require File::Copy::Recursive; }; SKIP: { skip "Must install File::Copy::Recursive for certain tests", 26 unless $rv; no warnings ('redefine'); local *rcopy = \&File::Copy::Recursive::rcopy; use warnings; note("COMPARISON: Basic tests of File::Copy::Recursive::rcopy()"); basic_rcopy_dir_tests(@dirnames); SKIP: { skip "System does not support symlinks", 6 unless $File::Copy::Recursive::Reduced::CopyLink; note("Copy directory which holds symlinks"); rcopy_mixed_block(); } } } __END__