# Copyright (c) 2021, PostgreSQL Global Development Group =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 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;