#!/usr/bin/perl -w
#
# $Revision: 1.8+1 $ $Date: 2010/01/05 17:45:59 $
# $Source: /home/vogelke/bin/RCS/rename,v $
# $UUID: 20e54287-6fc6-3ee3-84d7-21d209fe87a5 $
#
#<rename: safely renames multiple files using regular expressions
#
# From rwk@taunton.crl.dec.com Sat Mar  7 19:12:58 1992
# From: rwk@taunton.crl.dec.com (Bob Kerns)
# Subject: improved rename command.
# Date: Tue, 3 Mar 1992 05:38:21 GMT
#
# Here's my improved rename command I mentioned in my earlier post.
# Pretty much a complete rewrite of Larry Wall's rename hack,
# to be more careful not to clobber files or rename multiple files
# to the same thing.
#
# In particular, it lets you express the renaming in terms of patterns
# of wildcards instead of regexps.  (You can still specify a regexp
# if you want).  It will also copy, if you'd like.

use strict;

my $copy;
my $interactive;
my $op;
my @files;

my $DeleteOK    = 0;
my $showpattern = 0;
my $nodoit      = 0;
my $perlit      = 0;

sub usage {
    print STDERR
      "Usage: rename [-copy] [-i] [-delete] 'source-pattern' 'dest-pattern'
- or -
rename [-copy] [-i] [-s] [-n] [-delete] -e 'perl-expression' [filenames]

Flags:
-copy  copy files        -i       interactive      -e  perl expression
-s   show perl regexps   -delete  allow deletion   -n  No action (just print)

>>> Don't forget the quotes! <<<\n";
    exit(1);
}

sub mydie {
    print STDERR (@_, "\n");
    $nodoit || exit(1);
}

sub unbrace {
    my ($x) = (@_);
    $x =~ s/\\\{/\(/;
    $x =~ s/\\\,/\|/g;
    $x =~ s/\\\}/\)/;
    return $x;
}

sub expand_udir {
    my ($fname) = @_;
    my ($flag, $uname) = ($fname =~ m!^(\~([^/]*))\/!);
    if ($flag) {
        if ($uname) {
            my (
                $name,    $passwd, $uid, $gid, $quota,
                $comment, $gcos,   $dir, $shell
                ) = getpwnam($uname);
            $fname =~ s!^\~[^/]*\/!$dir\/!;
        }
        else {
            my (
                $name,    $passwd, $uid, $gid, $quota,
                $comment, $gcos,   $dir, $shell
                ) = getpwuid($<);
            $fname =~ s!^\~\/!$dir\/!;
        }
    }
    return ($fname);
}

# First, scan for options.

while (1) {
    ($op = shift) || &usage;
    ($op =~ /^-delete$/) && do {
        ($DeleteOK = 1);
        next;
    };
    ($op =~ /^-s$/) && do {
        ($showpattern = 1);
        next;
    };
    ($op =~ /^-n$/) && do {
        ($nodoit = 1);
        next;
    };
    ($op =~ /^-copy$/) && do {
        ($copy = 1);
        next;
    };

    ($op =~ /^-i$/) && do {
        ($interactive = 1);
        next;
    };
    ($op =~ /^-e$/) && do {
        ($perlit = 1);
        next;
    };

    # otherwise
    unshift(@ARGV, $op);
    last;
}

if ($perlit) {
    ($op = shift) || &usage;
    @files = @ARGV;
    if (!@files) {
        @files = <STDIN>;
        chop(@files);
    }
    $showpattern && print STDERR ("Using perl expression \'$op\'\n");

}
else {
    ($#ARGV != 1) && &usage;
    my ($spattern, $dpattern) = @ARGV;
    $spattern = &expand_udir($spattern);
    $dpattern = &expand_udir($dpattern);
    $spattern =~ m#^[^\*\?\{\}]*\/#;
    my $head = $&;

    if ($head) {
        my $newhead = <${head}>;
        if ($newhead ne $head) {
            print STDERR ("Replacing $head with $newhead.\n");
            $spattern =~ s*^$head*$newhead*;
        }
    }

    $spattern =~ s/\W/\\$&/g;                 # Quote everything needing it.
    $spattern =~ s/(^|[^\\])\\\*/$1(.*)/g;    # Turn wildcards into regexps
    $spattern =~ s/(^|[^\\])\\\?/$1(.)/g;
    $spattern =~ s/(^|[^\\])(\\\{\S+(\\\,\S+)+\\\})/ $1 . &unbrace($2) /eg;
    $dpattern =~ s/\W/\\$&/g;   # Quote everthing needing it in destination.

    for (my $i = 1 ; ($dpattern =~ s/\\(\*|\?)/\${$i}/) ; $i++) { 1; }
    my $foo = $op;
    @files = <${foo}>;
    $op    = "s/$spattern/$dpattern/";

    $showpattern && print STDERR ("Using perl expression \'$op\'\n");
}

my %seen = ();
foreach (@files) {
    my $was = $_;
    eval $op;
    die $@ if $@;

    if ($seen{$_}) {
        &mydie("$was and $seen{$_} would both rename to $_.");
    }
    $seen{$_} = $was;
    $_ = $was;    # Undo the change for the next pass.
}

$DeleteOK
  && print STDERR
  ">> Overwritting existing files is enabled (-d option).\n";

$nodoit
  && print STDERR ">> No changes will actually be made (-n option).\n";

FILE: for (@files) {
    my $was = $_;
    eval $op;
    die $@ if $@;

    if ($was eq $_) {
        print STDERR ("$was unchanged.\n");
    }
    else {
        my $overwrite = (($DeleteOK && (-e $_)) ? ' (overwrite)' : "");
        print STDOUT ("$was -> $_$overwrite\n");

        if ($interactive) {
          QUERY: while (1) {
                my $input;
                print STDERR ("OK? ");
                (($input = <STDIN>) =~ /^\s*y|yes/i) && last QUERY;
                ($input =~ /\s*n|no/i) && next FILE;
            }
        }
        if (!(-e $was)) {
            &mydie("Source file does not exist: $was");
        }
        if (!$DeleteOK && (-e $_)) {
            &mydie("Target file exists: $_");
        }
        elsif (!$nodoit) {
            $! = 0;
            if ($copy) {
                my $err;
                ($err = system("cp", "-p", $was, $_))
                  && ($! = ($err >> 8))
                  && &mydie("Could not copy: $!");
            }
            else {
                rename($was, $_) || &mydie("Error while renaming: $!");
            }
        }
    }
}

__END__

=head1 NAME

rename - renames multiple files

=head1 SYNOPSIS

B<rename> I<[options] "spattern" "dpattern">

B<rename> I<[options]> -e I<perlexpr> I<[files]>

=head1 DESCRIPTION

=over 10

=item I<Option>

I<Meaning>

=item -copy 

copy

=item -i 

interactive

=item -s 

show generated perl regular expression.

=item -n 

Do nothing, just indicate what would be done.

=item -delete

Allow deleting of files to occur.

=item -e 

Perl expression, instead of wildcard patterns.

=back

Renames the filenames, carefully.

Without the -e option, it renames files by wildcard pattern.  All the
files which match the pattern "spattern" are transformed into files which
match the pattern "dpattern".  "spattern" can have any combination of
'*', '?', and '{h,c}' wildcards.  You should supply a '*' in 'dpattern'
where you would like the corresponding matched component to appear in the
destination filename.  You may use more than one wildcard, but they must
appear in the destination in the same order.

If you wish to use wildcards in directory names, some restrictions apply
regarding directory links; see the section on B<BUGS>

With the -e option, the first argument is a Perl expression which is
expected to modify the $_ string in Perl for at least some of the filenames
specified.  If a given filename is not modified by the expression, it will
not be renamed.

When using the -e option, if no filenames are given on the command line,
filenames will be read via standard input.

The -delete option allows existing files to be deleted to allow the rename
or copy.

The -s option shows the perl expression which will be used to perform the
rename.  This is useful with the -n option; use -s -n to see what
expression would be used and its effects, then use the -n -e options
to try out your own expression and see its effects, and then when you're
happy, drop the -n option to actually perform it.

If the -copy option is specified, it copies using cp -p.

The -i (interactive) option asks you yes or no for each file.

For example, to rename all files matching *.bak to strip the extension,
you might say

 rename "*.bak/" "*"

or

 rename -e "s/\.bak$//" *.bak

To translate uppercase names to lower, you'd use

 rename -e "y/A-Z/a-z/" *

=head1 RESTRICTIONS

If you give a perl expression, it will be evaluated twice per file.
The first time is during a scan to see if any two filenames might conflict.
Be sure not to write an expression which cannot be safely executed twice.
(This would be hard to do on one comand line).

rename "foo*bar?baz" "foo?bar*baz" is a noop.  In the replacement
expression, ? and * are treated exactly the same.

=head1 ENVIRONMENT

No environment variables are used.

=head1 AUTHOR

Bob Kerns, Cambridge Research Labs, Digital Equipment Corporation.

A nearly-complete rewrite of something by Larry Wall, perlmeister.

strict, warnings, and POD documentation added by Karl Vogel.

=head1 SEE ALSO

L<mv(1)>
L<perl(1)>

=head1 DIAGNOSTICS

If you give an invalid Perl expression you'll get a syntax error.

=head1 BUGS

Symbolic directory links, and ~ are not handled well, because the shell
may expand these into filenames which no longer match the source pattern.
This will occur when wildcards in directory names and symbolic links in
the directory path are combined too intimately.  We carefully get around
the problem for directories appearing before the first wildcard.

Names of symbolic links, occurring to the right of wildcards, will confuse
it, resulting in it not renaming any files, as in the example below.
('test' is a symbolic link under ~rwk/vm/src to /udir/rwk/vm-test.).

 me% rename -s "~rwk/vm/src/*/foo.c" "../test/foo.c.old"
 Replacing ~rwk/vm/src/ with /udir/rwk/vm/src/.
 Using perl expression
 /udir/rwk/vm-test/foo.c unchanged.

=cut