#!/bin/env perl5
# 
# General file rename program written in Perl (using Tk for an interface).
# Most valuable under Windows, 
# 
# Here are some cookbook examples of what you might want to do:
# 
#   Move all the *.jpg files in a directory to another directory and call them
#   image_034.jpg ... image_067.jpg
# 
#       Unset "Same directory" pick the source and the target directories
#       Set the Ext to "jpg"
#       Set the destination name to "image_$03hwm.jpg"
#       Set the HWM pattern to "33" or
#           set the HWM pattern to "image_(\d+). and have a file called
#           "image_033.jpg" in the destination dir
#       Hit the run button
# 
#   Rename all files called *_tar.gzip to *.tgz
#
#       Pick the source directory
#       Set the ext to "gzip"
#       Set the basename to "(.+)_tar"
#       Set the destination name to "$b1.tgz"
#       Hit the run button
# 
#   Rename all the files which don't have any extension to have a .txt extension
#   in a directory and all its subdirs
# 
#       Pick the source directory
#       Set the ext to the empty string
#       Select "Recurse Subdirs"
#       Set the destination name to "$b0.txt"
#       Hit the run button
#
# This program uses Perl's pattern matching to specify the new names for a set
# of files.  Patterns are specified using Perl's pattern specifications, regex 
# to its freiends.  If you don't know how they work you can look up the syntax 
# in any good Perl book.
# 
# Bracketed elements in the basename pattern are assigned to the variables 
# $b1..$b9 ($b0 is the whole thing), elements in the extension pattern are 
# assigned to $e1..$e9.  $hwm represents the current "high water mark", that is 
# the additional numerical element used in the first example.  If the destination 
# name contains a $unique then the program will keep trying different numerical 
# values for that element until it generates a name that does not clash with an 
# existing file.  Any numerical value like $03hwm or $05unique will force the 
# number to be that number of digits wide preceeded by 0s, but notice the $e1 
# type variables are strings so specifying the width won't work there).
# 
# If you are thinking of using this to do something complex then you should first 
# create a test directory with a few files as examples.  It is amazing how often 
# I have run the program and only after seeing the result realised what I asked 
# it to do!
#
# This is a program I generated for my own use to manipulate groups of files under 
# windows 
#
# You will need the Tk package, assuming youare using ActivePerl (and who isn't?) 
# then PPM will be able to install it for you.
#
    use strict;
    use Tk;
    use Tk::DirTree;
    require Cwd;

    my($operating_system);

    my($a,$b,$src_dir,$dest_dir,$dir,$same_dir);
    my($recurse_dir,$flatten_dir);
    my($dest_fp,$dest_pat,$src_pat,$src_ext);
    my($dest_overwrite,$rename_dirs);
    my($main_win,$a_frame,$z_frame,$done_but,$cancel_but,$report_lab);
    my($b_frame,$c_frame,$d_frame,$e_frame,$f_frame,$g_frame,$h_frame);
    my($action);

    # Set some constants first
    $dest_dir = $src_dir = Cwd::getcwd();
    $same_dir = 1;
    $recurse_dir = "";
    $flatten_dir = "";
    $action = "rename";
        
    # I could just use $^O here but I have an aversion to 
    # putting control characters in scripts
    $operating_system = eval(sprintf('$%c',0xf));

    # Matching elements in the src_pat get assigned to $b1..$b9    
    $src_pat = "(.+)";
    # Matching elements in the $src_ext get assigned to $e1..$e9
    $src_ext = "\\S+";
    # So we can use matches to generate the new filename
    $dest_fp = "\$b1_\$03hwm.\$e0";

    $dest_pat = "image_(\\d+)\.";
    
    $main_win = new MainWindow(
        -title   => "TsorT Multi Rename",
      );

    # The source directory
    $a_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
            -padx => 1,
            -pady => 1,
          );

    $b_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
            -padx => 1,
            -pady => 1,
          );

    $c_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
            -padx => 1,
            -pady => 1,
          );

    $d_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
            -padx => 1,
            -pady => 1,
          );

    $e_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
            -padx => 1,
            -pady => 1,
          );

    $f_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
            -padx => 1,
            -pady => 1,
          );

    $g_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
            -padx => 1,
            -pady => 1,
          );

    $h_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
            -padx => 1,
            -pady => 1,
          );

    $z_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'bottom',
            -padx => 1,
            -pady => 1,
          );

    # Override some functions in DirTree for MSWindows
        eval(<<'EndOverride') if($operating_system =~ /^MSWin/i);
         # Override some funs for windows
         package Tk::DirTree;
         sub has_subdir {1}
         sub DirCmd {
             my ($w, $dir, undef) = @_;
             $dir =~ s/^(\w:)$/$1\//;
             my $h = DirHandle->new($dir) or return;
             my @names = grep( $_ ne '.' && $_ ne '..', $h->read );
             return @names;
         }
         sub add_to_tree {
             my( $w, $dir, $name, $parent ) = @_;

             my $image = $w->Getimage( $w->cget('-image') );
             my $mode = 'none';
             $mode = 'open' if $w->has_subdir( $dir );

             my @args = (-image => $image, -text => $name);
             if( $parent ) {             # Add in alphabetical order.
                 foreach my $sib ($w->infoChildren( $parent )) {
                     if( lc($sib) gt lc($dir) ) {
                         push @args, (-before => $sib);
                         last;
                     }
                 }
             }

             $w->add( $dir, @args );
             $w->setmode( $dir, $mode );
         }
EndOverride

    $a_frame->Button(
        -text => "Select Dir",
        -command => \&select_src_dir,
      )->pack(
            -side => 'right',
            -fill => 'y',
          );

#    $a_frame->Button(
#        -text => "Browse",
#        -command => \&select_src_dir,
#      )->pack(
#            -side => 'right',
#            -fill => 'y',
#          );

    $a_frame->Label(
        -text => "Source Directory"
      )->pack(
            -side => 'left',
            -fill => 'y',
          );

    $a_frame->Entry(
        -textvariable => \$src_dir,
      )->pack(
            -fill => 'both',
          );

    # The source name pattern
    $b_frame->Label(
        -text => "Basename"
      )->pack(
            -side => 'left',
            -fill => 'y',
          );

    $b_frame->Entry(
        -textvariable => \$src_ext,
        -width => 5,
      )->pack(
            -side => 'right',
            -fill => 'y',
          );

    $b_frame->Label(
        -text => "Ext",
      )->pack(
            -side => 'right',
            -fill => 'y',
          );

    $b_frame->Entry(
        -textvariable => \$src_pat,
      )->pack(
            -fill => 'both',
          );

    $c_frame->Checkbutton(
            -text => "Same Destination Dir",
            -variable => \$same_dir,
          )->pack(
                -side => 'left'
              );
    
    $c_frame->Checkbutton(
            -text => "Recurse Subdirs",
            -variable => \$recurse_dir,
          )->pack(
                -side => 'left'
              );
    
    $d_frame->Button(
        -text => "Browse",
        -command => \&select_dest_dir,
      )->pack(
            -side => 'right',
            -fill => 'y',
          );

    $d_frame->Label(
        -text => "Dest Directory"
      )->pack(
            -side => 'left',
            -fill => 'y',
          );

    $d_frame->Entry(
        -textvariable => \$dest_dir,
      )->pack(
            -fill => 'both',
          );

    $e_frame->Label(
        -text => "Action"
      )->pack(
            -side => 'left',
          );

    $e_frame->Optionmenu(
            -options => ["rename","uuencode","uudecode","join"],
            -variable => \$action,
            -command => \&switch_action,
          )->pack(
                -side => 'left',
              );

    &switch_action();
    # The bottom frame kicks off the program and shows the state
    $done_but = $z_frame->Button(
        -text    => "Start",
        -command => \&do_cmd,
      )->pack(
            -side => 'left',
            -fill => 'y',
          );

    $cancel_but = $z_frame->Button(
        -text    => "Done",
        -command => sub {$main_win->destroy},
      )->pack(
            -side => 'right',
            -fill => 'y',
          );

    $report_lab = $z_frame->Label(
        -text    => "User Input",
      )->pack(
            -fill => 'both',
          );

    # OK all the widgets are in place, lets go
    MainLoop;
    
    # Returns once it is done
    exit(0);

{
    my(@widgets);
      
sub switch_action
  {
    # We have selected a different action
    my($w);
    
    foreach $w (@widgets)
      {
        $w->destroy;
      }
    @widgets = ();
    
    if($action eq "join")
      {
        push(@widgets,$g_frame->Label(
            -text => "Dest Name"
          )->pack(
            -side => 'left',
            -fill => 'y',
          ));

        push(@widgets,$g_frame->Entry(
            -textvariable => \$dest_fp,
          )->pack(
            -fill => 'both',
          ));

        push(@widgets,$h_frame->Checkbutton(
            -text => "Overwrite",
            -variable => \$dest_overwrite,
          )->pack(
            -side => 'left'
          ));
      }
    else
      {
        push(@widgets,$f_frame->Checkbutton(
            -text => "Flatten target dirs",
            -variable => \$flatten_dir,
          )->pack(
                -side => 'left'
              ));
    
        push(@widgets,$f_frame->Checkbutton(
            -text => "Rename directories",
            -variable => \$rename_dirs,
          )->pack(
                -side => 'left'
              )) if($action eq "rename");
    
        push(@widgets,$g_frame->Label(
            -text => "Dest Name"
          )->pack(
            -side => 'left',
            -fill => 'y',
          ));

        push(@widgets,$g_frame->Entry(
            -textvariable => \$dest_fp,
          )->pack(
            -fill => 'both',
          ));

        push(@widgets,$h_frame->Checkbutton(
            -text => "Overwrite",
            -variable => \$dest_overwrite,
          )->pack(
            -side => 'left'
          ));

        push(@widgets,$h_frame->Label(
            -text => "HWM Pattern"
          )->pack(
            -side => 'left',
            -fill => 'y',
          ));

        push(@widgets,$h_frame->Entry(
            -textvariable => \$dest_pat,
          )->pack(
            -fill => 'both',
          ));
      }
  }
}

sub report
  {
    my($val) = @_;

    $report_lab->configure(-text => $val);
  }

sub select_src_dir
  {
    &select_dir(\$src_dir);
  }

sub add_output
  {
    my($line) = @_;
    $line .= "\n" if(!($line =~ /\n$/m));
    print STDERR $line;
  }

sub select_dest_dir
  {
    &select_dir(\$dest_dir);
  }
  
sub select_dir
  {
    # If we have a directory tree browser use it to select 
    # the directory
    my($dir_ref) = @_;
    my($status,$scrolled,$dtdialog);
    my($dtdialog_frame,$dtdialog_scrolled,$dtdialog_ok,$dtdialog_dir);

    $dtdialog = $main_win->Toplevel;
    $dtdialog->title("Choose Directory");
    $dtdialog_frame = $dtdialog->Frame->pack(
        -fill => "x",
        -side => "bottom"
      );
    $dtdialog_scrolled = $dtdialog->Scrolled('DirTree',
        -scrollbars => 'osoe',
        -width => 35,
        -height => 20,
        -selectmode => 'browse',
        -exportselection => 1,
        -browsecmd => sub {$dtdialog_dir=shift},
        -command   => sub {$dtdialog_ok = 1 },
      )->pack(-fill => "both", -expand => 1);

    if($operating_system =~ /^MSWin/i)
      {
        require Win32API::File;

        my(@drv,$d,$p);
        $p = " "x105;
        &Win32API::File::GetLogicalDriveStrings(105,$p);
        foreach $d (split(/\x00/,$p))
          {
            $d =~ s/\\//g;
            $d = lc($d);
            next if(${$dir_ref} =~ /^$d/i);
            $dtdialog_scrolled->add_to_tree($d, $d);
          }
      }

    $dtdialog_frame->Button(-text => 'OK',
        -command => sub {$dtdialog_ok =  1}
      )->pack(-side => 'left');
    $dtdialog_frame->Button(-text => 'Cancel',
        -command => sub {$dtdialog_ok = -1}
      )->pack(-side => 'left');

    $dtdialog_ok = 0;
    $dtdialog_dir = ${$dir_ref};
    $dtdialog_frame->waitVariable(\$dtdialog_ok);

    if ($dtdialog_ok == 1)
      {
        if (-x $dtdialog_dir)
          {
            $dtdialog_dir =~ s/^(\w):$/$1:\//;
            ${$dir_ref} = $dtdialog_dir;
          }
        else
          {
            &add_output("$dtdialog_dir doesn't exist");
          }
      }
    $dtdialog->withdraw;
    $dtdialog->destroy;    
  }

sub do_cmd
  {
    $dest_dir = $src_dir if($same_dir);

    if($action eq "join")
      {
        &do_join;
        &report("Join completed");
      }
    else
      {
        # Deduce the destination pattern from the fp string
        return if(!$dest_pat);
    
        $dest_dir = $src_dir if($same_dir);

        &do_dir($src_dir,$dest_dir,-1);
        &report("\u$action completed");
      }
  }

sub do_join
  {
    local(*IN,*OUT,*DIR);
    my($f,$linelen,$dest_hwm,$dbfp,@files);
    my($target,$len);

    $linelen = 1024*1024;

    if(!-d $dest_dir)
      {
        &report("Cannot open dir $dest_dir");
        return;
      }

    if($dest_hwm < 0)
      {
        $dest_hwm = &find_hwm($dest_dir,$dest_pat);
        $dest_hwm = 0 if($dest_hwm < -1);
      }
    do{
        $dest_hwm++;
        $dbfp = $dest_fp;
        while($dbfp =~ /\$(\-?\d*)hwm/)
          {
            my($val);
            $val = sprintf("\%$1d",$dest_hwm);
            $dbfp =~ s/\$(\-?\d*)hwm/$val/;
          }
        $target = "$dest_dir/$dbfp";
        if(-f $target && !($dest_fp =~ /\$(\-?\d*)hwm/))
          {
            # Force the dest pattern to have hwm if needed
            $dest_fp .= '$hwm' if(!($dest_fp =~ s/\.([^\.]+)$/\$hwm\.$1/));
          }
      } while(-f $target);

    open(OUT,">".$target) or die("Cannot write to $target\n");
    binmode OUT;

    opendir(*DIR,$src_dir);
    @files = sort(readdir(DIR));
    closedir(DIR);

    foreach $f (sort @files)
      {
        next if($f =~ /^\.\.?$/);
        next if(-d "$src_dir/$f");

        if(!$src_ext)
          {
            next if(!($f =~ /^($src_pat)$/));
          }
        else
          {
            next if(!($f =~ /^($src_pat)\.($src_ext)$/));
          }
        print "Next file $src_dir/$f\n";
        open(IN,"$src_dir/$f");
        binmode IN;
       
        do
          {
            my($buf);
            $len = sysread IN,$buf,$linelen;
            syswrite OUT,$buf,$len if($len);
          } while($len > 0);
        close(IN);
      }

    close(OUT);
  }

sub do_dir
  {
    my($isrc_dir,$idest_dir,$dest_hwm) = @_;
    my($f,$base,$ext,$dbase,$dbfp,$hh);
    my(@base,@ext,$unique,$uses_unique);
    my(@subdirs,@files,@rename_subdirs);
    local(*DIR);
        
    if(!-r $isrc_dir)
      {
        &report("Cannot open directory $isrc_dir");
        return;
      }

    if($dest_hwm < 0)
      {
        $dest_hwm = &find_hwm($idest_dir,$dest_pat);
        return if($dest_hwm < -1);
        if(!-d $idest_dir)
          {
            &report("Cannot open dir $idest_dir");
            return;
          }
      }
    else
      {
        # Being called recusively on subdir
        if(!-d $idest_dir)
          {
            if($flatten_dir)
              {
                &report("Cannot open dir $idest_dir");
                return;
              }
            mkdir $idest_dir,0755;
          }
      }
    $dest_hwm++;

    # If one of the renames uses $unique they all do!
    $unique = "";
    $uses_unique = "";

    # Read all the files and sort into ASCII order (whatever the OS does)
    opendir(*DIR,$isrc_dir);
    @files = sort(readdir(DIR));
    closedir(DIR);
    
    while($f = shift(@files))
      {
        my($is_subdir);
        
        next if($f =~ /^\./);
        $base = $f;
        $unique = "" if($uses_unique);
        $is_subdir = "";
        
        if($recurse_dir && -d "$isrc_dir/$f")
          {
            push(@subdirs,$f);
            next if(!$rename_dirs);
            $is_subdir = 1;
          }

        if($src_ext)
          {
            if($base =~ s/\.($src_ext)$//)
              {
                # This matches the extension
                @ext = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
              }
            else
              {
                next;
              }
          }
        else
          {
            # $src_ext is empty, expect NO extension
            next if($base =~ /\./);
            @ext = ();
          }

        # The extension matches move to the basename
        if($base =~ /^($src_pat)$/)
          {
            @base = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
          }
        else
          {
            next;
          }

        # We have a total match, work out the destination name

        # Now substitute the $e1..$e9 and $b1..$b9 elements into
        # the target name.  As a special case $b0 matches with the 
        # total name
        while(!$dbfp)
          {
            my($val);
                        
            $dbfp = $dest_fp;
            foreach $hh ("base","ext")
              {
                my($sln,$c);
    
                $sln = substr($hh,0,1);
                for($c=0;$c<=9;$c++)
                  {
                    while($dbfp =~ /\$$sln$c/)
                      {
                        # In theory  $val = ${$hh}[$c]  should
                        # do this, but obviously I don't know my
                        # perl well enough
    
                        $val = eval("\$$hh\[\$c\]");
                        $dbfp =~ s/\$$sln$c/$val/;
                      }
                  }
              }
            while($dbfp =~ /\$(\-?\d*)hwm/)
              {
                $val = sprintf("\%$1d",$dest_hwm);
                $dbfp =~ s/\$(\-?\d*)hwm/$val/;
              }
            while($dbfp =~ /\$(\d*)unique/)
              {
                $uses_unique = 1;
                $val = sprintf("\%$1d",$unique);
                $dbfp =~ s/\$(\d*)unique/$val/;
              }
            
            if(-r "$idest_dir/$dbfp")
              {
                # We have a file called that already
                if($dest_overwrite)
                  {
                    # Just overwrite it
                    # unlink("$idest_dir/$dbfp");
                  }
                elsif($uses_unique)
                  {
                    # Try and generate a different name
                    $unique++;
                    $dbfp = "";
                    next;
                  }
                else
                  {
                    # Give up on this file
                    last;
                  }
              }

            if($is_subdir)
              {
                push(@rename_subdirs,$f,$dbfp);
              }
            else
              {
                if($action eq "rename")
                  {
                    rename "$isrc_dir/$f","$idest_dir/$dbfp";
                  }
                elsif($action eq "uudecode")
                  {
                    &uudecode("$isrc_dir/$f","$idest_dir/$dbfp");
                  }
                elsif($action eq "uuencode")
                  {
                    &uuencode("$isrc_dir/$f","$idest_dir/$dbfp");
                  }
              }

            $dest_hwm++;
          }
        $dbfp = "";
      }

    foreach $f (sort(@subdirs))
      {
        my($d);
        
        $d = "$idest_dir/$f";
        $d = "$idest_dir" if($flatten_dir);
        $dest_hwm = &do_dir("$isrc_dir/$f",
                            $d,$dest_hwm - 1);
      }

    # Finally rename all the matched subdirs
    for($f=0;$f<=$#rename_subdirs;$f+=2)
      {
        rename $isrc_dir."/".$rename_subdirs[$f],
               $idest_dir."/".$rename_subdirs[$f+1];
      }
    return($dest_hwm);
  }

sub find_hwm
  {
    my($dir,$pat) = @_;
    my($hwm,$f);
    local(*DIR);
    
    return($pat) if($pat =~ /^\d+$/);

    if(!-d $dir)
      {
        &report("Cannot find directory $dir");
        return(-2);
      }
    if(!-r $dir)
      {
        &report("Cannot read directory $dir");
        return(-2);
      }
    opendir(DIR,$dir);
    $hwm = -1;
    while($f = readdir(DIR))
      {
        if($f =~ /$pat/)
          {
            $hwm = $1 if($1 > $hwm);
          }
      }
    closedir(DIR);
    return($hwm);
  }

sub uuencode
  {
    # UUencode a binary file
    my($input,$output) = @_;
    my($line,$len,$ll,$fname);
    
    $ll = 45;
    $output = $input.".uue" if(!$output);
    open(INPUT,$input);
    binmode INPUT;
    open(OUTPUT,">$output");
    binmode OUTPUT;
    $fname = $input;
    while($fname =~ m#/#)
      {
        $fname =~ s#^[^/]*/##;
      }
    print OUTPUT "begin 644 $fname\n";
    do
      {
        my($p);
        $len = read INPUT,$line,$ll;
        # Buffer up to nearest set of 3 bytes
        $len = 3*(1+int(($len-1)/3)) if($len > 0);
        if($len != $ll)
          {
            # print "yy\n";
          }
        # $p = substr(pack("u$len",$line),0,2+int(($len-1)/3+1)*4);
        $p = pack("u$len",$line);
        $p = "\`\n" if(!$p);
        print OUTPUT $p;
      } while($len > 0);
    print OUTPUT "end\n";
    close(OUTPUT);
    close(INPUT);
  }

sub uudecode
  {
    # UUencode a binary file
    my($input,$output) = @_;
    my($line,$len,$ll);
    local(*OUTPUT,*INPUT);
    
    $ll = 46;
    $output = $input.".uue" if(!$output);
    open(INPUT,$input);
    binmode INPUT;
    open(OUTPUT,">$output");
    print OUTPUT "begin 644 $input\n";
    $len = read INPUT,$line,$ll;
    while($len > 0)
      {
        print OUTPUT unpack("u$len",$line."                ");
        $len = read INPUT,$line,$ll;
      }
    print OUTPUT " \nend\n";
    close(OUTPUT);
    close(INPUT);
  }