@rem = '--*-Perl-*--
@echo off
if "%OS%" == "Windows_NT" goto WinNT
perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
:WinNT
perl -x -S %0 %*
if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
if %errorlevel% == 9009 echo You do not have Perl in your PATH.
if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
goto endofperl
@rem ';
#! /usr/bin/perl
#line 15

my $VERSION = 0.26;
my $debug = 1;

=head1 NAME

rxrename.pl - Interactively rename files using Perl regular expressions

=head1 SYNOPSIS

  rxrename.pl "D:\My Music\*.mp3"

or

  rxrename.pl ~/mp3/*.mp3

=head1 DESCRIPTION

Rename a group of files using regular expressions. The files to be renamed are 
given as argument to the script. The regular expressions are given 
interactively, and several may be given. They will be evaluated one after the 
other.

=cut

use File::Basename;

unless (@ARGV) {
	print "Give files to process as argument(s)!\n",
		"To view the full embedded POD documentation, you can type\n",
		"  perldoc $0\n";
	die;
}

@ARGV = map {glob} @ARGV;

print basename($0), " v. $VERSION will process these ", scalar(@ARGV), " files:\n",
	join("\n", @ARGV), "\n\n" if $debug;

print <<END_TEXT
Enter search/replace expression(s) that will be eval'ed in order.
End with CR.

Note that the s/// expression is done on the file name with suffix, but without the path!
END_TEXT
;

do {
	$_ = <STDIN>;
	chomp $_;
	if ( m!^s/.+/.*/!) {
		push @replaces, $_;
	}
	elsif ($_) {
		print "Bad regex syntax! try again. Example: s/something/something else/i\n";
		$_ = 0;
	}
} while $_;

foreach $FILE (@ARGV) {
	my ($name, $path) = fileparse($FILE);
	print "Path: '$path'\n",
		  "Name: '$name'\n",
		  #"Suff: '$suffix'\n"
		  if $debug > 2;

	my $newname = $name;

	my $rx;
	foreach $rx (@replaces) {
		print "eval will do '$rx' on $newname\n" if $debug > 5;
		eval $rx for $newname;
		if ($@) {
			print "Error: $@\n";
		}
	}

	if ($newname eq $name) {
		print "No change for '$name'\n";
		next;
	}

	else {
		# change name if necessary to not overwrite existing file
		#if (-f "$path$newname") {
		#	$cnt = 2;
	  	#	while (-f "$path$newname" . "-" . "$cnt") {
 		#		$cnt++;
   		#	}
		#	$newname .= "-".$cnt;
		#}
		$ren{$name} = $newname;
	}
}

print "Ready to rename these ", scalar(keys %ren), " files:\n";

foreach $f (sort keys %ren) {
	print "Rename '$f'\n",
		  "    -> '$ren{$f}'\n";
}

print "Do it? [Yes (this file only) / All / No]";
my $in = <STDIN>;

if ($in =~ /^[yYjJoO]/) {
	$all = 0;
}
elsif ($in =~ /^[aA]/) {
	$all = 1;
}
else {
	print "Operation cancelled. Nothing renamed.\n";
	exit;
}

foreach $f (sort keys %ren) {
	my $file_exists = 0;
	if (-e "$path$ren{$f}") {
		$file_exists = 1;
	}
	print "Rename '$f'\n",
		  "    -> '$ren{$f}'\n",
		  $file_exists ? "    ! would overwrite existing destination !\n" : "";

	if ($file_exists || !$all) {
		print "OK? [Y/A/n/q]";
		my $in = <STDIN>;
		if ($in =~ /^A/i) {
			$all = 1;
		}
		last if $in =~ /^q/i;
		next if $in =~ /^n/i;
	}
	if (rename "$path$f", "$path$ren{$f}") { print "OK\n" }
	else { print "ERROR $!\n" };
}

__END__

=head1 TO DO

  Fix "new file name exists" code, and look into case sensitivity of file system.
  Take debug level from command line
  Keep a history of regexes and allow reusing them
  Offer a menu of some common regexes (capitalisation, handling of spaces, ...)
  A good-looking practical Tk interface?

=head1 AUTHOR and COPYRIGHT

perl -e "print qq(mi.perl\x40alma.ch\n)"

=head1 LICENSE

Same as Perl itself.

=head1 SEE ALSO

perl(1) perldoc perlrequick perlretut.

=cut

__END__
:endofperl