Perl version of the rename script

prename.pl

#!/usr/bin/perl
use strict;
use warnings;

=head1 NAME

rename - renames multiple files

=head1 SYNOPSIS

F<rename>
B<-h>

F<rename>
S<B<[ -0 ]>>
S<B<[ -c | -C ]>>
S<B<[ -e code ]>>
S<B<[ -f ]>>
S<B<[ -i ]>>
S<B<[ -l | -L ]>>
S<B<[ -n ]>>
S<B<[ -s from to ]>>
S<B<[ -v ]>>
S<B<[ files ]>>

=head1 DESCRIPTION

C<rename> renames the filenames supplied according to the rules specif
+ied. If a given filename is not modified, it will not be renamed. If 
+no filenames are given on the command line, filenames will be read vi
+a standard input.

For example, to rename all files matching C<*.bak> to strip the extens
+ion, you might say

 rename 's/\.bak$//' *.bak

If are confident that none of the filenames has C<.bak> anywhere else 
+than at the end, you can also use the much easier typed

 rename -s .bak '' *.bak

You can always do multiple changes in one ago:

 rename -s .tgz .tar.gz -s .tbz2 .tar.bz2 *.tar.*

Note however that expressive options are order sensitive. The followin
+g would probably surprise you:

 rename -s foo bar -s bar baz *

Because changes are cumulative, this would end up substituting a F<foo
+> match in a filename with F<baz>, not F<bar>! To get the intended re
+sults in the above example, you could reverse the order of options:

 rename -s bar baz -s foo bar *

If you placed the C<-c> after the C<-e> in the above example, files wi
+th F<.zip> and F<.ZIP> extensions would be (attempted to be) moved to
+ different directories.

To translate uppercase names to lower, you'd use

 rename -c *

If you have files with control characters and blanks in their names, C
+<-z> will clean them up.

 rename -z *

You can combine all of these to suit your needs. F.ex files from Windo
+ws systems often have blanks and (sometimes nothing but) capital lett
+ers. Let's say you have a bunch of such files to clean up, and you al
+so want to move them to subdirectories based on extension. The follow
+ing command should help, provided all directories already exist:

 rename -cz -e '$_ = "$1/$_" if /(\..*)\z/' *

Again you need to pay attention to order sensitivity for expressive op
+tions. If you placed the C<-c> after the C<-e> in the above example, 
+files with F<.zip> and F<.ZIP> extensions would be (attempted to be) 
+moved to different directories because the directory name prefix woul
+d be added before the filenames were normalized.

=head1 ARGUMENTS

=over 4

=item B<-h>, B<--help>

Browse the manpage.

=back

=head1 OPTIONS

=over 4

=item B<-0>, B<--null>

When reading file names from C<STDIN>, split on null bytes instead of 
+newlines. This is useful in combination with GNU find's C<-print0> op
+tion, GNU grep's C<-Z> option, and GNU sort's C<-z> option, to name j
+ust a few. B<Only valid if no filenames have been given on the comman
+dline.>

=item B<-c>, B<--lower-case>

Converts file names to all lower case.

=item B<-C>, B<--upper-case>

Converts file names to all upper case.

=item B<-e>, B<--expr>

The C<code> argument to this option should be a Perl expression that a
+ssumes the filename in the C<$_> variable and modifies it for the fil
+enames to be renamed. When no other C<-c>, C<-C>, C<-e>, C<-s>, or C<
+-z> options are given, you can omit the C<-e> from infront of the cod
+e.

=item B<-f>, B<--force>

Rename even when a file with the destination name already exists.

=item B<-i>, B<--interactive>

Ask the user to confirm every action before it is taken.

=item B<-l>, B<--symlink>

Create symlinks from the new names to the existing ones, instead of re
+naming the files. B<Cannot be used in conjunction with C<-L>.>

=item B<-L>, B<--hardlink>

Create hard links from the new names to the existing ones, instead of 
+renaming the files. B<Cannot be used in conjunction with C<-l>.>

=item B<-n>, B<--dry-run>, B<--just-print>

Show how the files would be renamed, but don't actually do anything.

=item B<-s>, B<--subst>, B<--simple>

Perform a simple textual substitution of C<from> to C<to>. The C<from>
+ and C<to> parameters must immediately follow the argument.

This is equivalent to supplying a C<perlexpr> of C<s/\Qfrom/to/>.

=item B<-v>, B<--verbose>

Print additional information about the operations (not) executed.

=item B<-z>, B<--sanitize>

Replaces consecutive blanks, shell meta characters, and control charac
+ters in filenames with underscores.

=back

=head1 SEE ALSO

mv(1), perl(1), find(1), grep(1), sort(1)

=head1 AUTHORS

Aristotle Pagaltzis

Original code from Larry Wall and Robin Barker.

=head1 BUGS

None currently known.

=cut

use Pod::Usage;
use Getopt::Long;

sub DEBUG { print "@_\n" if $::LEVEL >= 2 }
sub INFO  { print "@_\n" if $::LEVEL >= 1 }
sub ERROR { print "@_\n" }

my @perlexpr;

Getopt::Long::Configure(qw(bundling no_ignore_case));
GetOptions(
    'h|help'               => sub { pod2usage( -verbose => 2 ) },
    '0|null'               => \my $opt_null,
    'c|lower-case'         => sub { push @perlexpr, 's/([[:upper:]]+)/\L$1/g' },
    'C|upper-case'         => sub { push @perlexpr, 's/([[:lower:]]+)/\U$1/g' },
    'e|expr=s'             => \@perlexpr,
    'f|force'              => \my $opt_force,
    'i|interactive'        => \my $opt_interactive,
    'l|symlink'            => \my $opt_symlink,
    'L|hardlink'           => \my $opt_hardlink,
    'n|just-print|dry-run' => \my $opt_dryrun,
    's|subst|simple'       => sub {
        pod2usage( -verbose => 1 ) if @ARGV < 2;
        my @param = map(quotemeta, splice @ARGV, 0, 2);
        # NB: ${\"..."} is necessary because unknown backslash escapes are not
        # treated the same in pattern- vs doublequote-quoting context, and we need
        # the latter to do the right thing with user input like 'foo{bar}baz'
        push @perlexpr, sprintf 's/\Q${\"%s"}\E/%s/', @param;
    },
    'v|verbose+'           => \my $opt_verbose,
    'z|sanitize'           => sub { push @perlexpr, 's/[!"$&()=?`*\';<>|_[:cntrl:][:blank:]]+/_/g' },
) or pod2usage( -verbose => 1 );

pod2usage( -verbose => 1 ) if $opt_hardlink and $opt_symlink;

if(not @perlexpr) {
    if(@ARGV) { push @perlexpr, shift }
    else { pod2usage( -verbose => 1 ) }
}

pod2usage( -verbose => 1 ) if $opt_null and @ARGV;

$::LEVEL = ($opt_verbose || 0) + ($opt_dryrun || 0);

my $code = do {
    my $cat = "sub { ".join('; ', @perlexpr)." }";
    DEBUG("Using expression: $cat");
    my $evaled = eval $cat;
    die $@ if $@;
    die "Could not evaluate to code ref\n" unless 'CODE' eq ref $evaled;
    $evaled;
};

if (!@ARGV) {
    INFO("Reading filenames from STDIN");
    @ARGV = do {
        if($opt_null) {
            INFO("Splitting on null bytes");
            local $/ = "\0";
        }
        <STDIN>;
    };
    chomp @ARGV;
}

my ($verb, $verbed, $action) =
    $opt_hardlink ? ( qw(link linked), sub { link shift, shift } ) :
    $opt_symlink  ? ( qw(symlink symlinked), sub { symlink shift, shift } ) :
    do { qw(rename renamed), sub { rename shift, shift } };

for (@ARGV) {
    my $oldname = $_;

    $code->();

    if($oldname eq $_) {
        DEBUG("'$oldname' unchanged");
        next;
    }

    ERROR("'$oldname' not $verbed: '$_' already exists"), next
        if not $opt_force and -e;

    if($opt_interactive and not $opt_dryrun) {
        print "\u$verb '$oldname' to '$_' (y/n)? ";
        if(<STDIN> !~ /^y/i) {
            DEBUG("Skipping '$oldname'.");
            next;
        }
    }

    if ($opt_dryrun or $action->($oldname, $_)) {
        INFO("'$oldname' $verbed to '$_'");
    }
    else {
        ERROR("Can't $verb '$oldname' to '$_': $!");
    }
}

INFO('Dry run, no changes were made.') if $opt_dryrun;