#!/usr/bin/perl

use strict;
use warnings;
use File::Find;
use File::Spec;
use Getopt::Std;
use Cwd qw(abs_path getcwd);

our $VERSION = 0.27;

our $HOMEDIR;
if ($ENV{TESTING_HOME}) { $HOMEDIR = $ENV{TESTING_HOME} }
else {
    eval { require File::HomeDir; $HOMEDIR = File::HomeDir->my_home };
    if (!$HOMEDIR) { $HOMEDIR = $ENV{HOME} }
    die "FATAL: Can't determine home directory\n" unless $HOMEDIR;
}

my $scriptlets;

my %opts;
getopts('ce:D:dfhlorSs:Vvw:', \%opts);

if ($opts{V}) { print "perlmv version $VERSION\n"; exit 0 }
if ($opts{h}) { print <<'USAGE'; exit 0 }
Rename files using Perl code.

Usage:

 perlmv -h

 perlmv [options] <scriptlet> <file...>
 perlmv [options] -e <code> <file...>

 perlmv -e <code> -w <name>
 perlmv -l
 perlmv -s <name>
 perlmv -D <name>

Options:

 -c  Only test compile code, do not run it on the arguments
 -e <CODE> Specify code to rename file (\$_), e.g. 's/\.old\$/\.bak/'
 -d  Dry-run (implies -v)
 -f  Only process files, do not process directories
 -h  Show this help
 -o  Overwrite (by default, ".1", ".2", and so on will be appended to
     avoid overwriting existing files)
 -r  Recursive
 -S  Do not process symlinks
 -V  Print version and exit
 -v  Verbose

 -l  list all scriptlets
 -s <NAME> Show source code for scriptlet
 -w <NAME> Write code specified in -e as scriptlet
 -D <NAME> Delete scriptlet
USAGE

if ($opts{l}) {
    load_scriptlets();
    for (sort keys %$scriptlets) {
        if ($opts{v}) {
            print format_scriptlet_source($_), "\n";
        } else {
            print $_, "\n";
        }
    }
    exit 0;
}

if ($opts{s}) {
    print format_scriptlet_source($opts{s});
    exit 0;
}

if ($opts{w}) {
    write_scriptlet($opts{w}, $opts{e});
    exit 0;
}

if ($opts{D}) {
    delete_user_scriptlet($opts{D});
    exit 0;
}

my ($code, $name);
if ($opts{e}) {
    $code = $opts{e};
    $name = "-e";
} else {
    die "FATAL: Must specify -e or scriptlet name in first argument\n"
        unless @ARGV;
    $name = shift @ARGV;
    $code = load_scriptlet($name);
}

$opts{v} = 1 if $opts{d};

# test code first
run_code($code, $name, 1);
exit 0 if $opts{c};

die "FATAL: Please specify some files in arguments\n" unless @ARGV;

my @items = ();

# do our own globbing in windows, this is convenient
if ($^O =~ /win32/i) {
    for (@ARGV) {
        if (/[*?{}\[\]]/) { push @items, glob $_ } else { push @items, $_ }
    }
} else {
    push @items, @ARGV;
}

my %n = ();
process_items(@items);

# subroutines

sub format_scriptlet_source {
    my ($name) = @_;
    load_scriptlets();
    die "FATAL: Scriptlet `$name` not found\n"
        unless $scriptlets->{$name};
    "### Name: $name (from ", $scriptlets->{$name}{from}, ")\n" .
    $scriptlets->{$name}{code} .
    ($scriptlets->{$name}{code} =~ /\n\z/ ? "" : "\n");
}

sub load_scriptlet {
    my ($name) = @_;
    load_scriptlets();
    die "FATAL: Can't find scriptlet `$name`"
        unless $scriptlets->{$name};
    $scriptlets->{$name}{code};
}

sub load_scriptlets {
    if (!$scriptlets) {
        $scriptlets = find_scriptlets();
    }
}

sub find_scriptlets {
    my $res = {};

    eval { require App::perlmv::scriptlets::std };
    if (%App::perlmv::scriptlets::std::scriptlets) {
        $res->{$_} = { code=>$App::perlmv::scriptlets::std::scriptlets{$_},
                       from=>"App::perlmv::scriptlets::std.pm" }
            for keys %App::perlmv::scriptlets::std::scriptlets;
    }

    eval { require App::perlmv::scriptlets };
    if (%App::perlmv::scriptlets::scriptlets) {
        $res->{$_} = { code=>$App::perlmv::scriptlets::scriptlets{$_},
                       from=>"App::perlmv::scriptlets.pm" }
            for keys %App::perlmv::scriptlets::scriptlets;
    }

    if (-d "/usr/share/perlmv/scriptlets") {
        local $/;
        for (glob "/usr/share/perlmv/scriptlets/*") {
            my $name = $_; $name =~ s!.+/!!;
            open my($fh), $_;
            my $code = <$fh>;
            $res->{$name} = { code=>$code, from => $_ }
                if $code;
        }
    }

    if (-d "$HOMEDIR/.perlmv/scriptlets") {
        local $/;
        for (glob "$HOMEDIR/.perlmv/scriptlets/*") {
            my $name = $_; $name =~ s!.+/!!;
            open my($fh), $_;
            my $code = <$fh>;
            $res->{$name} = { code=>$code, from => $_ }
                if $code;
        }
    }

    $res;
}

sub valid_scriptlet_name {
    my ($name) = @_;
    $name =~ m/^[A-Za-z_][0-9A-Za-z_-]*$/;
}

sub write_scriptlet {
    my ($name, $code) = @_;
    die "FATAL: Invalid scriptlet name `$name`\n"
        unless valid_scriptlet_name($name);
    die "FATAL: Code not specified\n" unless $code;
    unless (-d "$HOMEDIR/.perlmv") {
        mkdir "$HOMEDIR/.perlmv" or
            die "FATAL: Can't mkdir `$HOMEDIR/.perlmv`: $!\n";
    }
    unless (-d "$HOMEDIR/.perlmv/scriptlets") {
        mkdir "$HOMEDIR/.perlmv/scriptlets" or
            die "FATAL: Can't mkdir `$HOMEDIR/.perlmv/scriptlets`: $!\n";
    }
    # XXX warn existing file, unless -o
    open my($fh), ">$HOMEDIR/.perlmv/scriptlets/$name";
    print $fh $code;
    close $fh or
        die "FATAL: Can't write to $HOMEDIR/.perlmv/scriptlets/$name: $!\n";
}

sub delete_user_scriptlet {
    my ($name) = @_;
    unlink "$HOMEDIR/.perlmv/scriptlets/$name";
}

sub run_code {
    my ($code, $name, $is_testing) = @_;
    no strict;
    no warnings;
    $_ = "-TEST" if $is_testing;
    $App::perlmv::code::TESTING = ($is_testing ? 1 : undef);
    eval "package App::perlmv::code; $code";
    die "FATAL: Code (name=$name, code=$code, \$_=$_) died: $@\n" if $@;
}

sub process_items {
    my @items = @_;
    for my $item (@items) {
        next if $opts{S} && (-l $item);
        if (-d _) {
            next if $opts{f};
            if ($opts{r}) {
                my $cwd = getcwd();
                if (chdir $item) {
                    print "INFO: chdir `$cwd/$item` ...\n" if $opts{v};
                    local *D;
                    opendir D, ".";
                    my @d = grep { $_ ne '.' && $_ ne '..' } readdir D;
                    closedir D;
                    process_items(@d);
                    chdir $cwd or die "FATAL: Can't go back to `$cwd`: $!\n";
                } else {
                    warn "WARN: Can't chdir to `$cwd/$item`, skipped\n";
                }
            }
        }
        process_item($item);
    }
}

sub process_item {
    my ($filename) = @_;
    local $_ = $filename;

    my $old = $filename;
    run_code($code, $name);
    my $new = $_;

    return if abs_path($old) eq abs_path($new);

    my $cwd = getcwd();
    unless ($opts{o}) {
        my $i = 1;
        while (1) {
            if ((-e $new) || exists $n{"$cwd/$new"}) {
                $new = "$_.$i";
                $i++;
            } else {
                last;
            }
        }
        $n{"$cwd/$new"}++;
    }
    print "DRYRUN: " if $opts{d};
    print "`$old` -> `$new`\n" if $opts{v};
    unless ($opts{d}) {
        my $res = rename $old, $new;
        warn "ERROR: failed renaming $old -> $new\n" unless $res;
    }
}

1;
__END__

=head1 NAME

perlmv - Rename files using Perl code

=head1 VERSION

0.27

=head1 SYNOPSIS

Usage:

 perlmv -h

 perlmv [options] <scriptlet> <file...>
 perlmv [options] -e <code> <file...>

 perlmv -e <code> -w <name>
 perlmv -l
 perlmv -s <name>
 perlmv -d <name>

=head2 Usage examples

 $ ls
 A.txt B1 c2.txt D3.pl D4.pl

Rename files with prewritten scriptlet (B<ls>) and show (B<-v>) each
file as it is being renamed.

 $ perlmv -v lc *.txt
 `A.txt` -> `a.txt`

Specify script in command line (B<-e>) but do not actually rename
files (B<-d>, dry-run mode):

 $ perlmv -de 's/\d+//g' *
 `B1` -> `B`
 `c2.txt` -> `c.txt`
 `D3.pl` -> `D.pl`
 `D4.pl` -> `D.pl.1`

Really rename the files this time:

 $ perlmv -e 's/\d+//g' *

Save Perl code as scriptlet (in ~/.perlmv/scriptlets/):

 $ perlmv -e 's/\d+//g' -w remove-digits

List all scriptlets (add B<-v> to also show their contents):

 $ perlmv -l
 lc
 uc
 remove-digits

Show source code of scriptlet:

 $ perlmv -s remove-digits
 s/\d+//g

Remove scriptlet:

 $ perlmv -D remove-digits

=head1 DESCRIPTION

Perlmv lets you rename files using Perl code. All the Perl code needs
to do is modify the filename in C<$_> and perlmv will do the rest
(actual renaming, recursive renaming, handling filename conflicts,
dry-run mode, etc.).

Perl code will first be run (eval-ed) once at the beginning for
testing, with C<-TEST> as the filename in C<$_> (and C<$TESTING> will
be defined). Perl code is not run under strict/warnings. Perl code is
run under C<App::perlmv::code> namespace.

Perl code can be specified directly from the command line (using
B<-e>), or by name in C<~/.perlmv/scriptlets/NAME>, or in
C</usr/share/perlmv/scriptlets/>, or in C<%scriptlets> in
L<App::perlmv::scriptlets>, or in C<%scriptlets> in
L<App::perlmv::scriptlets::std>.

=head1 OPTIONS

 -c  Only test compile code, do not run it on the arguments
 -e <CODE> Specify code to rename file (\$_), e.g. 's/\.old\$/\.bak/'
 -d  Dry-run (implies -v)
 -f  Only process files, do not process directories
 -h  Show this help
 -o  Overwrite (by default, ".1", ".2", and so on will be appended to
     avoid overwriting existing files)
 -r  Recursive
 -S  Do not process symlinks
 -V  Print version and exit
 -v  Verbose

 -l  list all scriptlets
 -s <NAME> Show source code for scriptlet
 -w <NAME> Write code specified in -e as scriptlet
 -D <NAME> Delete scriptlet

=head1 FAQ

=head2 Why should I use perlmv? There is prename already?

Yes, there is a very similar script called B<prename> (also accessible
via B<rename> in Debian) which comes with Perl. This script reinvents
prename and offers more features, e.g.: automatic renaming in case of
conflicts, recursive mode, and saving and loading scriptlets.

=head1 BUGS/TODOS

=over 4

=item * Patches for Windows welcome.

=item * Scriptlet should be able to receive arguments.

=back

=head1 SEE ALSO

L<prename>.

=cut
