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

# $n[i] is array containing information about i-th file:
# 0 - original name (windows codepage)
# 1 - original name (internal unicode)
# 2 - new name if 'Make' button was pressed or old name otherwise (windows codepage)
# 3 - new name if 'Make' button was pressed or old name otherwise (internal unicode)
# 4 - file size (bytes)
# 5 - modification time (seconds)
# 6 - file type ('d' for directory, 'f' for ordinary file)
# 7 - new name if rename was successful or old name otherwise (windows codepage)
# 8 - new name if rename was successful or old name otherwise (internal unicode)

my ($Mod, $mg, $mi, $me, $Wrap, $Clob, $Sort, $Dir, $md, $gi, $go, @n) =
	('s',  '',  '',  '',     0,     0,    '',    0,   0,  '',  '');
tie our @MRU, 'Tie::File', "c:/windows/rename.db" or die "Cannot open database";

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

my $Op = $mw->Frame()->pack();
my $RenFr = $Op->LabFrame(-label => 'Regular expression')->pack(qw/-side left/);
my $SMod = $RenFr->Radiobutton(qw(-text s/ -value s), -variable => \$Mod)->pack(qw/-side left/);
$Bl->attach($SMod, -balloonmsg => 'Substitution mode');
my $YMod = $RenFr->Radiobutton(qw(-text y/ -value y), -variable => \$Mod)->pack(qw/-side left/);
$Bl->attach($YMod, -balloonmsg => 'Transliteration mode');
my $ri = $RenFr->BrowseEntry(-variable => \$gi, -buttontakefocus => 0, -browse2cmd =>
	sub { $go = decode("utf8", (split chr(0x0), $MRU[$_[1]])[1]) if $go eq '';
		($me, $mg, $mi) = (split chr(0x0), $MRU[$_[1]])[2..4] })->pack(qw/-side left/);
$ri->Subwidget('entry')->configure(qw/-background white -width 17/);
$RenFr->Label(qw(-text /))->pack(qw/-side left/);
my $ro = $RenFr->BrowseEntry(-variable => \$go, -buttontakefocus => 0, -browse2cmd =>
	sub { $gi = decode("utf8", (split chr(0x0), $MRU[$_[1]])[0]) if $gi eq '';
		($me, $mg, $mi) = (split chr(0x0), $MRU[$_[1]])[2..4] })->pack(qw/-side left/);
$ro->Subwidget('entry')->configure(qw/-background white -width 17/);
$RenFr->Label(qw(-text /))->pack(qw/-side left/);
my $GMod = $RenFr->Checkbutton(-variable => \$mg, -offvalue => '')->pack(qw/-side left/);
my $IMod = $RenFr->Checkbutton(-variable => \$mi, -offvalue => '')->pack(qw/-side left/);
my $EMod = $RenFr->Checkbutton(-variable => \$me, -offvalue => '')->pack(qw/-side left/);
$SMod->configure(-command => \&setsmod);
$YMod->configure(-command => \&setymod);
&setsmod;
$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');
my $Mk = $Buttons->Button(qw/-width 4 -text Make/, -command => \&preview)->pack(qw/-side left/);
$Bl->attach($Mk, -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); addtoreg() });
$Un->configure(-command => sub { ($Clob, $md) = (0, 0); action(7, 0, \$St, \$Un) });
$Buttons->Button(qw/-width 4 -text Quit/, -command => sub { untie @MRU; 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).' Modification time', 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 => \&movenew)->
	pack(qw/-side left/), -balloonmsg => 'Change old names to new names in left preview'.
	' panel. WARNING: Undo will be impossible');
$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 (@MRU) {
	@_ = split chr(0x0), $_, 3;
	$ri->insert("end", decode("utf8", $_[0]));
	$ro->insert("end", decode("utf8", $_[1]))
}
for (0..$#ARGV) {
	($n[$_][0] = $ARGV[$_]) =~ y#\\#/#;
	$n[$_][1] = decode 'cp1251', $n[$_][0];
	getstat($_);
	@{$n[$_]}[7..8] = @{$n[$_]}[2..3]
}
&view;
MainLoop;

sub preview {
	my $si = $gi;
	$si = '^' if $si eq '' and $Mod eq 's';
	my $cn = $AA->get;
	for (0..$#n) {
		(my $nf = $n[$_][1]) =~ s#^.*/##;
		(my $pt = $n[$_][1]) =~ s#[^/]*$##;
		my $so = $go;
		if ($Mod eq 's') {
			$so =~ 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;
			$so =~ s/\\5/md5dig($n[$_][0])/ge if $so =~ /\\5/;
			eval '$nf =~ s/$si/$so/'.$me.$mg.$mi
		} else {
			eval '$nf =~ tr/'.$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]];
		if (! $Ok && lc($n[$_][$_[0]]) eq lc($n[$_][$_[1]]) && $n[$_][$_[0]] ne $n[$_][$_[1]]) {
			rename $n[$_][$_[0]], $n[$_][$_[1]]."_stlle";
			$Ok = rename $n[$_][$_[1]]."_stlle", $n[$_][$_[1]]
		}
		@{$n[$_]}[7..8] = @{$n[$_]}[2..3] if $Ok && $_[0] == 0;
		$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 addtoreg {
	push @MRU, $gi.chr(0x0).$go.chr(0x0).$me.chr(0x0).$mg.chr(0x0).$mi.chr(0x0).time
		if (grep { index($_, $gi.chr(0x0).$go.chr(0x0).$me.chr(0x0)) != -1 } @MRU) + 0 == 0
}

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 movenew {
	$Un->configure(qw/-state disabled/);
	for (0..$#n) { @{$n[$_]}[0,1,2,3] = @{$n[$_]}[7,8,7,8] }
	&view
}

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..3] = @{$n[$_]}[0..1];
	@{$n[$_]}[4..6] = (stat($n[$_][0]))[7,9,2];
	$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
}

sub md5dig {
	$_[0] =~ y#/#\\#;
	if (open FILE, $_[0]) {
		binmode FILE;
		my $i = Digest::MD5->new->addfile(*FILE)->hexdigest;
		close FILE;
		return $i
	} else {
		return '0' x 32
	}
}

sub setsmod {
	$Bl->attach($ri, -balloonmsg => 'Search expression');
	$Bl->attach($ro, -balloonmsg => 'Replace expression');
	$GMod->configure(qw/-text g -onvalue g/);
	$IMod->configure(qw/-text i -onvalue i/);
	$EMod->configure(qw/-text e -onvalue ee/);
	($mg, $mi, $me) = ('', '', '');
	$Bl->attach($GMod, -balloonmsg => 'Global search');
	$Bl->attach($IMod, -balloonmsg => 'Case-insensitive search');
	$Bl->attach($EMod, -balloonmsg => 'Evaluation of replace expression')
}

sub setymod {
	$Bl->attach($ri, -balloonmsg => 'Search list');
	$Bl->attach($ro, -balloonmsg => 'Replace list');
	$GMod->configure(qw/-text c -onvalue c/);
	$IMod->configure(qw/-text d -onvalue d/);
	$EMod->configure(qw/-text s -onvalue s/);
	($mg, $mi, $me) = ('', '', '');
	$Bl->attach($GMod, -balloonmsg => 'Complement the search list');
	$Bl->attach($IMod, -balloonmsg => 'Delete found but unreplaced characters');
	$Bl->attach($EMod, -balloonmsg => 'Squash duplicate replaced characters')
}

=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. There two modes of work: substitution (s///) and transliteration
(y///). 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. If files are
renamed by groups (more than one "Go!"), "Undo" will undo all changes at once. In
substitution mode 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.

=item *

\5 - md5 sum.

=back

There is '<' button to put new filenames instead of old ones into preview panel after
renaming in order to start second stage of filename modification (Undo will be disabled).
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). Inputted expressions are
stored in "c:/windows/rename.db".

=head1 README

File and directories multi-rename script for Windows with graphical user interface,
similar to Multi-Rename Tool of Total Commander, but more powerful, a quick and
convenient way to use perl regular expressions for renaming files (it can make new
directories if needed).

=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').
The path to database file is also hard-wired.

=pod OSNAMES

Win32

=pod SCRIPT CATEGORIES

Win32/Utilities

=cut

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