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);
13+
14+ =cut
15+
216package RecursiveCopy ;
317
418use strict;
@@ -7,10 +21,56 @@ use warnings;
721use File::Basename;
822use File::Copy;
923
24+ =pod
25+
26+ =head2 copypath($from, $to)
27+
28+ Copy all files and directories from $from to $to. Raises an exception
29+ if a file would be overwritten, the source dir can't be read, or any
30+ I/O operation fails. Always returns true. On failure the copy may be
31+ in some incomplete state; no cleanup is attempted.
32+
33+ If the keyword param 'filterfn' is defined it's invoked as a sub that
34+ returns true if the file/directory should be copied, false otherwise.
35+ The passed path is the full path to the file relative to the source
36+ directory.
37+
38+ e.g.
39+
40+ RecursiveCopy::copypath('/some/path', '/empty/dir',
41+ filterfn => sub {^
42+ # omit children of pg_log
43+ my $src = shift;
44+ return ! $src ~= /\/pg_log\//
45+ }
46+ );
47+
48+ =cut
49+
1050sub copypath
1151{
12- my $srcpath =shift ;
13- my $destpath =shift ;
52+ my ($srcpath ,$destpath ,%params ) =@_ ;
53+
54+ die (" if specified, 'filterfn' must be a sub ref"
55+ if defined $params {filterfn } && !ref $params {filterfn };
56+
57+ my $filterfn ;
58+ if (defined $params {filterfn })
59+ {
60+ $filterfn =$params {filterfn };
61+ }
62+ else
63+ {
64+ $filterfn =sub {return 1; };
65+ }
66+
67+ return _copypath_recurse($srcpath ,$destpath ,$filterfn );
68+ }
69+
70+ # Recursive private guts of copypath
71+ sub _copypath_recurse
72+ {
73+ my ($srcpath ,$destpath ,$filterfn ) =@_ ;
1474
1575die " Cannot operate on symlinks" if -l $srcpath or -l $destpath ;
1676
@@ -19,8 +79,11 @@ sub copypath
1979die " Destination path$destpath exists as file" if -f $destpath ;
2080if (-f $srcpath )
2181{
22- copy($srcpath ,$destpath )
23- or die " copy$srcpath ->$destpath failed:$! "
82+ if ($filterfn -> ($srcpath ))
83+ {
84+ copy($srcpath ,$destpath )
85+ or die " copy$srcpath ->$destpath failed:$! "
86+ }
2487return 1;
2588}
2689
@@ -32,7 +95,8 @@ sub copypath
3295while (my $entry =readdir ($directory ))
3396{
3497next if ($entry eq ' .' $entry eq ' ..'
35- RecursiveCopy::copypath(" $srcpath /$entry " " $destpath /$entry "
98+ RecursiveCopy::_copypath_recurse(" $srcpath /$entry "
99+ " $destpath /$entry " $filterfn )
36100or die " copypath$srcpath /$entry ->$destpath /$entry failed"
37101}
38102closedir ($directory );