| 1 |
#!/usr/bin/perl |
| 2 |
|
| 3 |
use strict; |
| 4 |
use warnings; |
| 5 |
use File::Copy; |
| 6 |
use File::Find; |
| 7 |
use File::Path; |
| 8 |
use POSIX qw(mkfifo); |
| 9 |
use Getopt::Long; |
| 10 |
|
| 11 |
# pcopy [-i <path>] [-s <regex>]* <src> <target> |
| 12 |
# Copy directory trees with optional path substitutions/exclusions. |
| 13 |
|
| 14 |
my $verbose = 0; |
| 15 |
my $matchonly = 0; |
| 16 |
my (@subst, @incl); |
| 17 |
|
| 18 |
GetOptions( |
| 19 |
's=s' => \@subst, |
| 20 |
'i=s' => \@incl, |
| 21 |
'm|matchonly' => \$matchonly, |
| 22 |
'v' => \$verbose, |
| 23 |
'paxargs=s' => sub {}, # accepted but ignored |
| 24 |
) or die "Usage: pcopy [-s regex]* [-i path]* <from> <to>\n"; |
| 25 |
|
| 26 |
die "Usage: pcopy <from> <to>\n" if @ARGV != 2; |
| 27 |
|
| 28 |
# Convert \1 back-references to $1 style |
| 29 |
s/\\(\d)/\$$1/g foreach @subst; |
| 30 |
|
| 31 |
my ($fromdir, $todir) = @ARGV; |
| 32 |
|
| 33 |
if (!-d $fromdir) { |
| 34 |
print STDERR "Source directory not found: $fromdir\n"; |
| 35 |
exit 1; |
| 36 |
} |
| 37 |
|
| 38 |
mkpath($todir, 0, 0775) unless -d $todir; |
| 39 |
|
| 40 |
my %hardlinks; |
| 41 |
|
| 42 |
sub docopy { |
| 43 |
my $whole = $fromdir . '/' . $File::Find::name; |
| 44 |
my $target = $File::Find::name; |
| 45 |
my @matches = ($target); |
| 46 |
my $didmatch = 0; |
| 47 |
|
| 48 |
my $keepfile = 0; |
| 49 |
foreach my $i (@incl) { |
| 50 |
$keepfile = 1 if $target =~ /$i/; |
| 51 |
} |
| 52 |
|
| 53 |
foreach my $s (@subst) { |
| 54 |
my $t = $target; |
| 55 |
(my $rs = $s) =~ s/p$//; |
| 56 |
$rs =~ s/\\\(/(/g; |
| 57 |
$rs =~ s/\\\)/)/g; |
| 58 |
eval("\$didmatch = 1 if \$target =~ s$rs"); |
| 59 |
if ($keepfile && $target eq '') { |
| 60 |
$target = $t; |
| 61 |
$keepfile = 2; |
| 62 |
} |
| 63 |
push @matches, $target if $t ne $target; |
| 64 |
} |
| 65 |
|
| 66 |
return if !$didmatch && $matchonly; |
| 67 |
return if $target eq ''; |
| 68 |
|
| 69 |
if ($verbose || @subst) { |
| 70 |
print join(' >> ', @matches); |
| 71 |
print ' (kept)' if $keepfile == 2; |
| 72 |
print "\n"; |
| 73 |
} |
| 74 |
|
| 75 |
my @parts = split(/\//, $target); |
| 76 |
my $targetdir = $todir . '/' . join('/', @parts[0..$#parts-1]); |
| 77 |
|
| 78 |
if (-e $targetdir && !-d $targetdir) { |
| 79 |
print STDERR "ERROR: $targetdir exists as a file\n"; |
| 80 |
} elsif (!-d $targetdir) { |
| 81 |
mkpath($targetdir); |
| 82 |
} |
| 83 |
|
| 84 |
if (-d $whole && !-l $whole) { |
| 85 |
mkpath($todir . '/' . $target); |
| 86 |
return; |
| 87 |
} |
| 88 |
|
| 89 |
if (-p $whole) { |
| 90 |
mkfifo($todir . '/' . $target, (stat($whole))[2]); |
| 91 |
return; |
| 92 |
} |
| 93 |
|
| 94 |
if (-l $whole) { |
| 95 |
my $link = readlink($whole); |
| 96 |
my $lt = $todir . '/' . $target; |
| 97 |
if (-l $lt) { |
| 98 |
my $old = readlink($lt); |
| 99 |
print "Symlink conflict: $lt -> $old (want $link)\n" if $link ne $old; |
| 100 |
} elsif (-e $lt) { |
| 101 |
print "Cannot symlink $lt: file exists\n"; |
| 102 |
} else { |
| 103 |
symlink($link, $lt) or print "symlink failed: $lt\n"; |
| 104 |
} |
| 105 |
} else { |
| 106 |
my ($dev, $ino, $mode, undef, undef, undef, undef, undef, $atime, $mtime) = stat($whole); |
| 107 |
if (exists $hardlinks{$ino}) { |
| 108 |
link($hardlinks{$ino}, $todir . '/' . $target) |
| 109 |
or print STDERR "hardlink failed: $target\n"; |
| 110 |
} else { |
| 111 |
copy($whole, $todir . '/' . $target) or print "Copy failed: $target\n"; |
| 112 |
chmod($mode, $todir . '/' . $target); |
| 113 |
utime $atime, $mtime, $todir . '/' . $target; |
| 114 |
$hardlinks{$ino} = $todir . '/' . $target; |
| 115 |
} |
| 116 |
} |
| 117 |
} |
| 118 |
|
| 119 |
local $| = 1; |
| 120 |
chdir($fromdir) or die "Cannot chdir to '$fromdir': $!\n"; |
| 121 |
find({ wanted => \&docopy, no_chdir => 1 }, '.'); |
