1package Vimana::Recursive; 2 3use strict; 4BEGIN { 5 # Keep older versions of Perl from trying to use lexical warnings 6 $INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006; 7} 8use warnings; 9 10use Carp; 11use File::Copy; 12use File::Spec; #not really needed because File::Copy already gets it, but for good measure :) 13 14use vars qw( 15 @ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink 16 $PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir 17 $CondCopy $BdTrgWrn $SkipFlop $DirPerms 18); 19 20require Exporter; 21@ISA = qw(Exporter); 22@EXPORT_OK = qw(fcopy rcopy dircopy dircopy_files fmove rmove dirmove pathmk pathrm pathempty pathrmdir); 23$VERSION = '0.38'; 24 25$MaxDepth = 0; 26$KeepMode = 1; 27$CPRFComp = 0; 28$CopyLink = eval { local $SIG{'__DIE__'};symlink '',''; 1 } || 0; 29$PFSCheck = 1; 30$RemvBase = 0; 31$NoFtlPth = 0; 32$ForcePth = 0; 33$CopyLoop = 0; 34$RMTrgFil = 0; 35$RMTrgDir = 0; 36$CondCopy = {}; 37$BdTrgWrn = 0; 38$SkipFlop = 0; 39$DirPerms = 0777; 40 41my $samecheck = sub { 42 return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders... 43 return if @_ != 2 || !defined $_[0] || !defined $_[1]; 44 return if $_[0] eq $_[1]; 45 46 my $one = ''; 47 if($PFSCheck) { 48 $one = join( '-', ( stat $_[0] )[0,1] ) || ''; 49 my $two = join( '-', ( stat $_[1] )[0,1] ) || ''; 50 if ( $one eq $two && $one ) { 51 carp "$_[0] and $_[1] are identical"; 52 return; 53 } 54 } 55 56 if(-d $_[0] && !$CopyLoop) { 57 $one = join( '-', ( stat $_[0] )[0,1] ) if !$one; 58 my $abs = File::Spec->rel2abs($_[1]); 59 my @pth = File::Spec->splitdir( $abs ); 60 while(@pth) { 61 my $cur = File::Spec->catdir(@pth); 62 last if !$cur; # probably not necessary, but nice to have just in case :) 63 my $two = join( '-', ( stat $cur )[0,1] ) || ''; 64 if ( $one eq $two && $one ) { 65 # $! = 62; # Too many levels of symbolic links 66 carp "Caught Deep Recursion Condition: $_[0] contains $_[1]"; 67 return; 68 } 69 70 pop @pth; 71 } 72 } 73 74 return 1; 75}; 76 77my $glob = sub { 78 my ($do, $src_glob, @args) = @_; 79 80 local $CPRFComp = 1; 81 82 my @rt; 83 for my $path ( glob($src_glob) ) { 84 my @call = [$do->($path, @args)] or return; 85 push @rt, \@call; 86 } 87 88 return @rt; 89}; 90 91my $move = sub { 92 my $fl = shift; 93 my @x; 94 if($fl) { 95 @x = fcopy(@_) or return; 96 } else { 97 @x = dircopy(@_) or return; 98 } 99 if(@x) { 100 if($fl) { 101 unlink $_[0] or return; 102 } else { 103 pathrmdir($_[0]) or return; 104 } 105 if($RemvBase) { 106 my ($volm, $path) = File::Spec->splitpath($_[0]); 107 pathrm(File::Spec->catpath($volm,$path,''), $ForcePth, $NoFtlPth) or return; 108 } 109 } 110 return wantarray ? @x : $x[0]; 111}; 112 113my $ok_todo_asper_condcopy = sub { 114 my $org = shift; 115 my $copy = 1; 116 if(exists $CondCopy->{$org}) { 117 if($CondCopy->{$org}{'md5'}) { 118 119 } 120 if($copy) { 121 122 } 123 } 124 return $copy; 125}; 126 127sub fcopy { 128 $samecheck->(@_) or return; 129 if($RMTrgFil && (-d $_[1] || -e $_[1]) ) { 130 my $trg = $_[1]; 131 if( -d $trg ) { 132 my @trgx = File::Spec->splitpath( $_[0] ); 133 $trg = File::Spec->catfile( $_[1], $trgx[ $#trgx ] ); 134 } 135 $samecheck->($_[0], $trg) or return; 136 if(-e $trg) { 137 if($RMTrgFil == 1) { 138 unlink $trg or carp "\$RMTrgFil failed: $!"; 139 } else { 140 unlink $trg or return; 141 } 142 } 143 } 144 my ($volm, $path) = File::Spec->splitpath($_[1]); 145 if($path && !-d $path) { 146 pathmk(File::Spec->catpath($volm,$path,''), $NoFtlPth); 147 } 148 if( -l $_[0] && $CopyLink ) { 149 carp "Copying a symlink ($_[0]) whose target does not exist" 150 if !-e readlink($_[0]) && $BdTrgWrn; 151 symlink readlink(shift()), shift() or return; 152 } else { 153 copy(@_) or return; 154 155 my @base_file = File::Spec->splitpath($_[0]); 156 my $mode_trg = -d $_[1] ? File::Spec->catfile($_[1], $base_file[ $#base_file ]) : $_[1]; 157 158 chmod scalar((stat($_[0]))[2]), $mode_trg if $KeepMode; 159 } 160 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 161} 162 163sub rcopy { 164 if (-l $_[0] && $CopyLink) { 165 goto &fcopy; 166 } 167 168 goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*'; 169 goto &fcopy; 170} 171 172sub rcopy_glob { 173 $glob->(\&rcopy, @_); 174} 175 176 177 178sub dircopy_files { 179 if($RMTrgDir && -d $_[1]) { 180 if($RMTrgDir == 1) { 181 pathrmdir($_[1]) or carp "\$RMTrgDir failed: $!"; 182 } else { 183 pathrmdir($_[1]) or return; 184 } 185 } 186 my $globstar = 0; 187 my $_zero = $_[0]; 188 my $_one = $_[1]; 189 if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*') { 190 $globstar = 1; 191 $_zero = substr( $_zero, 0, ( length( $_zero ) - 1 ) ); 192 } 193 194 $samecheck->( $_zero, $_[1] ) or return; 195 if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) { 196 $! = 20; 197 return; 198 } 199 200 if(!-d $_[1]) { 201 pathmk($_[1], $NoFtlPth) or return; 202 } else { 203 if($CPRFComp && !$globstar) { 204 my @parts = File::Spec->splitdir($_zero); 205 while($parts[ $#parts ] eq '') { pop @parts; } 206 $_one = File::Spec->catdir($_[1], $parts[$#parts]); 207 } 208 } 209 my $baseend = $_one; 210 my $level = 0; 211 my $filen = 0; 212 my $dirn = 0; 213 214 my @copied = (); 215 my $recurs; #must be my()ed before sub {} since it calls itself 216 217 $recurs = sub { 218 my ($str,$end,$buf) = @_; 219 $filen++ if $end eq $baseend; 220 $dirn++ if $end eq $baseend; 221 222 $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0'; 223 mkdir($end,$DirPerms) or return if !-d $end; 224 chmod scalar((stat($str))[2]), $end if $KeepMode; 225 if($MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth) { 226 return ($filen,$dirn,$level) if wantarray; 227 return $filen; 228 } 229 $level++; 230 231 232 my @files; 233 if ( $] < 5.006 ) { 234 opendir(STR_DH, $str) or return; 235 @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH)); 236 closedir STR_DH; 237 } 238 else { 239 opendir(my $str_dh, $str) or return; 240 @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh)); 241 closedir $str_dh; 242 } 243 244 for my $file (@files) { 245 my ($file_ut) = $file =~ m{ (.*) }xms; 246 my $org = File::Spec->catfile($str, $file_ut); 247 my $new = File::Spec->catfile($end, $file_ut); 248 if( -l $org && $CopyLink ) { 249 push @copied,$new; 250 carp "Copying a symlink ($org) whose target does not exist" 251 if !-e readlink($org) && $BdTrgWrn; 252 symlink readlink($org), $new or return; 253 } 254 elsif(-d $org) { 255 $recurs->($org,$new,$buf) if defined $buf; 256 $recurs->($org,$new) if !defined $buf; 257 $filen++; 258 $dirn++; 259 } 260 else { 261 if($ok_todo_asper_condcopy->($org)) { 262 push @copied,$new; 263 if($SkipFlop) { 264 fcopy($org,$new,$buf) or next if defined $buf; 265 fcopy($org,$new) or next if !defined $buf; 266 } 267 else { 268 fcopy($org,$new,$buf) or return if defined $buf; 269 fcopy($org,$new) or return if !defined $buf; 270 } 271 chmod scalar((stat($org))[2]), $new if $KeepMode; 272 $filen++; 273 } 274 } 275 } 276 1; 277 }; 278 279 $recurs->($_zero, $_one, $_[2]) or return; 280 return @copied; 281 # return wantarray ? ($filen,$dirn,$level,\@copied) : \@copied; 282} 283 284 285 286 287sub dircopy { 288 if($RMTrgDir && -d $_[1]) { 289 if($RMTrgDir == 1) { 290 pathrmdir($_[1]) or carp "\$RMTrgDir failed: $!"; 291 } else { 292 pathrmdir($_[1]) or return; 293 } 294 } 295 my $globstar = 0; 296 my $_zero = $_[0]; 297 my $_one = $_[1]; 298 if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*') { 299 $globstar = 1; 300 $_zero = substr( $_zero, 0, ( length( $_zero ) - 1 ) ); 301 } 302 303 $samecheck->( $_zero, $_[1] ) or return; 304 if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) { 305 $! = 20; 306 return; 307 } 308 309 if(!-d $_[1]) { 310 pathmk($_[1], $NoFtlPth) or return; 311 } else { 312 if($CPRFComp && !$globstar) { 313 my @parts = File::Spec->splitdir($_zero); 314 while($parts[ $#parts ] eq '') { pop @parts; } 315 $_one = File::Spec->catdir($_[1], $parts[$#parts]); 316 } 317 } 318 my $baseend = $_one; 319 my $level = 0; 320 my $filen = 0; 321 my $dirn = 0; 322 my @files = (); 323 324 my $recurs; #must be my()ed before sub {} since it calls itself 325 $recurs = sub { 326 my ($str,$end,$buf) = @_; 327 $filen++ if $end eq $baseend; 328 $dirn++ if $end eq $baseend; 329 330 $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0'; 331 mkdir($end,$DirPerms) or return if !-d $end; 332 chmod scalar((stat($str))[2]), $end if $KeepMode; 333 if($MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth) { 334 return ($filen,$dirn,$level) if wantarray; 335 return $filen; 336 } 337 $level++; 338 339 340 my @files; 341 if ( $] < 5.006 ) { 342 opendir(STR_DH, $str) or return; 343 @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH)); 344 closedir STR_DH; 345 } 346 else { 347 opendir(my $str_dh, $str) or return; 348 @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh)); 349 closedir $str_dh; 350 } 351 352 for my $file (@files) { 353 my ($file_ut) = $file =~ m{ (.*) }xms; 354 my $org = File::Spec->catfile($str, $file_ut); 355 my $new = File::Spec->catfile($end, $file_ut); 356 if( -l $org && $CopyLink ) { 357 carp "Copying a symlink ($org) whose target does not exist" 358 if !-e readlink($org) && $BdTrgWrn; 359 symlink readlink($org), $new or return; 360 } 361 elsif(-d $org) { 362 $recurs->($org,$new,$buf) if defined $buf; 363 $recurs->($org,$new) if !defined $buf; 364 $filen++; 365 $dirn++; 366 } 367 else { 368 if($ok_todo_asper_condcopy->($org)) { 369 if($SkipFlop) { 370 fcopy($org,$new,$buf) or next if defined $buf; 371 fcopy($org,$new) or next if !defined $buf; 372 } 373 else { 374 fcopy($org,$new,$buf) or return if defined $buf; 375 fcopy($org,$new) or return if !defined $buf; 376 } 377 chmod scalar((stat($org))[2]), $new if $KeepMode; 378 $filen++; 379 } 380 } 381 } 382 1; 383 }; 384 385 $recurs->($_zero, $_one, $_[2]) or return; 386 return wantarray ? ($filen,$dirn,$level) : $filen; 387} 388 389sub fmove { $move->(1, @_) } 390 391sub rmove { 392 if (-l $_[0] && $CopyLink) { 393 goto &fmove; 394 } 395 396 goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*'; 397 goto &fmove; 398} 399 400sub rmove_glob { 401 $glob->(\&rmove, @_); 402} 403 404sub dirmove { $move->(0, @_) } 405 406sub pathmk { 407 my @parts = File::Spec->splitdir( shift() ); 408 my $nofatal = shift; 409 my $pth = $parts[0]; 410 my $zer = 0; 411 if(!$pth) { 412 $pth = File::Spec->catdir($parts[0],$parts[1]); 413 $zer = 1; 414 } 415 for($zer..$#parts) { 416 $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0'; 417 mkdir($pth,$DirPerms) or return if !-d $pth && !$nofatal; 418 mkdir($pth,$DirPerms) if !-d $pth && $nofatal; 419 $pth = File::Spec->catdir($pth, $parts[$_ + 1]) unless $_ == $#parts; 420 } 421 1; 422} 423 424sub pathempty { 425 my $pth = shift; 426 427 return 2 if !-d $pth; 428 429 my @names; 430 my $pth_dh; 431 if ( $] < 5.006 ) { 432 opendir(PTH_DH, $pth) or return; 433 @names = grep !/^\.+$/, readdir(PTH_DH); 434 } 435 else { 436 opendir($pth_dh, $pth) or return; 437 @names = grep !/^\.+$/, readdir($pth_dh); 438 } 439 440 for my $name (@names) { 441 my ($name_ut) = $name =~ m{ (.*) }xms; 442 my $flpth = File::Spec->catdir($pth, $name_ut); 443 444 if( -l $flpth ) { 445 unlink $flpth or return; 446 } 447 elsif(-d $flpth) { 448 pathrmdir($flpth) or return; 449 } 450 else { 451 unlink $flpth or return; 452 } 453 } 454 455 if ( $] < 5.006 ) { 456 closedir PTH_DH; 457 } 458 else { 459 closedir $pth_dh; 460 } 461 462 1; 463} 464 465sub pathrm { 466 my $path = shift; 467 return 2 if !-d $path; 468 my @pth = File::Spec->splitdir( $path ); 469 my $force = shift; 470 471 while(@pth) { 472 my $cur = File::Spec->catdir(@pth); 473 last if !$cur; # necessary ??? 474 if(!shift()) { 475 pathempty($cur) or return if $force; 476 rmdir $cur or return; 477 } 478 else { 479 pathempty($cur) if $force; 480 rmdir $cur; 481 } 482 pop @pth; 483 } 484 1; 485} 486 487sub pathrmdir { 488 my $dir = shift; 489 if( -e $dir ) { 490 return if !-d $dir; 491 } 492 else { 493 return 2; 494 } 495 496 pathempty($dir) or return; 497 498 rmdir $dir or return; 499} 500 5011; 502 503__END__ 504 505=head1 NAME 506 507Vimana::Recursive - Perl extension for recursively copying files and directories 508 509=head1 SYNOPSIS 510 511 use Vimana::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove); 512 513 fcopy($orig,$new[,$buf]) or die $!; 514 rcopy($orig,$new[,$buf]) or die $!; 515 dircopy($orig,$new[,$buf]) or die $!; 516 517 fmove($orig,$new[,$buf]) or die $!; 518 rmove($orig,$new[,$buf]) or die $!; 519 dirmove($orig,$new[,$buf]) or die $!; 520 521 rcopy_glob("orig/stuff-*", $trg [, $buf]) or die $!; 522 rmove_glob("orig/stuff-*", $trg [,$buf]) or die $!; 523 524=head1 DESCRIPTION 525 526This module copies and moves directories recursively (or single files, well... singley) to an optional depth and attempts to preserve each file or directory's mode. 527 528=head1 EXPORT 529 530None by default. But you can export all the functions as in the example above and the path* functions if you wish. 531 532=head2 fcopy() 533 534This function uses File::Copy's copy() function to copy a file but not a directory. Any directories are recursively created if need be. 535One difference to File::Copy::copy() is that fcopy attempts to preserve the mode (see Preserving Mode below) 536The optional $buf in the synopsis if the same as File::Copy::copy()'s 3rd argument 537returns the same as File::Copy::copy() in scalar context and 1,0,0 in list context to accomidate rcopy()'s list context on regular files. (See below for more info) 538 539=head2 dircopy() 540 541This function recursively traverses the $orig directory's structure and recursively copies it to the $new directory. 542$new is created if necessary (multiple non existant directories is ok (IE foo/bar/baz). The script logically and portably creates all of them if necessary). 543It attempts to preserve the mode (see Preserving Mode below) and 544by default it copies all the way down into the directory, (see Managing Depth) below. 545If a directory is not specified it croaks just like fcopy croaks if its not a file that is specified. 546 547returns true or false, for true in scalar context it returns the number of files and directories copied, 548In list context it returns the number of files and directories, number of directories only, depth level traversed. 549 550 my $num_of_files_and_dirs = dircopy($orig,$new); 551 my($num_of_files_and_dirs,$num_of_dirs,$depth_traversed) = dircopy($orig,$new); 552 553Normally it stops and return's if a copy fails, to continue on regardless set $Vimana::Recursive::SkipFlop to true. 554 555 local $Vimana::Recursive::SkipFlop = 1; 556 557That way it will copy everythgingit can ina directory and won't stop because of permissions, etc... 558 559=head2 rcopy() 560 561This function will allow you to specify a file *or* directory. It calls fcopy() if its a file and dircopy() if its a directory. 562If you call rcopy() (or fcopy() for that matter) on a file in list context, the values will be 1,0,0 since no directories and no depth are used. 563This is important becasue if its a directory in list context and there is only the initial directory the return value is 1,1,1. 564 565=head2 rcopy_glob() 566 567This function lets you specify a pattern suitable for perl's glob() as the first argument. Subsequently each path returned by perl's glob() gets rcopy()ied. 568 569It returns and array whose items are array refs that contain the return value of each rcopy() call. 570 571It forces behavior as if $Vimana::Recursive::CPRFComp is true. 572 573=head2 fmove() 574 575Copies the file then removes the original. You can manage the path the original file is in according to $RemvBase. 576 577=head2 dirmove() 578 579Uses dircopy() to copy the directory then removes the original. You can manage the path the original directory is in according to $RemvBase. 580 581=head2 rmove() 582 583Like rcopy() but calls fmove() or dirmove() instead. 584 585=head2 rmove_glob() 586 587Like rcopy_glob() but calls rmove() instead of rcopy() 588 589=head3 $RemvBase 590 591Default is false. When set to true the *move() functions will not only attempt to remove the original file or directory but will remove the given path it is in. 592 593So if you: 594 595 rmove('foo/bar/baz', '/etc/'); 596 # "baz" is removed from foo/bar after it is successfully copied to /etc/ 597 598 local $Vimana::Recursive::Remvbase = 1; 599 rmove('foo/bar/baz','/etc/'); 600 # if baz is successfully copied to /etc/ : 601 # first "baz" is removed from foo/bar 602 # then "foo/bar is removed via pathrm() 603 604=head4 $ForcePth 605 606Default is false. When set to true it calls pathempty() before any directories are removed to empty the directory so it can be rmdir()'ed when $RemvBase is in effect. 607 608=head2 Creating and Removing Paths 609 610=head3 $NoFtlPth 611 612Default is false. If set to true rmdir(), mkdir(), and pathempty() calls in pathrm() and pathmk() do not return() on failure. 613 614If its set to true they just silently go about their business regardless. This isn't a good idea but its there if you want it. 615 616=head3 $DirPerms 617 618Mode to pass to any mkdir() calls. Defaults to 0777 as per umask()'s POD. Explicitly having this allows older perls to be able to use FCR and might add a bit of flexibility for you. 619 620Any value you set it to should be suitable for oct() 621 622=head3 Path functions 623 624These functions exist soley because they were necessary for the move and copy functions to have the features they do and not because they are of themselves the purpose of this module. That being said, here is how they work so you can understand how the copy and move funtions work and use them by themselves if you wish. 625 626=head4 pathrm() 627 628Removes a given path recursively. It removes the *entire* path so be carefull!!! 629 630Returns 2 if the given path is not a directory. 631 632 Vimana::Recursive::pathrm('foo/bar/baz') or die $!; 633 # foo no longer exists 634 635Same as: 636 637 rmdir 'foo/bar/baz' or die $!; 638 rmdir 'foo/bar' or die $!; 639 rmdir 'foo' or die $!; 640 641An optional second argument makes it call pathempty() before any rmdir()'s when set to true. 642 643 Vimana::Recursive::pathrm('foo/bar/baz', 1) or die $!; 644 # foo no longer exists 645 646Same as:PFSCheck 647 648 Vimana::Recursive::pathempty('foo/bar/baz') or die $!; 649 rmdir 'foo/bar/baz' or die $!; 650 Vimana::Recursive::pathempty('foo/bar/') or die $!; 651 rmdir 'foo/bar' or die $!; 652 Vimana::Recursive::pathempty('foo/') or die $!; 653 rmdir 'foo' or die $!; 654 655An optional third argument acts like $Vimana::Recursive::NoFtlPth, again probably not a good idea. 656 657=head4 pathempty() 658 659Recursively removes the given directory's contents so it is empty. returns 2 if argument is not a directory, 1 on successfully emptying the directory. 660 661 Vimana::Recursive::pathempty($pth) or die $!; 662 # $pth is now an empty directory 663 664=head4 pathmk() 665 666Creates a given path recursively. Creates foo/bar/baz even if foo does not exist. 667 668 Vimana::Recursive::pathmk('foo/bar/baz') or die $!; 669 670An optional second argument if true acts just like $Vimana::Recursive::NoFtlPth, which means you'd never get your die() if something went wrong. Again, probably a *bad* idea. 671 672=head4 pathrmdir() 673 674Same as rmdir() but it calls pathempty() first to recursively empty it first since rmdir can not remove a directory with contents. 675Just removes the top directory the path given instead of the entire path like pathrm(). Return 2 if given argument does not exist (IE its already gone). Return false if it exists but is not a directory. 676 677=head2 Preserving Mode 678 679By default a quiet attempt is made to change the new file or directory to the mode of the old one. 680To turn this behavior off set 681 $Vimana::Recursive::KeepMode 682to false; 683 684=head2 Managing Depth 685 686You can set the maximum depth a directory structure is recursed by setting: 687 $Vimana::Recursive::MaxDepth 688to a whole number greater than 0. 689 690=head2 SymLinks 691 692If your system supports symlinks then symlinks will be copied as symlinks instead of as the target file. 693Perl's symlink() is used instead of File::Copy's copy() 694You can customize this behavior by setting $Vimana::Recursive::CopyLink to a true or false value. 695It is already set to true or false dending on your system's support of symlinks so you can check it with an if statement to see how it will behave: 696 697 if($Vimana::Recursive::CopyLink) { 698 print "Symlinks will be preserved\n"; 699 } else { 700 print "Symlinks will not be preserved because your system does not support it\n"; 701 } 702 703If symlinks are being copied you can set $Vimana::Recursive::BdTrgWrn to true to make it carp when it copies a link whose target does not exist. Its false by default. 704 705 local $Vimana::Recursive::BdTrgWrn = 1; 706 707=head2 Removing existing target file or directory before copying. 708 709This can be done by setting $Vimana::Recursive::RMTrgFil or $Vimana::Recursive::RMTrgDir for file or directory behavior respectively. 710 7110 = off (This is the default) 712 7131 = carp() $! if removal fails 714 7152 = return if removal fails 716 717 local $Vimana::Recursive::RMTrgFil = 1; 718 fcopy($orig, $target) or die $!; 719 # if it fails it does warn() and keeps going 720 721 local $Vimana::Recursive::RMTrgDir = 2; 722 dircopy($orig, $target) or die $!; 723 # if it fails it does your "or die" 724 725This should be unnecessary most of the time but its there if you need it :) 726 727=head2 Turning off stat() check 728 729By default the files or directories are checked to see if they are the same (IE linked, or two paths (absolute/relative or different relative paths) to the same file) by comparing the file's stat() info. 730It's a very efficient check that croaks if they are and shouldn't be turned off but if you must for some weird reason just set $Vimana::Recursive::PFSCheck to a false value. ("PFS" stands for "Physical File System") 731 732=head2 Emulating cp -rf dir1/ dir2/ 733 734By default dircopy($dir1,$dir2) will put $dir1's contents right into $dir2 whether $dir2 exists or not. 735 736You can make dircopy() emulate cp -rf by setting $Vimana::Recursive::CPRFComp to true. 737 738NOTE: This only emulates -f in the sense that it does not prompt. It does not remove the target file or directory if it exists. 739If you need to do that then use the variables $RMTrgFil and $RMTrgDir described in "Removing existing target file or directory before copying" above. 740 741That means that if $dir2 exists it puts the contents into $dir2/$dir1 instead of $dir2 just like cp -rf. 742If $dir2 does not exist then the contents go into $dir2 like normal (also like cp -rf) 743 744So assuming 'foo/file': 745 746 dircopy('foo', 'bar') or die $!; 747 # if bar does not exist the result is bar/file 748 # if bar does exist the result is bar/file 749 750 $Vimana::Recursive::CPRFComp = 1; 751 dircopy('foo', 'bar') or die $!; 752 # if bar does not exist the result is bar/file 753 # if bar does exist the result is bar/foo/file 754 755You can also specify a star for cp -rf glob type behavior: 756 757 dircopy('foo/*', 'bar') or die $!; 758 # if bar does not exist the result is bar/file 759 # if bar does exist the result is bar/file 760 761 $Vimana::Recursive::CPRFComp = 1; 762 dircopy('foo/*', 'bar') or die $!; 763 # if bar does not exist the result is bar/file 764 # if bar does exist the result is bar/file 765 766NOTE: The '*' is only like cp -rf foo/* and *DOES NOT EXPAND PARTIAL DIRECTORY NAMES LIKE YOUR SHELL DOES* (IE not like cp -rf fo* to copy foo/*) 767 768=head2 Allowing Copy Loops 769 770If you want to allow: 771 772 cp -rf . foo/ 773 774type behavior set $Vimana::Recursive::CopyLoop to true. 775 776This is false by default so that a check is done to see if the source directory will contain the target directory and croaks to avoid this problem. 777 778If you ever find a situation where $CopyLoop = 1 is desirable let me know (IE its a bad bad idea but is there if you want it) 779 780(Note: On Windows this was necessary since it uses stat() to detemine samedness and stat() is essencially useless for this on Windows. 781The test is now simply skipped on Windows but I'd rather have an actual reliable check if anyone in Microsoft land would care to share) 782 783=head1 SEE ALSO 784 785L<File::Copy> L<File::Spec> 786 787=head1 TO DO 788 789I am currently working on and reviewing some other modules to use in the new interface so we can lose the horrid globals as well as some other undesirable traits and also more easily make available some long standing requests. 790 791Tests will be easier to do with the new interface and hence the testing focus will shift to the new interface and aim to be comprehensive. 792 793The old interface will work, it just won't be brought in until it is used, so it will add no overhead for users of the new interface. 794 795I'll add this after the latest verision has been out for a while with no new features or issues found :) 796 797=head1 AUTHOR 798 799Daniel Muey, L<http://drmuey.com/cpan_contact.pl> 800 801=head1 COPYRIGHT AND LICENSE 802 803Copyright 2004 by Daniel Muey 804 805This library is free software; you can redistribute it and/or modify 806it under the same terms as Perl itself. 807 808=cut 809