#!/usr/bin/perl -w

#########################
# Pull in needed packages
#########################

use Tk;
use Tk::JPEG;

##################################
# Do forward variable declarations
##################################

use vars
qw(
$any_button
$controls_frame_l
$current_file_name_l
$dir_name
$file_name
$image
$picture_f
$the_font
$the_picture_l

@action_buttons
@files

$fw_ap_b
$fw_bb_b
$fw_bj_b
$fw_bt_b
$fw_ca_b
$fw_cl_b
$fw_cs_b
$fw_dt_b
$fw_fc_b
$fw_fu_b
$fw_ks_b
$fw_lk_b
$fw_lz_b
$fw_mf_b
$fw_nu_b
$fw_sh_b
$fw_sp_b
$fw_te_b
$fw_tf_b
$fw_tp_b
$fw_mixed_b

$dw_ap_b
$dw_bb_b
$dw_bj_b
$dw_bt_b
$dw_ca_b
$dw_cl_b
$dw_cs_b
$dw_dt_b
$dw_fc_b
$dw_fu_b
$dw_ks_b
$dw_lk_b
$dw_lz_b
$dw_mf_b
$dw_nu_b
$dw_sh_b
$dw_sp_b
$dw_te_b
$dw_tf_b
$dw_tp_b
$dw_mixed_b

$dw_leave_as_is_b
$dw_delete_b

$vis
$mw
@args
);

####################
# Do initializations
####################
$dir_name       =  undef;
$file_name      =  undef;
$image          =  undef;
@files          =     ();
@action_buttons =     ();
$the_font       = "6x10";

####################
# Define subroutines
####################

sub no_current_dir_name
{
  my $reason_for_living = shift
    or die "no_current_dir_name: reason parameter not received";

  $current_dir_name_l->destroy()
    if Tk::Exists( $current_dir_name_l );

  $current_dir_name_l = $controls_f->Label
  (
    -text             => "Directory name: $reason_for_living",
    -font             =>                          "$the_font",
    -background       =>                           "darkblue",
    -foreground       =>                              "white",
  )->pack
  (
    -after            =>                 $current_file_name_l,
    -side             =>                             "bottom",
    -anchor           =>                                  "w",
    -expand           =>                                    1,
    -fill             =>                                  "x",
    -padx             =>                                    2,
    -pady             =>                                    2,
  ) or die "could not create and pack 'no current dir name' label";

}

sub new_current_dir_name
{
  my $new_dir_name = shift
    or die "new_current_dir_name: no new directory name parameter received";

  $current_dir_name_l->destroy() if Tk::Exists( $current_dir_name_l );

  $current_dir_name_l = $controls_f->Label
  (
    -text             => "Directory name: '$new_dir_name'",
    -font             =>                       "$the_font",
    -background       =>                      "dodgerblue",
    -foreground       =>                           "black",
  )->pack
  (
    -after            =>              $current_file_name_l,
    -side             =>                          "bottom",
    -anchor           =>                               "w",
    -expand           =>                                 1,
    -fill             =>                               "x",
    -padx             =>                                 2,
    -pady             =>                                 2,
  ) or die "could not create and pack 'new current"
    . " dir name' dir '$new_dir_name' label";
}

sub new_current_dir
{
  $dir_name = shift
    or die "new_current_dir: directory name missing from call";

  opendir ANYDIR, "$dir_name"
    or die "new_current_dir: unworkable directory name '${dir_name}' received";

  @files = grep( !/^([.]|[.][.])/, readdir ANYDIR );

  closedir ANYDIR;

  &new_current_dir_name( "$dir_name" );
}

sub no_current_dir
{
  my $reason_for_none = shift
    or die "no_current_dir: no reason parameter received";

  &no_current_dir_name( "$reason_for_none" );

  foreach $action_button ( @action_buttons )
  {
    $action_button->configure( -state => "disabled" );
  }
}

sub no_current_file_name
{
  $file_name = "";

  $current_file_name_l->destroy()
    if Tk::Exists( $current_file_name_l );

  $current_file_name_l = $controls_f->Label
  (
    -text             => "File name: (no file chosen)",
    -font             =>                   "$the_font",
    -background       =>                    "darkblue",
    -foreground       =>                       "white",
  )->pack
  (
    -after            =>                       $done_b,
    -side             =>                      "bottom",
    -anchor           =>                      "center",
    -expand           =>                             1,
    -fill             =>                           "x",
    -padx             =>                             2,
    -pady             =>                             2,
  ) or die
    "could not create and pack 'no current file name' label";
}

sub no_current_file
{
  &no_current_file_name();

  foreach $action_button ( @action_buttons )
  {
    $action_button->configure
    (
      -state => "disabled"
    );
  }

  &no_current_picture();
}

sub new_current_file_name
{

  my $filename = shift
    or die
    "new_current_file_name: no new current file name parameter received";

  $current_file_name_l->destroy()
    if Tk::Exists($current_file_name_l);

  $current_file_name_l = $controls_f->Label
  (
    -text             =>  "$filename",
    -font             =>  "$the_font",
    -background       => "dodgerblue",
    -foreground       =>      "black",
  )->pack
  (
    -after            =>      $done_b,
    -side             =>     "bottom",
    -anchor           =>     "center",
    -expand           =>            1,
    -fill             =>          "x",
    -padx             =>            2,
    -pady             =>            2,
  ) or die
    "could not recreate and pack current file name label for file "
    . "'$dir_name/$filename'";

}

sub new_current_file
{
  $file_name = shift
    or die "new_current_file: no new current file name parameter received";

  die "new_current_file: directory name not defined for '$file_name'"
    if ( ! $dir_name );

  &new_current_file_name( $file_name );

  &new_current_picture( $dir_name, $file_name );

  foreach my $action_button ( @action_buttons )
  {
    $action_button->configure( -state => "normal" );
  }
}

sub no_current_picture
{

  $the_picture_l->destroy() if Tk::Exists( $the_picture_l );

  $the_picture_l = $picture_f->Label
  (
    -text   => "no picture assigned at this time",
    -font   =>                        "$the_font",
  )->pack
  (
    -anchor =>                           "center",
    -side   =>                             "left",
    -expand =>                                  1,
    -fill   =>                             "both",
  );

}

sub new_current_picture
{
  my ($dirname, $filename, @trash) = @_;

  warn "new_current_picture: not enough parameters received"
    if ! $filename;
  warn "new_current_picture: trash passed beyond expected parameters"
    if @trash;

  $the_picture_l->destroy() if Tk::Exists( $the_picture_l );

  if ( $filename =~ m/\.jpg/ )
  {

    warn "new_current_picture: array args not defined"
      if ! defined( @args );
 
#    I'd _love to do this, since without it memory use grows
#    without bound, but Tk::Exists is wrong, $image isn't a
#    normal Tk object, and invoking its destroy() method
#    destroys the program rather than the object.  This may
#    be a bug, or it may be a feature, but it sure is an
#    inconvenience in either case!

#    $image->destroy() if Tk::Exists( $image);

#    Let's try this, instead: treat it like a normal reference.
#    Orphaning the referenced data; perhaps now the
#    garbage collector will notice and help us out?

#    undef $image if defined( $image );

#    No joy, plus that one invoked a fairly fast memory leak in
#    the window manager.  Sigh.

    $image =
      $mw->Photo
      (

        # "format" is a Perl reserved word, so we quote it here
        # in its Tk::JPEG usage as a flag name.

        '-format' =>               'jpeg',
        -file     => "$dirname/$filename",
        @args,
      ) or die
        "new_current_picture: image creation failed for '$dirname/$filename'";

    $the_picture_l = $picture_f->Label
    (
      -image  => $image,
    )->pack
    (
      -anchor =>   "nw",
      -side   => "left",
      -expand =>      1,
      -fill   => "both",
    );
  }
  elsif ( $filename =~ m/\.gif/ )
  {
    $image =
      $mw->Photo
      (

        # "format" is a Perl reserved word, so we quote it here
        # in its Tk::JPEG usage as a flag name.

        '-format' =>               'gif',
        -file     => "$dirname/$filename",
        @args,
      ) or die
        "new_current_picture: image creation failed for '$dirname/$filename'";

    $the_picture_l = $picture_f->Label
    (
      -image  => $image,
    )->pack
    (
      -anchor =>   "nw",
      -side   => "left",
      -expand =>      1,
      -fill   => "both",
    );
  }
  else
  {
    $the_picture_l = $picture_f->Label
    (
      -text => "unrecognized picture filename tag in '$dirname/$filename'",
    )->pack
    (
      -anchor =>   "center",
      -side   =>     "left",
      -expand =>          1,
      -fill   =>        "x",
    );
  }

}

sub do_action
{
  print qq(@_), "\n";
  `@_` if qq(@_) !~ /^#/;
}

sub delete_body
{
  $action = "rm $dir_name/$file_name";
  &do_action( qq($action) );
  &next_file( "('$dir_name' complete )" );
}

sub leave_as_is_body
{
  $action = "# leaving $dir_name/$file_name alone";
  &do_action( qq($action) );
  &next_file( "('$dir_name' complete )" );
}

sub next_file
{
  my $reason_to_fail = shift or die "next_file: no reason given";

  if ( 0 + @files )
  {
    &new_current_file( shift @files );
  }
  else
  {
    &no_current_dir( "$reason_to_fail" );
    &no_current_file();
  }
}

sub from_where_body
{
  my $some_button_name = shift or die "from_where_body: no button name input";

  &new_current_dir( "$some_button_name" );

  $action = "# took " . ( 0 + @files ). " images from '$some_button_name' a.k.a. '$dir_name'";
  &do_action( qq($action) );
  &next_file( "(empty directory)" );
}

sub do_what_body
{

  my $some_button_name = shift or die "do_what_body: no button name input";
  
  $action = "mv $dir_name/$file_name .$some_button_name";
  &do_action( qq($action) );

  &next_file( "('$dir_name' complete)" );

}

###################################################################
# Special callback constructor subroutines for repetitive callbacks
###################################################################

# Note that the stuff inside the "-command" parts have very limited
# visibility of the _current_when_called_back_ value of outside
# variables, so most of the implementation of the command bodies is
# done by helper subroutines, declared above.

sub make_from_where_button
{

  my $any_button_name = shift
    or die "make_from_where_button: no button name received";

  $any_button = $from_where_f->Button
  (
    -text    => "$any_button_name",
    -font    =>        "$the_font",
    -command =>                sub
    {
      &from_where_body("$any_button_name");
    },
  )->pack
  (
    -anchor  =>                "e",
    -expand  =>                  1,
    -fill    =>                "x",
  ) or die
    "could not create and pack 'from where' button '$any_button_name'";

  return $any_button;
}

sub make_do_what_button
{

  my $any_button_name = shift
    or die
    "make_do_what_button: no button name received";

  $any_button  = $do_what_f->Button
  (
    -text    => "move to $any_button_name",
    -font    =>                "$the_font",
    -command =>                       sub
    {
      &do_what_body( "$any_button_name" );
    },
  )->pack
  (
    -anchor  =>                        "e",
    -expand  =>                          1,
    -fill    =>                        "x",
  );
  return $any_button;
}

#################
# Main Processing
#################

#--------------------------------------------------------------
# set up a main window widget based on the perceptible features
# of the hardware graphics environment, in one of a couple of
# variant ways.
#--------------------------------------------------------------

# stolen from example code in the distribution

$mw = MainWindow->new();  

# We print this bit to standard error, because every standard output
# emmission from this script is in format suitable for incorporation
# into a shell script, not a big surprise, since earlier versions of
# this program just created a shell script for later execution, as a
# more conservative alternative to executing the commands on the fly
# interactively while bugs were being removed and features added.

print STDERR "vis=",$mw->visual," d=",$mw->depth,"\n";

($vis) = grep(!/\b8\b/,grep(/truecolor/,$mw->visualsavailable)); 

@args = ();

if ($vis)                                                       
{
  print $vis,"\n";

  $mw = MainWindow->new(-visual => $vis)
    or die
    "unable to recreate main window with -visual entry";
}                                                                  
else
{
  @args = (-palette => '4/4/4');
}

# $mw_title =
$mw->title
(
  "image reviewer and refiler"
)
# or die "unable to assign main window title"
;

#-----------------------------------------------------
# Set up a main control frame, its top line label, and
# an exit button for the main window, and thus the
# whole program.
#-----------------------------------------------------

$controls_f = $mw->Frame
(
)->pack
(
  -side => "left",
  -anchor => "nw",
) or die "unable to create and pack controls frame";

$controls_frame_l = $controls_f->Label
(
  -text => "Image Reviewer and Refiler",
  -font =>                  "$the_font",
)->pack
(
  -side   => "top",
  -anchor =>   "n",
) or die "could not create and pack controls frame label";

$done_b = $controls_f->Button
(
  -text             =>        "Done",
  -font             =>   "$the_font",
  -background       =>   "limegreen",
  -foreground       =>       "black",
  -activebackground =>       "green",
  -activeforeground =>       "white",
  -command          => sub
  {
    $mw->destroy() if Tk::Exists($mw);
    exit(0);
  },
)->pack
(
  -side   => "bottom",
  -anchor => "center",
  -expand =>        1,
  -fill   =>      "x",
) or die "could not create and pack Done button";

#------------------------------------------------------------
# Set up a frame internal to the main controls frame, a stack
# of buttons on the left telling from which directory to
# fetch and process the next list of image file names.
#------------------------------------------------------------

$from_where_f = $controls_f->Frame
(
)->pack
(
  -side => "left",
  -anchor => "nw",
) or die "could not create and pack 'from where' frame";

#-------------------------------------------------------------
# Set up a frame internals to the main controls frame, a stack
# of buttons on the right providing actions to apply to each
# image's source file, move to a different directory, leave
# alone, or delete.
#-------------------------------------------------------------

$do_what_f = $controls_f->Frame
(
)->pack
(
  -side   => "right",
  -anchor =>    "ne",
) or die "could not create and pack 'do what' frame";

#--------------------------------------------------------------
# Set up a picture frame to hold the image, to the right of the
# controls frame.
#--------------------------------------------------------------

$picture_f = $mw->Frame
(
)->pack
(
  -side   =>  "right",
  -anchor => "center",
) or die "could not create and pack picture frame initially";

#------------------------------------------------------
# Label the left side control button stack, at the top.
#------------------------------------------------------

$from_where_f->Label
(
  -text   => "Take\nImages\nFrom\nWhere?",
  -font   =>                  "$the_font",
)->pack
(
  -side   => "top",
  -anchor =>   "n",
) or die "could not create and pack label for 'from where' frame";

#------------------------------------------------------------------
# Create repetitively the callback buttons to denote, access, and
# create files lists from  the image file source directories, using
# a helper constructor subroutine, above.
#------------------------------------------------------------------

$fw_ap_b    = &make_from_where_button( "ap"    );
$fw_bb_b    = &make_from_where_button( "bb"    );
$fw_bj_b    = &make_from_where_button( "bj"    );
$fw_bt_b    = &make_from_where_button( "bt"    );
$fw_ca_b    = &make_from_where_button( "ca"    );
$fw_cl_b    = &make_from_where_button( "cl"    );
$fw_cs_b    = &make_from_where_button( "cs"    );
$fw_dt_b    = &make_from_where_button( "dt"    );
$fw_fc_b    = &make_from_where_button( "fc"    );
$fw_fu_b    = &make_from_where_button( "fu"    );
$fw_ks_b    = &make_from_where_button( "ks"    );
$fw_lk_b    = &make_from_where_button( "lk"    );
$fw_lz_b    = &make_from_where_button( "lz"    );
$fw_mf_b    = &make_from_where_button( "mf"    );
$fw_nu_b    = &make_from_where_button( "nu"    );
$fw_sh_b    = &make_from_where_button( "sh"    );
$fw_sp_b    = &make_from_where_button( "sp"    );
$fw_te_b    = &make_from_where_button( "te"    );
$fw_tf_b    = &make_from_where_button( "tf"    );
$fw_tp_b    = &make_from_where_button( "tp"    );
$fw_mixed_b = &make_from_where_button( "mixed" );

#-------------------------------------------------------
# Label the right side control button stack, at the top.
#-------------------------------------------------------

$do_what_f->Label
(
  -text   => "Do\nWhat\nWith\nImage?",
  -font   =>              "$the_font",
)->pack
(
  -side   =>                    "top",
  -anchor =>                      "n",
);

#------------------------------------------------------------------
# Create repetitively the callback buttons to do the similarly
# implemented "move to new directory" per-file action buttions for
# the right-side control button frame using # a helper constructor
# subroutine, above.  Push the handles to a list, so that they
# can be easily disabled en masse when no file name is currently
# defined.
#------------------------------------------------------------------

push @action_buttons, $dw_ap_b    = &make_do_what_button( "ap"    );
push @action_buttons, $dw_bb_b    = &make_do_what_button( "bb"    );
push @action_buttons, $dw_bj_b    = &make_do_what_button( "bj"    );
push @action_buttons, $dw_bt_b    = &make_do_what_button( "bt"    );
push @action_buttons, $dw_ca_b    = &make_do_what_button( "ca"    );
push @action_buttons, $dw_cl_b    = &make_do_what_button( "cl"    );
push @action_buttons, $dw_cs_b    = &make_do_what_button( "cs"    );
push @action_buttons, $dw_dt_b    = &make_do_what_button( "dt"    );
push @action_buttons, $dw_fc_b    = &make_do_what_button( "fc"    );
push @action_buttons, $dw_fu_b    = &make_do_what_button( "fu"    );
push @action_buttons, $dw_ks_b    = &make_do_what_button( "ks"    );
push @action_buttons, $dw_lk_b    = &make_do_what_button( "lk"    );
push @action_buttons, $dw_lz_b    = &make_do_what_button( "lz"    );
push @action_buttons, $dw_mf_b    = &make_do_what_button( "mf"    );
push @action_buttons, $dw_nu_b    = &make_do_what_button( "nu"    );
push @action_buttons, $dw_sh_b    = &make_do_what_button( "sh"    );
push @action_buttons, $dw_sp_b    = &make_do_what_button( "sp"    );
push @action_buttons, $dw_te_b    = &make_do_what_button( "te"    );
push @action_buttons, $dw_tf_b    = &make_do_what_button( "tf"    );
push @action_buttons, $dw_tp_b    = &make_do_what_button( "tp"    );
push @action_buttons, $dw_mixed_b = &make_do_what_button( "mixed" );

#-----------------------------------------------------------------
# Separately create and push to the action button stack the "leave
# as is" action button.  Even this one must be disabled when no
# file name is currently selected.
#-----------------------------------------------------------------

push @action_buttons, $dw_leave_as_is_b = $do_what_f->Button
(
  -text    => "leave as is",
  -font    =>   "$the_font",
  -command => sub
  {
    &leave_as_is_body();
  }
)->pack
(
  -anchor => "e",
  -expand =>   1,
  -fill   => "x",
);

#------------------------------------------------------------------
# Separately create and push to the action button stack the "delete
# the image file" action button.  Even this one must be disabled
# when no file name is currently selected.
#-----------------------------------------------------------------

push @action_buttons, $dw_delete_b = $do_what_f->Button
(
  -text             =>    "delete",
  -font             => "$the_font",
  -background       =>   "hotpink",
  -foreground       =>     "black",
  -activebackground =>       "red",
  -activeforeground =>     "white",
  -command          => sub
  {
    &delete_body();
  },
)->pack
(
  -anchor => "e",
  -expand =>   1,
  -fill   => "x",
);

#---------------------------------------------------------------
# Create the current picture, current file and current directory
# entities with the appropriate "no current selection" semantics
# and information label contents.
#---------------------------------------------------------------

&no_current_file();

&no_current_dir("(none chosen yet)");

&no_current_picture();

#-------------------------------------------------------------------
# Start the main Tk processing loop.  From here on, everything that
# happens is triggered by a button callback and modified as needed
# by internal triggers such as "file list empty", "directory empty",
# or "image invalid".
#-------------------------------------------------------------------

MainLoop;