1- # RecursiveCopy, a simple recursive copy implementation
1+
2+ =pod
3+
4+ =head1 NAME
5+
6+ RecursiveCopy - simple recursive copy implementation
7+
8+ =head1 SYNOPSIS
9+
10+ use RecursiveCopy;
11+
12+ RecursiveCopy::copypath($from, $to, filterfn => sub { return 1; });
13+ RecursiveCopy::copypath($from, $to);
14+
15+ =cut
16+
217package RecursiveCopy ;
318
419use strict;
@@ -7,35 +22,105 @@ use warnings;
722use File::Basename;
823use File::Copy;
924
25+ =pod
26+
27+ =head1 DESCRIPTION
28+
29+ =head2 copypath($from, $to, %params)
30+
31+ Recursively copy all files and directories from $from to $to.
32+
33+ Only regular files and subdirectories are copied. Trying to copy other types
34+ of directory entries raises an exception.
35+
36+ Raises an exception if a file would be overwritten, the source directory can't
37+ be read, or any I/O operation fails. Always returns true.
38+
39+ If theB<filterfn > parameter is given, it must be a subroutine reference.
40+ This subroutine will be called for each entry in the source directory with its
41+ relative path as only parameter; if the subroutine returns true the entry is
42+ copied, otherwise the file is skipped.
43+
44+ On failure the target directory may be in some incomplete state; no cleanup is
45+ attempted.
46+
47+ =head1 EXAMPLES
48+
49+ RecursiveCopy::copypath('/some/path', '/empty/dir',
50+ filterfn => sub {
51+ # omit pg_log and contents
52+ my $src = shift;
53+ return $src ne 'pg_log';
54+ }
55+ );
56+
57+ =cut
58+
1059sub copypath
1160{
12- my $srcpath = shift ;
13- my $destpath = shift ;
61+ my ( $base_src_dir , $base_dest_dir , %params ) = @_ ;
62+ my $filterfn ;
1463
15- die " Cannot operate on symlinks" if -l $srcpath or -l $destpath ;
64+ if (defined $params {filterfn })
65+ {
66+ die " if specified, filterfn must be a subroutine reference"
67+ unless defined (ref $params {filterfn })
68+ and (ref $params {filterfn }eq ' CODE'
1669
17- # This source path is a file, simply copy it to destination with the
18- # same name.
19- die " Destination path$destpath exists as file" if -f $destpath ;
70+ $filterfn =$params {filterfn };
71+ }
72+ else
73+ {
74+ $filterfn =sub {return 1; };
75+ }
76+
77+ # Start recursive copy from current directory
78+ return _copypath_recurse($base_src_dir ,$base_dest_dir ," " $filterfn );
79+ }
80+
81+ # Recursive private guts of copypath
82+ sub _copypath_recurse
83+ {
84+ my ($base_src_dir ,$base_dest_dir ,$curr_path ,$filterfn ) =@_ ;
85+ my $srcpath =" $base_src_dir /$curr_path "
86+ my $destpath =" $base_dest_dir /$curr_path "
87+
88+ # invoke the filter and skip all further operation if it returns false
89+ return 1unless &$filterfn ($curr_path );
90+
91+ # Check for symlink -- needed only on source dir
92+ die " Cannot operate on symlinks" if -l $srcpath ;
93+
94+ # Can't handle symlinks or other weird things
95+ die " Source path\" $srcpath \" is not a regular file or directory"
96+ unless -f $srcpath or -d $srcpath ;
97+
98+ # Abort if destination path already exists. Should we allow directories
99+ # to exist already?
100+ die " Destination path\" $destpath \" already exists" if -e $destpath ;
101+
102+ # If this source path is a file, simply copy it to destination with the
103+ # same name and we're done.
20104if (-f $srcpath )
21105{
22106copy($srcpath ,$destpath )
23107or die " copy$srcpath ->$destpath failed:$! "
24108return 1;
25109}
26110
27- die " Destination needs to be a directory " unless -d $srcpath ;
111+ # Otherwise this is directory: create it on dest and recurse onto it.
28112mkdir ($destpath )or die " mkdir($destpath ) failed:$! "
29113
30- # Scan existing source directory and recursively copy everything.
31114opendir (my $directory ,$srcpath )or die " could not opendir($srcpath ):$! "
32115while (my $entry =readdir ($directory ))
33116{
34- next if ($entry eq ' .' $entry eq ' ..'
35- RecursiveCopy::copypath(" $srcpath /$entry " " $destpath /$entry "
117+ next if ($entry eq ' .' or $entry eq ' ..'
118+ _copypath_recurse($base_src_dir ,$base_dest_dir ,
119+ $curr_path eq ' ' $entry :" $curr_path /$entry " $filterfn )
36120or die " copypath$srcpath /$entry ->$destpath /$entry failed"
37121}
38122closedir ($directory );
123+
39124return 1;
40125}
41126