use warnings 'all';
use strict;
use POSIX 'strftime';
use Tk;
use Tk::LabFrame;
use Tk::Balloon;
use Tk::TextUndo;
use Encode qw(encode decode);
use Fcntl ':mode';
use List::Util 'shuffle';

my ($mg, $mi, $me, $Wrap, $Clob, $Sort, $Dir, $md, @n) = ('', '', '', 0, 0, '', 0, 0);

my $mw = MainWindow->new;
$mw->configure(-title => 'Perl-based Multi Rename Tool by Steuermann Liouville, v2.0');
my $Bl = $mw->Balloon();

my $Op = $mw->Frame()->pack();
my $RenFr = $Op->LabFrame(-label => 'Regular expression')->pack(qw/-side left/);
$RenFr->Label(qw(-text s/))->pack(qw/-side left/);
my $ri = $RenFr->Entry()->pack(qw/-side left/);
$Bl->attach($ri, -balloonmsg => 'Search expression');
$RenFr->Label(qw(-text /))->pack(qw/-side left/);
my $ro = $RenFr->Entry()->pack(qw/-side left/);
$Bl->attach($ro, -balloonmsg => 'Replace expression');
$RenFr->Label(qw(-text /))->pack(qw/-side left/);
$Bl->attach($RenFr->Checkbutton(-variable => \$mg, qw/-text g -onvalue g/, -offvalue => '')->
	pack(qw/-side left/), -balloonmsg => 'Global search');
$Bl->attach($RenFr->Checkbutton(-variable => \$mi, qw/-text i -onvalue i/, -offvalue => '')->
	pack(qw/-side left/), -balloonmsg => 'Case-insensitive search');
$Bl->attach($RenFr->Checkbutton(-variable => \$me, qw/-text e -onvalue ee/, -offvalue => '')->
	pack(qw/-side left/), -balloonmsg => 'Evaluation of replace expression');
$ri->focus;

my $CntFr = $Op->LabFrame(qw/-label Counter/)->pack(qw/-side left/);
$Bl->attach($CntFr, -balloonmsg => 'Counter: \0 in replace expression, \4 for total number');
my $AA = $CntFr->Spinbox(qw/-from -9999 -to 9999 -width 4/);
$AA->set(0);
$Bl->attach($AA, qw/-balloonmsg Start/);
my $SS = $CntFr->Spinbox(qw/-from -9999 -to 9999 -width 4/);
$SS->set(1);
$Bl->attach($SS, qw/-balloonmsg Step/);
my $WW = $CntFr->Spinbox(qw/-from 1 -to 99 -width 2/);
$Bl->attach($WW, qw/-balloonmsg Digits/);
my $ZZ = $CntFr->Spinbox(qw/-from -9999 -to 9999 -width 4 -state disabled/);
$ZZ->set(0);
$Bl->attach($ZZ, -balloonmsg => 'Stop number in wrap mode');
$AA->pack($SS, $WW, $ZZ, qw/-side left/);
$Bl->attach($CntFr->Checkbutton(qw/-text z/, -variable => \$Wrap, -command => 
	sub { $Wrap ? $ZZ->configure(qw/-state normal/) : $ZZ->configure(qw/-state disabled/) })->
	pack(qw/-side left/), -balloonmsg => 'Wrap mode, reset counter');

my $Buttons = $Op->LabFrame(qw/-label Actions/)->pack(qw/-side left/);
$Bl->attach($Buttons->Checkbutton(-variable => \$md, qw/-text d/)->pack(qw/-side left/),
	-balloonmsg =>	'Create new directories');
$Bl->attach($Buttons->Checkbutton(-variable => \$Clob, qw/-text !/)->pack(qw/-side left/),
	-balloonmsg =>	'Clobber mode, WARNING: files with conflicting names will be erased');
$Bl->attach($Buttons->Button(qw/-width 4 -text Make/, -command => \&preview)->
	pack(qw/-side left/), -balloonmsg => 'Prepare filenames');
my $St = $Buttons->Button(qw/-width 4 -text Go! -state disabled/)->pack(qw/-side left/);
my $Un = $Buttons->Button(qw/-width 4 -text Undo -state disabled/)->pack(qw/-side left/);
$St->configure(-command => sub { action(0, 2, \$Un, \$St) });
$Un->configure(-command => sub { ($Clob, $md) = (0, 0); action(2, 0, \$St, \$Un) });
$Buttons->Button(qw/-width 4 -text Quit/, -command => \&exit)->pack(qw/-side left/);

my $Op2 = $mw->Frame()->pack();
$Bl->attach($Op2->Button(qw/-width 1 -text ^/, -command => \&loadcur)->
	pack(qw/-side left/), -balloonmsg => 'Get old filenames from preview panel');
$Op2->Label(-text => 'Sort by ')->pack(qw/-side left/);
$Bl->attach($Op2->Radiobutton(-text => chr(0x2193), -value => 'f', -variable => \$Sort,
	-command => sub { Sort('sort { $b->[1] cmp $a->[1] }') })->
	pack(qw/-side left/), -balloonmsg => 'Descending case-sensitive fullpath sort');
$Bl->attach($Op2->Radiobutton(-text => chr(0x2191).' Full path', qw/-value F/,
	-variable => \$Sort, -command => sub { Sort('sort { $a->[1] cmp $b->[1] }') })->
	pack(qw/-side left/), -balloonmsg => 'Ascending case-sensitive fullpath sort');
$Bl->attach($Op2->Radiobutton(-text => chr(0x2193), -value => 'p', -variable => \$Sort,
	-command => sub { Sort('sort { uc($b->[1]) cmp uc($a->[1]) }') })->
	pack(qw/-side left/), -balloonmsg => 'Descending case-insensitive fullpath sort');
$Bl->attach($Op2->Radiobutton(-text => chr(0x2191).' FULL PATH', qw/-value P/,
	-variable => \$Sort, -command => sub { Sort('sort { uc($a->[1]) cmp uc($b->[1]) }') })->
	pack(qw/-side left/), -balloonmsg => 'Ascending case-insensitive fullpath sort');
$Bl->attach($Op2->Radiobutton(-text => chr(0x2193), -value => 'd', -variable => \$Sort,
	-command => sub { Sort('sort { ds($b->[1]) cmp ds($a->[1]) }') })->
	pack(qw/-side left/), -balloonmsg => 'Descending dictionary fullpath sort');
$Bl->attach($Op2->Radiobutton(-text => chr(0x2191).' full path', qw/-value D/,
	-variable => \$Sort, -command => sub { Sort('sort { ds($a->[1]) cmp ds($b->[1]) }') })->
	pack(qw/-side left/), -balloonmsg => 'Ascending dictionary fullpath sort');
$Bl->attach($Op2->Radiobutton(-text => chr(0x2193), -value => 's', -variable => \$Sort,
	-command => sub { Sort('sort { $b->[4] <=> $a->[4] }') })->
	pack(qw/-side left/), -balloonmsg => 'Descending filesize, B: \1 in replace expression');
$Bl->attach($Op2->Radiobutton(-text => chr(0x2191).' File size', qw/-value S/,
	-variable => \$Sort, -command => sub { Sort('sort { $a->[4] <=> $b->[4] }') })->
	pack(qw/-side left/), -balloonmsg => 'Ascending filesize, B: \1 in replace expression');
$Bl->attach($Op2->Radiobutton(-text => chr(0x2193), -value => 't', -variable => \$Sort,
	-command => sub { Sort('sort { $b->[5] <=> $a->[5] }') })->
	pack(qw/-side left/), -balloonmsg => 'Descending mtime, s: \2 in replace expression');
$Bl->attach($Op2->Radiobutton(-text => chr(0x2191).' MTime', qw/-value T/,
	-variable => \$Sort, -command => sub { Sort('sort { $a->[5] <=> $b->[5] }') })->
	pack(qw/-side left/), -balloonmsg => 'Ascending mtime, s: \2 in replace expression');
$Bl->attach($Op2->Radiobutton(-text => 'Random', qw/-value r/, -variable => \$Sort,
	-command => sub { Sort('shuffle') })->pack(qw/-side left/), -balloonmsg => 'Random order');
$Bl->attach($Op2->Checkbutton(-text => 'Directories first', -variable => \$Dir)->
	pack(qw/-side left/), -balloonmsg => 'Separate directories, f/d: \3 in replace expression');
$Bl->attach($Op2->Button(qw/-width 1 -text ^/, -command => \&loadnew)->
	pack(qw/-side left/), -balloonmsg => 'Get new filenames from preview panel');

my $Result = $mw->Frame()->pack(qw/-expand yes -fill both -side bottom/);
my $t = $Result->Scrolled(qw/TextUndo -scrollbars osoe -wrap none -width 50/)->
	pack(qw/-expand yes -fill both -side left/);
$Bl->attach($t, -balloonmsg => 'Old names can be added and used by the tool (left ^ button)');
my $u = $Result->Scrolled(qw/TextUndo -scrollbars osoe -wrap none -width 50/)->
	pack(qw/-expand yes -fill both -side left/);
$Bl->attach($u, -balloonmsg => 'New names can be edited and used by the tool (right ^ button)');

for (0..$#ARGV) {
	($n[$_][0] = $ARGV[$_]) =~ y#\\#/#;
	$n[$_][1] = decode 'cp1251', $n[$_][0];
	getstat($_)
}
&view;
MainLoop;

sub preview {
	my $si = $ri->get;
	$si = '^' if $si eq '';
	my $cn = $AA->get;
	for (0..$#n) {
		(my $nf = $n[$_][1]) =~ s#^.*/##;
		(my $pt = $n[$_][1]) =~ s#[^/]*$##;
		(my $so = $ro->get) =~ s/\\0/sprintf("%0".$WW->get."d", $cn)/ge;
		$cn += $SS->get;
		if ($Wrap && abs($cn) > abs($ZZ->get)) { $cn = $AA->get }
		$so =~ s/\\1/$n[$_][4]/g;
		$so =~ s/\\2/$n[$_][5]/g;
		$so =~ s/\\3/$n[$_][6]/g;
		$so =~ s/\\4/sprintf("%0".$WW->get."d", $#n+1)/ge;
		eval '$nf =~ s/$si/$so/'.$me.$mg.$mi;
		$n[$_][3] = $pt.$nf;
		$n[$_][2] = encode 'cp1251', $pt.$nf
	}
	&view;
	$St->configure(qw/-state normal/)
}

sub action {
	&clear;
	for (0..$#n) {
		if ($md) {
			(my $pt = $n[$_][$_[0]]) =~ s#/?[^/]*$##;
			(my $dif = $n[$_][$_[1]]) =~ s#/?[^/]*$##;
			$dif =~ s#^\Q$pt\E/?##;
			$pt = "." if $pt eq "";
			foreach (split '/', $dif) {
				$pt .= "/".$_;
				mkdir $pt unless -d $pt
			}
		}
		my $Ok = 0;
		$Ok = rename $n[$_][$_[0]], $n[$_][$_[1]] if -e $n[$_][$_[0]] &&
			$Clob || ! -e $n[$_][$_[1]];
		$t->insert('end', ($Ok ? 'OK: ' : 'NG: ').$n[$_][$_[0]+1]."\n");
		$u->insert('end', $n[$_][$_[1]+1]."\n")
	}
	${$_[2]}->configure(qw/-state normal/);
	${$_[3]}->configure(qw/-state disabled/)
}

sub clear {
	$t->delete(qw/0.0 end/);
	$u->delete(qw/0.0 end/)
}

sub view {
	&clear;
	map { $t->insert('end', $_->[1]."\n"); $u->insert('end', $_->[3]."\n") } @n
}

sub loadcur {
	for (0..$t->index('end')-2) { getname($_, 0, \$t); getstat($_) }
	&view
}

sub loadnew {
	for (0..$#n) { getname($_, 2, \$u) }
	&view;
	$St->configure(qw/-state normal/)
}

sub getname {
	shift;
	my @i = ${$_[1]}->dump('-text', ($_+1).'.0', ($_+1).'.end');
	next if $#i < 1;
	$n[$_][$_[0]+1] = "";
	for (my $j = 1; $j < $#i; $j += 3) { $n[$_][$_[0]+1] .= $i[$j] }
	$n[$_][$_[0]+1] =~ y#\\#/#;
	$n[$_][$_[0]] = encode 'cp1251', $n[$_][$_[0]+1]
}

sub getstat {
	shift;
	($n[$_][2], $n[$_][3]) = ($n[$_][0], $n[$_][1]);
	($n[$_][6], $n[$_][4], $n[$_][5]) = (stat($n[$_][0]))[2,7,9];
	$n[$_][6] = "f" if S_ISREG($n[$_][6]);
	$n[$_][6] = "d" if S_ISDIR($n[$_][6])
}

sub ds {
	(my $i = $_[0]) =~ s/[\W_]//g;
	return uc($i)
}

sub Sort {
	@n = $Dir ? (eval $_[0].' grep { $_->[6] eq "d" } @n',
		eval $_[0].' grep { $_->[6] eq "f" } @n') : eval $_[0].' @n';
	&view
}

=head1 NAME

rename - simple graphical multi-rename tool for M$ Windows.

=head1 DESCRIPTION

This script can rename multiple files using perl regular expression or using prepared
list of new filenames. Current filenames can be passed to script as command-line arguments
(wildcards are supported using Wild.pm as described in documentation) or by pasting to
left preview panel. Script also can create new directories and replace existing files.
There are special combinations which can be used in replace expression:

=over 4

=item *

\0 - counter, parameters for counter are set with spinboxes.

=item *

\1 - filesize in bytes.

=item *

\2 - modification time in seconds.

=item *

\3 - filetype: 'd' for directory, 'f' for ordinary file.

=item *

\4 - total number of files being renamed.

=back

Filename list can be sorted or randomized with radiobuttons. In order to use manually
added/modified filenames in preview panel it is necessary to press '^' button located
above each panel. Backreferences ($1, $2...) requires 'e' switch to be set which implies
using perl syntax in replace expression (due to 'ee' modifier).

=head1 PREREQUISITES

This script requires the C<Tk> module. It also requires C<List::Util>.

=head1 BUGS

Windows codepage to decode/encode to/from Unicode is hard-wired now (e.g. 'cp1251').

=pod OSNAMES

Win32

=pod SCRIPT CATEGORIES

Win32/Utilities

=cut

# vim:ts=4:sw=4:lines=34:co=96