I'm already bald so don't have the luxury of pulling hair over this.
I don't understand the error ouput or maybe I could get somewhere with
this. Pouring over perldoc File::Copy isn't helping either... I
think the error is before that but can't see what.
The end result of this script is supposed to be a directory named
./tmp with any copied files renamed into it.
The incoming files from ./dir1 ./dir2 are all files with numeric
names. The total of them is 117
If I leave out the copy part it prints just what you'd expect so
somehow when inserting the copy funtion things change.
It fails on the first copy:
hpdb cp'ing ./dir1/2765 => ./tmp/001
Failed to copy ./dir1/2765 => ./tmp/001: No such file or directory
at ./renum2.pl line 111
------- 8< snip --------
#!/usr/local/bin/perl -w
use File::Find;
use File::Copy;
my $myscript;
($myscript = $0) =~ s:^.*/::;
my ($pattern,$reg,@oldnames,$cnt,$tmpdir,@searchdir,$old,
$new,$ext,$endname,$ans,@SystemCmdArgs,$SrchByExt);
if(!$ARGV[0] || $ARGV[0] eq "help"){
usage();
exit;
}
## Our command line may contain a switch for various purposes so we
## run getopsts std here:
## ==== BEGIN Getopts section ====
## Declare vars inside qw()
use vars qw($opt_e);
use Getopt::Std;
my $optstr ="e";
getopts($optstr);
## Somewhat abnormal usage here.. we don't use `-e ARG' at
## my $optstr no (e:) Because we want the second ARG left alone
## Since it will be used as search string even if we don't use -e
if($opt_e){
$SrchByExt = "TRUE";
}
## ARGV contains our file search regex plus our tmpdir name and finally
## The diretories to search. If any of these are missing we bail
## slurp the find pattern
$pattern = shift;
## compile it into a perl regex
$reg = qr/$pattern/;
if(!$ARGV[0]){
usage();
exit;
}
## Slurp the name of a directory user wants created to put our
## renamed files in.
$tmpdir = shift;
if(!$ARGV[0]){
usage();
exit;
}
## And finally, whatever is left is our search directories
@searchdir = @ARGV;
## Null out ARGV (may not be necessary)
@ARGV = ();
## if we need to rm -rf $tmpdir we set args for system call here
@SystemCmdArgs = ("rm", "-rf", "$tmpdir");
## Create the temporary directory to hold our newly renamed files.
if(-d $tmpdir){
print " $tmpdir already exits do you want to delete it and all
its contents?\n";
print " \n$tmpdir contains:\n";
opendir(TMPDIR,"$tmpdir")or die "Can't open $tmpdir: $!";
print readdir(TMPDIR) . "\n";
print "[anything but a lower case \`y' at the prompt will abort]
=> ";
$ans = <STDIN>;
if($ans !~ /^y$/){
print "\n aborting ....\n\n";
exit;
}
system(@SystemCmdArgs) == 0
or die "system failed to @SystemCmdArgs: $!";
}
mkdir $tmpdir or die "Can't create $tmpdir $!";
$cnt = 0;
find(\&wanted, @searchdir);
sub wanted {
## Spaces in file names will break this script... bail out if
## we see any
if(/\s/){
usage();
print "\ No filenames with spaces allowed \n";
exit;
}
if($_ =~ /$reg/){
## Keep our counter synced since it is the newname
$new = sprintf q[%03d], ++$cnt;
## If we are handling files with extensions we need to change how
## we process them.
if($SrchByExt){
## process any extension
$endname = $_;
## Lop off the extension and save it
($ext = $endname) =~ s/(^.*)(\.[\w\d]+$)/$2/;
## add ext to our new numeric name
$new = $new . $ext;
}
$new = $tmpdir."/".$new;
$oldf = $File::Find::name;
print "hpdb cp\'ing $oldf => $new\n";
copy($oldf, $new)
or die "Failed to copy $oldf => $new: $!";
}
}
sub usage {
print<<EOM;
Purpose: Copy or move files from multiple directories to one new
tmp directory and rename them in consecutive numeric names.
(3 digit padded)
Usage: \`$myscript 'REGEX' tmpdir dir1 dir1 ...dirN'
Where REGEX is the file ext you want to work with.
\`tmpdir' is the name of directory you want to put renamed
files in.
Then a list of directories to scour for filenames with
that extension to be [copied/moved].
NOTE: Don't apply this script to files whos names have spaces!
No allowance has been made so it may destroy something
EOM
}
--
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
<http://learn.perl.org/> <http://learn.perl.org/first-response>
