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
+
2
16
package RecursiveCopy ;
3
17
4
18
use strict;
@@ -7,10 +21,56 @@ use warnings;
7
21
use File::Basename;
8
22
use File::Copy;
9
23
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
+
10
50
sub copypath
11
51
{
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 ) = @_ ;
14
74
15
75
die " Cannot operate on symlinks" if -l $srcpath or -l $destpath ;
16
76
@@ -19,8 +79,11 @@ sub copypath
19
79
die " Destination path $destpath exists as file" if -f $destpath ;
20
80
if (-f $srcpath )
21
81
{
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
+ }
24
87
return 1;
25
88
}
26
89
@@ -32,7 +95,8 @@ sub copypath
32
95
while (my $entry = readdir ($directory ))
33
96
{
34
97
next if ($entry eq ' .' || $entry eq ' ..' );
35
- RecursiveCopy::copypath(" $srcpath /$entry " , " $destpath /$entry " )
98
+ RecursiveCopy::_copypath_recurse(" $srcpath /$entry " ,
99
+ " $destpath /$entry " , $filterfn )
36
100
or die " copypath $srcpath /$entry -> $destpath /$entry failed" ;
37
101
}
38
102
closedir ($directory );
0 commit comments