Commit | Line | Data |
dbcf12a6 |
1 | #line 1 |
2 | package File::Copy::Recursive; |
3 | |
4 | use strict; |
5 | BEGIN { |
6 | # Keep older versions of Perl from trying to use lexical warnings |
7 | $INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006; |
8 | } |
9 | use warnings; |
10 | |
11 | use Carp; |
12 | use File::Copy; |
13 | use File::Spec; #not really needed because File::Copy already gets it, but for good measure :) |
14 | |
15 | use vars qw( |
16 | @ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink |
17 | $PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir |
18 | $CondCopy $BdTrgWrn $SkipFlop $DirPerms |
19 | ); |
20 | |
21 | require Exporter; |
22 | @ISA = qw(Exporter); |
23 | @EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir); |
24 | $VERSION = '0.38'; |
25 | |
26 | $MaxDepth = 0; |
27 | $KeepMode = 1; |
28 | $CPRFComp = 0; |
29 | $CopyLink = eval { local $SIG{'__DIE__'};symlink '',''; 1 } || 0; |
30 | $PFSCheck = 1; |
31 | $RemvBase = 0; |
32 | $NoFtlPth = 0; |
33 | $ForcePth = 0; |
34 | $CopyLoop = 0; |
35 | $RMTrgFil = 0; |
36 | $RMTrgDir = 0; |
37 | $CondCopy = {}; |
38 | $BdTrgWrn = 0; |
39 | $SkipFlop = 0; |
40 | $DirPerms = 0777; |
41 | |
42 | my $samecheck = sub { |
43 | return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders... |
44 | return if @_ != 2 || !defined $_[0] || !defined $_[1]; |
45 | return if $_[0] eq $_[1]; |
46 | |
47 | my $one = ''; |
48 | if($PFSCheck) { |
49 | $one = join( '-', ( stat $_[0] )[0,1] ) || ''; |
50 | my $two = join( '-', ( stat $_[1] )[0,1] ) || ''; |
51 | if ( $one eq $two && $one ) { |
52 | carp "$_[0] and $_[1] are identical"; |
53 | return; |
54 | } |
55 | } |
56 | |
57 | if(-d $_[0] && !$CopyLoop) { |
58 | $one = join( '-', ( stat $_[0] )[0,1] ) if !$one; |
59 | my $abs = File::Spec->rel2abs($_[1]); |
60 | my @pth = File::Spec->splitdir( $abs ); |
61 | while(@pth) { |
62 | my $cur = File::Spec->catdir(@pth); |
63 | last if !$cur; # probably not necessary, but nice to have just in case :) |
64 | my $two = join( '-', ( stat $cur )[0,1] ) || ''; |
65 | if ( $one eq $two && $one ) { |
66 | # $! = 62; # Too many levels of symbolic links |
67 | carp "Caught Deep Recursion Condition: $_[0] contains $_[1]"; |
68 | return; |
69 | } |
70 | |
71 | pop @pth; |
72 | } |
73 | } |
74 | |
75 | return 1; |
76 | }; |
77 | |
78 | my $glob = sub { |
79 | my ($do, $src_glob, @args) = @_; |
80 | |
81 | local $CPRFComp = 1; |
82 | |
83 | my @rt; |
84 | for my $path ( glob($src_glob) ) { |
85 | my @call = [$do->($path, @args)] or return; |
86 | push @rt, \@call; |
87 | } |
88 | |
89 | return @rt; |
90 | }; |
91 | |
92 | my $move = sub { |
93 | my $fl = shift; |
94 | my @x; |
95 | if($fl) { |
96 | @x = fcopy(@_) or return; |
97 | } else { |
98 | @x = dircopy(@_) or return; |
99 | } |
100 | if(@x) { |
101 | if($fl) { |
102 | unlink $_[0] or return; |
103 | } else { |
104 | pathrmdir($_[0]) or return; |
105 | } |
106 | if($RemvBase) { |
107 | my ($volm, $path) = File::Spec->splitpath($_[0]); |
108 | pathrm(File::Spec->catpath($volm,$path,''), $ForcePth, $NoFtlPth) or return; |
109 | } |
110 | } |
111 | return wantarray ? @x : $x[0]; |
112 | }; |
113 | |
114 | my $ok_todo_asper_condcopy = sub { |
115 | my $org = shift; |
116 | my $copy = 1; |
117 | if(exists $CondCopy->{$org}) { |
118 | if($CondCopy->{$org}{'md5'}) { |
119 | |
120 | } |
121 | if($copy) { |
122 | |
123 | } |
124 | } |
125 | return $copy; |
126 | }; |
127 | |
128 | sub fcopy { |
129 | $samecheck->(@_) or return; |
130 | if($RMTrgFil && (-d $_[1] || -e $_[1]) ) { |
131 | my $trg = $_[1]; |
132 | if( -d $trg ) { |
133 | my @trgx = File::Spec->splitpath( $_[0] ); |
134 | $trg = File::Spec->catfile( $_[1], $trgx[ $#trgx ] ); |
135 | } |
136 | $samecheck->($_[0], $trg) or return; |
137 | if(-e $trg) { |
138 | if($RMTrgFil == 1) { |
139 | unlink $trg or carp "\$RMTrgFil failed: $!"; |
140 | } else { |
141 | unlink $trg or return; |
142 | } |
143 | } |
144 | } |
145 | my ($volm, $path) = File::Spec->splitpath($_[1]); |
146 | if($path && !-d $path) { |
147 | pathmk(File::Spec->catpath($volm,$path,''), $NoFtlPth); |
148 | } |
149 | if( -l $_[0] && $CopyLink ) { |
150 | carp "Copying a symlink ($_[0]) whose target does not exist" |
151 | if !-e readlink($_[0]) && $BdTrgWrn; |
152 | symlink readlink(shift()), shift() or return; |
153 | } else { |
154 | copy(@_) or return; |
155 | |
156 | my @base_file = File::Spec->splitpath($_[0]); |
157 | my $mode_trg = -d $_[1] ? File::Spec->catfile($_[1], $base_file[ $#base_file ]) : $_[1]; |
158 | |
159 | chmod scalar((stat($_[0]))[2]), $mode_trg if $KeepMode; |
160 | } |
161 | return wantarray ? (1,0,0) : 1; # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings |
162 | } |
163 | |
164 | sub rcopy { |
165 | if (-l $_[0] && $CopyLink) { |
166 | goto &fcopy; |
167 | } |
168 | |
169 | goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*'; |
170 | goto &fcopy; |
171 | } |
172 | |
173 | sub rcopy_glob { |
174 | $glob->(\&rcopy, @_); |
175 | } |
176 | |
177 | sub dircopy { |
178 | if($RMTrgDir && -d $_[1]) { |
179 | if($RMTrgDir == 1) { |
180 | pathrmdir($_[1]) or carp "\$RMTrgDir failed: $!"; |
181 | } else { |
182 | pathrmdir($_[1]) or return; |
183 | } |
184 | } |
185 | my $globstar = 0; |
186 | my $_zero = $_[0]; |
187 | my $_one = $_[1]; |
188 | if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*') { |
189 | $globstar = 1; |
190 | $_zero = substr( $_zero, 0, ( length( $_zero ) - 1 ) ); |
191 | } |
192 | |
193 | $samecheck->( $_zero, $_[1] ) or return; |
194 | if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) { |
195 | $! = 20; |
196 | return; |
197 | } |
198 | |
199 | if(!-d $_[1]) { |
200 | pathmk($_[1], $NoFtlPth) or return; |
201 | } else { |
202 | if($CPRFComp && !$globstar) { |
203 | my @parts = File::Spec->splitdir($_zero); |
204 | while($parts[ $#parts ] eq '') { pop @parts; } |
205 | $_one = File::Spec->catdir($_[1], $parts[$#parts]); |
206 | } |
207 | } |
208 | my $baseend = $_one; |
209 | my $level = 0; |
210 | my $filen = 0; |
211 | my $dirn = 0; |
212 | |
213 | my $recurs; #must be my()ed before sub {} since it calls itself |
214 | $recurs = sub { |
215 | my ($str,$end,$buf) = @_; |
216 | $filen++ if $end eq $baseend; |
217 | $dirn++ if $end eq $baseend; |
218 | |
219 | $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0'; |
220 | mkdir($end,$DirPerms) or return if !-d $end; |
221 | chmod scalar((stat($str))[2]), $end if $KeepMode; |
222 | if($MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth) { |
223 | return ($filen,$dirn,$level) if wantarray; |
224 | return $filen; |
225 | } |
226 | $level++; |
227 | |
228 | |
229 | my @files; |
230 | if ( $] < 5.006 ) { |
231 | opendir(STR_DH, $str) or return; |
232 | @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH)); |
233 | closedir STR_DH; |
234 | } |
235 | else { |
236 | opendir(my $str_dh, $str) or return; |
237 | @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh)); |
238 | closedir $str_dh; |
239 | } |
240 | |
241 | for my $file (@files) { |
242 | my ($file_ut) = $file =~ m{ (.*) }xms; |
243 | my $org = File::Spec->catfile($str, $file_ut); |
244 | my $new = File::Spec->catfile($end, $file_ut); |
245 | if( -l $org && $CopyLink ) { |
246 | carp "Copying a symlink ($org) whose target does not exist" |
247 | if !-e readlink($org) && $BdTrgWrn; |
248 | symlink readlink($org), $new or return; |
249 | } |
250 | elsif(-d $org) { |
251 | $recurs->($org,$new,$buf) if defined $buf; |
252 | $recurs->($org,$new) if !defined $buf; |
253 | $filen++; |
254 | $dirn++; |
255 | } |
256 | else { |
257 | if($ok_todo_asper_condcopy->($org)) { |
258 | if($SkipFlop) { |
259 | fcopy($org,$new,$buf) or next if defined $buf; |
260 | fcopy($org,$new) or next if !defined $buf; |
261 | } |
262 | else { |
263 | fcopy($org,$new,$buf) or return if defined $buf; |
264 | fcopy($org,$new) or return if !defined $buf; |
265 | } |
266 | chmod scalar((stat($org))[2]), $new if $KeepMode; |
267 | $filen++; |
268 | } |
269 | } |
270 | } |
271 | 1; |
272 | }; |
273 | |
274 | $recurs->($_zero, $_one, $_[2]) or return; |
275 | return wantarray ? ($filen,$dirn,$level) : $filen; |
276 | } |
277 | |
278 | sub fmove { $move->(1, @_) } |
279 | |
280 | sub rmove { |
281 | if (-l $_[0] && $CopyLink) { |
282 | goto &fmove; |
283 | } |
284 | |
285 | goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*'; |
286 | goto &fmove; |
287 | } |
288 | |
289 | sub rmove_glob { |
290 | $glob->(\&rmove, @_); |
291 | } |
292 | |
293 | sub dirmove { $move->(0, @_) } |
294 | |
295 | sub pathmk { |
296 | my @parts = File::Spec->splitdir( shift() ); |
297 | my $nofatal = shift; |
298 | my $pth = $parts[0]; |
299 | my $zer = 0; |
300 | if(!$pth) { |
301 | $pth = File::Spec->catdir($parts[0],$parts[1]); |
302 | $zer = 1; |
303 | } |
304 | for($zer..$#parts) { |
305 | $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0'; |
306 | mkdir($pth,$DirPerms) or return if !-d $pth && !$nofatal; |
307 | mkdir($pth,$DirPerms) if !-d $pth && $nofatal; |
308 | $pth = File::Spec->catdir($pth, $parts[$_ + 1]) unless $_ == $#parts; |
309 | } |
310 | 1; |
311 | } |
312 | |
313 | sub pathempty { |
314 | my $pth = shift; |
315 | |
316 | return 2 if !-d $pth; |
317 | |
318 | my @names; |
319 | my $pth_dh; |
320 | if ( $] < 5.006 ) { |
321 | opendir(PTH_DH, $pth) or return; |
322 | @names = grep !/^\.+$/, readdir(PTH_DH); |
323 | } |
324 | else { |
325 | opendir($pth_dh, $pth) or return; |
326 | @names = grep !/^\.+$/, readdir($pth_dh); |
327 | } |
328 | |
329 | for my $name (@names) { |
330 | my ($name_ut) = $name =~ m{ (.*) }xms; |
331 | my $flpth = File::Spec->catdir($pth, $name_ut); |
332 | |
333 | if( -l $flpth ) { |
334 | unlink $flpth or return; |
335 | } |
336 | elsif(-d $flpth) { |
337 | pathrmdir($flpth) or return; |
338 | } |
339 | else { |
340 | unlink $flpth or return; |
341 | } |
342 | } |
343 | |
344 | if ( $] < 5.006 ) { |
345 | closedir PTH_DH; |
346 | } |
347 | else { |
348 | closedir $pth_dh; |
349 | } |
350 | |
351 | 1; |
352 | } |
353 | |
354 | sub pathrm { |
355 | my $path = shift; |
356 | return 2 if !-d $path; |
357 | my @pth = File::Spec->splitdir( $path ); |
358 | my $force = shift; |
359 | |
360 | while(@pth) { |
361 | my $cur = File::Spec->catdir(@pth); |
362 | last if !$cur; # necessary ??? |
363 | if(!shift()) { |
364 | pathempty($cur) or return if $force; |
365 | rmdir $cur or return; |
366 | } |
367 | else { |
368 | pathempty($cur) if $force; |
369 | rmdir $cur; |
370 | } |
371 | pop @pth; |
372 | } |
373 | 1; |
374 | } |
375 | |
376 | sub pathrmdir { |
377 | my $dir = shift; |
378 | if( -e $dir ) { |
379 | return if !-d $dir; |
380 | } |
381 | else { |
382 | return 2; |
383 | } |
384 | |
385 | pathempty($dir) or return; |
386 | |
387 | rmdir $dir or return; |
388 | } |
389 | |
390 | 1; |
391 | |
392 | __END__ |
393 | |
394 | #line 696 |