Location via proxy:   [ UP ]  
[Report a bug]   [Manage cookies]                
Skip to content

Commit 8fd42e6

Browse files
committed
TAP: Add filtering to RecursiveCopy
Allow RecursiveCopy to accept a filter function so callers can exclude unwanted files. Also POD-ify it.
1 parent 26fdff1 commit 8fd42e6

File tree

1 file changed

+70
-6
lines changed

1 file changed

+70
-6
lines changed

src/test/perl/RecursiveCopy.pm

Lines changed: 70 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,18 @@
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+
216
package RecursiveCopy;
317

418
use strict;
@@ -7,10 +21,56 @@ use warnings;
721
use File::Basename;
822
use 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+
1050
sub 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

1575
die "Cannot operate on symlinks" if -l $srcpath or -l $destpath;
1676

@@ -19,8 +79,11 @@ sub copypath
1979
die "Destination path $destpath exists as file" if -f $destpath;
2080
if (-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+
}
2487
return 1;
2588
}
2689

@@ -32,7 +95,8 @@ sub copypath
3295
while (my $entry = readdir($directory))
3396
{
3497
next if ($entry eq '.' || $entry eq '..');
35-
RecursiveCopy::copypath("$srcpath/$entry", "$destpath/$entry")
98+
RecursiveCopy::_copypath_recurse("$srcpath/$entry",
99+
"$destpath/$entry", $filterfn)
36100
or die "copypath $srcpath/$entry -> $destpath/$entry failed";
37101
}
38102
closedir($directory);

0 commit comments

Comments
 (0)