1 files changed, 155 insertions, 0 deletions
diff --git a/src/test/perl/RecursiveCopy.pm b/src/test/perl/RecursiveCopy.pm
new file mode 100644
index 0000000..baf5d0a
--- /dev/null
+++ b/src/test/perl/RecursiveCopy.pm
@@ -0,0 +1,155 @@
+
+=pod
+
+=head1 NAME
+
+RecursiveCopy - simple recursive copy implementation
+
+=head1 SYNOPSIS
+
+use RecursiveCopy;
+
+RecursiveCopy::copypath($from, $to, filterfn => sub { return 1; });
+RecursiveCopy::copypath($from, $to);
+
+=cut
+
+package RecursiveCopy;
+
+use strict;
+use warnings;
+
+use Carp;
+use File::Basename;
+use File::Copy;
+
+=pod
+
+=head1 DESCRIPTION
+
+=head2 copypath($from, $to, %params)
+
+Recursively copy all files and directories from $from to $to.
+Does not preserve file metadata (e.g., permissions).
+
+Only regular files and subdirectories are copied.  Trying to copy other types
+of directory entries raises an exception.
+
+Raises an exception if a file would be overwritten, the source directory can't
+be read, or any I/O operation fails.  However, we silently ignore ENOENT on
+open, because when copying from a live database it's possible for a file/dir
+to be deleted after we see its directory entry but before we can open it.
+
+Always returns true.
+
+If the B<filterfn> parameter is given, it must be a subroutine reference.
+This subroutine will be called for each entry in the source directory with its
+relative path as only parameter; if the subroutine returns true the entry is
+copied, otherwise the file is skipped.
+
+On failure the target directory may be in some incomplete state; no cleanup is
+attempted.
+
+=head1 EXAMPLES
+
+ RecursiveCopy::copypath('/some/path', '/empty/dir',
+    filterfn => sub {
+		# omit log/ and contents
+		my $src = shift;
+		return $src ne 'log';
+	}
+ );
+
+=cut
+
+sub copypath
+{
+	my ($base_src_dir, $base_dest_dir, %params) = @_;
+	my $filterfn;
+
+	if (defined $params{filterfn})
+	{
+		croak "if specified, filterfn must be a subroutine reference"
+		  unless defined(ref $params{filterfn})
+		  and (ref $params{filterfn} eq 'CODE');
+
+		$filterfn = $params{filterfn};
+	}
+	else
+	{
+		$filterfn = sub { return 1; };
+	}
+
+	# Complain if original path is bogus, because _copypath_recurse won't.
+	croak "\"$base_src_dir\" does not exist" if !-e $base_src_dir;
+
+	# Start recursive copy from current directory
+	return _copypath_recurse($base_src_dir, $base_dest_dir, "", $filterfn);
+}
+
+# Recursive private guts of copypath
+sub _copypath_recurse
+{
+	my ($base_src_dir, $base_dest_dir, $curr_path, $filterfn) = @_;
+	my $srcpath  = "$base_src_dir/$curr_path";
+	my $destpath = "$base_dest_dir/$curr_path";
+
+	# invoke the filter and skip all further operation if it returns false
+	return 1 unless &$filterfn($curr_path);
+
+	# Check for symlink -- needed only on source dir
+	# (note: this will fall through quietly if file is already gone)
+	croak "Cannot operate on symlink \"$srcpath\"" if -l $srcpath;
+
+	# Abort if destination path already exists.  Should we allow directories
+	# to exist already?
+	croak "Destination path \"$destpath\" already exists" if -e $destpath;
+
+	# If this source path is a file, simply copy it to destination with the
+	# same name and we're done.
+	if (-f $srcpath)
+	{
+		my $fh;
+		unless (open($fh, '<', $srcpath))
+		{
+			return 1 if ($!{ENOENT});
+			die "open($srcpath) failed: $!";
+		}
+		copy($fh, $destpath)
+		  or die "copy $srcpath -> $destpath failed: $!";
+		close $fh;
+		return 1;
+	}
+
+	# If it's a directory, create it on dest and recurse into it.
+	if (-d $srcpath)
+	{
+		my $directory;
+		unless (opendir($directory, $srcpath))
+		{
+			return 1 if ($!{ENOENT});
+			die "opendir($srcpath) failed: $!";
+		}
+
+		mkdir($destpath) or die "mkdir($destpath) failed: $!";
+
+		while (my $entry = readdir($directory))
+		{
+			next if ($entry eq '.' or $entry eq '..');
+			_copypath_recurse($base_src_dir, $base_dest_dir,
+				$curr_path eq '' ? $entry : "$curr_path/$entry", $filterfn)
+			  or die "copypath $srcpath/$entry -> $destpath/$entry failed";
+		}
+
+		closedir($directory);
+		return 1;
+	}
+
+	# If it disappeared from sight, that's OK.
+	return 1 if !-e $srcpath;
+
+	# Else it's some weird file type; complain.
+	croak "Source path \"$srcpath\" is not a regular file or directory";
+}
+
+1;