@rem = ' vi:syntax=perl
@echo off
perl -x -S %0 %*
goto endofperl
@rem ';
#!perl
#line 8


# some config vars:

my $geom = '1280x1024'; # initial window width x height
my $unzip = "c:\\sw\\GnuWin32\\bin\\unzip.exe"; #"c:\\Program Files\\G
+nuWin32\\bin\\unzip.exe";

# Version: 2009-04-26

use Tk;
use Tk::JPEG;
use Tk::Pane;
use Tk::BrowseEntry;
use Tk::DialogBox;
use File::Find;
use List::Util;
use File::stat;
use XML::Simple;
use Getopt::Long;
use Data::Dumper;
use Carp;
eval { require File::Wildcard::Find };
use strict;
use warnings;

sub Gui_mw { }

{
    package BrowseEntryDialog;

=pod  Example:

my $bed = BrowseEntryDialog->new(
    'Enter Filter Code',
    sub { warn "Doing '$_[0]'\n" },
);
$bed->update( @preload ) if @preload;

$mw->Button( -text => 'Filter', -command => sub { $bed->popup } )->pac
+k;

=cut

    # inside-out
    my %be;
    my %dg;
    my %cb;

    sub new
    {
        my $pkg = shift;
        my $mw = shift;
        my $dlg_lbl = shift;
        my $cb = shift;
        my $d = $mw->DialogBox( -title => $dlg_lbl, -buttons => [qw( O
+K Cancel )] );
        $d->bind( '<Escape>', sub { $d->Subwidget('B_Cancel')->invoke 
+} );
        my $f = $d->add('Frame')->pack( -expand => 1, -fill => 'both' 
+);
        my $b = $f->BrowseEntry( -choices => [@_], -buttontakefocus =>
+ 1, -width => 80 )->pack;
        $b->Subwidget('entry')->configure( -validate => 'none' );
        my $self = bless {}, $pkg;
        $be{$self} = $b;
        $dg{$self} = $d;
        $cb{$self} = $cb;
        $self
    }

    # if it's not already in the list, adds it at the top.
    # if it is, it pulls it out of line and moves it to the top. (MRU)
    sub update
    {
        my( $self, @vals ) = @_;
        my %vals; @vals{@vals} = ();
        my $ar = $be{$self}->cget('-choices');
        @$ar = ( @vals, grep { not exists $vals{$_} } @$ar );
        $be{$self}->configure( -choices => $ar );
        $self
    }

    sub popup
    {
        my $self = shift;
        $be{$self}->Subwidget('entry')->focus;
        if ( $dg{$self}->Show eq 'OK' )
        {
            my $sr = $be{$self}->cget('-variable');
            my $foo = $$sr;
            eval {
                # True indicates failure.
                $cb{$self}->($foo) or
                $self->update($foo);
            };
        }
    }
}

{
    # XXX Windows specific!
    local $_ = `assoc .jpg`;
    my( $assoc ) = /=(.*)$/;
    $_ = `ftype $assoc`;
    my( $command ) = /=(.*)$/;
    sub external_edit
    {
        my $fname = shift;
        $fname =~ s/\//\\/g;
        my $cmd = $command;
        $cmd =~ s/%1/$fname/;
warn "system => $cmd\n";
        system $cmd;
    }
}



# WSH for manipulating Windows shortcuts:

my $on_Windows = ( $^O =~ /mswin/i );
if ( $on_Windows )
{
    require Win32::OLE;
    Win32::OLE->import;
    Win32::OLE->Option(Warn => 0);
    my $wsh;
    sub wsh() { $wsh ||= new Win32::OLE 'WScript.Shell' }
}


{ # begin symlink-related stuff

my %from_symlink; # { realpath, symlink }

sub create_symlink($) # can THROW EXCEPTIONS
{
    my( $target_path ) = @_;
    my $lnk_path = $target_path;
    $lnk_path =~ s#.*[\\/]##; # to be created in cwd

    if ($on_Windows)
    {
        $lnk_path = "Shortcut to $lnk_path.lnk";

        $target_path =~ s#/#\\#g;
        $target_path =~ /^[a-z]:\\/i or die(
            "invalid target path '$target_path' - Must be absolute!\n"
+ ), return();

        my $shcut = wsh()->CreateShortcut($lnk_path) or die(
            qq(Error creating symlink named "$lnk_path"\n) ), return()
+;

        $shcut->{'TargetPath'} = $target_path;
# 'Arguments' is a string appended to the actual target path field:
# $shcut->{'Arguments'} = "-w 640 -h 480";
# 'Description' is shown as the "Comments:" field in the Shortcut Prop
+erties window:
$shcut->{'Description'} = "Foo! Bar!";
# these two could be useful, but are NOT automatically set when
# TargetPath is set:
# $shcut->RelativePath 
# $shcut->WorkingDirectory 
        $shcut->Save;
        -e $lnk_path or die( qq(Failed to create symlink "$lnk_path") 
+), return();
    }
    else
    {
        warn "symlinks not yet supported on non-Windows platforms. :-(
+\n";
    }

    # now we know this file as symlinked. Useful in case we want
    # to delete the symlink during the same session.
    warn qq(Remembering symlink "$target_path" => "$lnk_path"\n);
    $from_symlink{lc $target_path} = $lnk_path;

    $lnk_path # a success message
}
sub remove_symlink
{
    my $file = shift;
    $file =~ s#/#\\#g;
    if ( $from_symlink{lc $file} )
    {
        if ( unlink $from_symlink{lc $file} )
        {
            warn qq(Forgetting symlink "$file" => "$from_symlink{lc $f
+ile}"\n);
            delete $from_symlink{lc $file};
        }
        else
        {
            alert( qq(Error trying to unlink symlink "$from_symlink{lc
+ $file}" => "$file" : $!\n) );
        }
    }
    else
    {
        alert( "Ctrl-Del means nothing unless the file was loaded via 
+a symlink/shortcut!\n($file)\n" );
    }
}
sub real_path($)
{
    #Carp::confess "real_path(@_)\n";
    my $path = shift;
    my $shcut;
    if ( $on_Windows )
    {
        $shcut = wsh()->CreateShortcut($path);
    }
    # non-Windows not yet supported
    $shcut or return $path;
    my $realpath = $shcut->TargetPath;
    warn qq("$realpath" => "$path"\n);
    $from_symlink{lc $realpath} = $path;
    $realpath
}
sub symlinked($)
{
    my $f = shift;
    $f =~ s#/#\\#g;
    exists $from_symlink{lc $f}
}

} # end symlink-related stuff.




{
my $tmpdir;
sub expand_zip_files
{
    my $files_ar = shift; # \@files

    unless ( $tmpdir )
    {
        my $dir = "tmp.$$";
        while ( -e $dir and !-d $dir ) { warn "Can't use $dir; trying 
+${dir}a ...\n"; $dir .= 'a' }
        -d $dir or mkdir $dir or return alert( "Failed to create tmp d
+ir $dir - $!" );
        $tmpdir = $dir;
    }

    my $suck_tmpdir;
    my @f = map {
        if ( /\.zip$/i )
        {
            system $unzip, $_, '-d', $tmpdir
                and exit alert( "unzip seems to have failed" );
            $suck_tmpdir = 1;
            ();
        }
        else
        {
            $_
        }
    } @$files_ar;

    $suck_tmpdir and push @f, glob "$tmpdir/*";

    @$files_ar = @f; # only update the list if everything went OK
}
END {
    if ( defined $tmpdir )
    {
        system qq(rmdir /s /q "$tmpdir") and 
            warn qq(rmdir /s /q "$tmpdir" seems to have failed!);
        -e $tmpdir or warn "\nCleaned up.\n";
        undef $tmpdir;
    }
}
}

{
# this is the "List" pseudo-package / singleton object.

my @files;
my $ii = -1; # image index
my $slideshow_file;

sub List_slideshow_filename() { $slideshow_file }
sub List_count() { scalar @files }
sub List_current_item() { @files && $ii >= 0 ? $files[$ii] : undef }
sub List_current_item_seqno() { $ii+1 } # this is a 1-based index.
sub List_remove_current_item() {
    @files && $ii >= 0 or return;
    splice @files, $ii, 1;
    $ii > $#files and $ii =0;
}

sub List_initialize_from_file
{
    my $file = shift;
    $file =~ s#\/#\\#g if $on_Windows; # XXX
    my $ds = XMLin $file;
    $ds or return alert("Error opening $file !!!");
    $slideshow_file = $file;
    bless $_, 'FileItem' for @{ $ds->{'item'} };
    @files = @{ $ds->{'item'} };
}

# unceremoniously dumps the previous contents of @files onto the groun
+d.
sub List_initialize_from_filenames
{
    expand_zip_files( \@_ );
    my $n_before = @_;
    @files = map FileItem->new_from_filename($_), @_;
    my $n_after = @files;
    my $n_failed = $n_before - $n_after;
    $n_failed and alert("Looks like $n_failed of the $n_before files s
+pecified did not pass the image validator.");
    undef $slideshow_file;
}
sub List_add_from_filenames
{
    expand_zip_files( \@_ );
    push @files, map FileItem->new_from_filename($_), @_;
    # should probably remove dups.
}

sub List_set_index_0 { $ii = 0; }
sub List_advance_index { $ii = ( $ii + @files - 1 ) % @files; }
sub List_retreat_index { $ii = ( $ii + 1 ) % @files; }

sub List_count_selected() { scalar( grep { $_->is_selected } @files ) 
+}
sub List_get_selected() { grep { $_->is_selected } @files }
sub List_clear_selection() { $_->unselect for @files }
sub List_invert_selection() { $_->toggle_selection_state() for @files 
+}
sub List_set_no_current_item { $ii = -1 }
sub List_set_current_item
{
    my $obj = shift;
    $ii = 0;
    for ( my $i = 0; $i <= $#files; $i++ )
    {
        $files[$i] eq $obj and $ii = $i;
    }
}

sub List_for_each
{
    my $code = shift; # remaining args will be passed
    
    wantarray and
        return map { ref $code ? $code->( $_, @_ ) : $_->$code( @_ ) }
+ @files;

    my $n;
    if ( ref $code )
    {
        $n += !!$code->( $_, @_ ) for @files;
    }
    else # assume it's a method name
    {
        $n += !!$_->$code( @_ ) for @files;
    }
    $n;
}

sub List_filter
{
    my $func = shift;
    @files = $func->( @files );
}

# notice that in the resulting XML, the first line (<list>) has a lead
+ing space,
# the <item> lines have a leading tab, and the last line has the < in 
+the first column.
# this has the effect that when passed through sort, the first line st
+ays first
# and the last line stays last.
sub List_as_xml
{
    local $_ = XMLout \@files;
# may need to handle the possibility of the XML having newlines within
+ each 'record'.
    s/opt>$/list>/mg;
    s/(<list)/ $1/;
    s/^\s*<anon/\t<item/mg;
    $_
}

}

# here's the (real) class for items of the list.
{
package FileItem;

use Image::ExifTool 'ImageInfo';
use Data::Dumper;

sub new_from_filename
{
    my $pkg = shift;
    my $filename = shift;

    my $self = ImageInfo( $filename, qw(
        Comment
        FileModifyDate
        FileName
        FileSize
        ImageHeight
        ImageWidth
        Error
    ));
    bless $self, $pkg;

        $self->{'Error'} and warn("$filename: Error: $self->{'Error'}\
+n"), return();

    $self->{'FileSize'} =~ s/mb/000000/i;
    $self->{'FileSize'} =~ s/kb/000/i;
    $self->{'FileSize'} =~ s/b//i;

    $self->{'filename'} = $filename;

    $self->sanitize_datamembers;
    $self
}

    sub sanitize_property_name_and_value
    {
        my( $self, $name, $value ) = @_;
        for ( $name )
        {
            s/ \((.+)\)$/_$1/;
            s/[^0-9a-zA-Z_:]+/_/g;
        }
        for ( $value )
        {
            s/[^\x20-\x7E]/ /g;
            s/"/'/g;
            s/\s+/ /g;
            s/\s+$//;
        }
        ( $name, $value )
    }

sub sanitize_datamembers
{
    my $self = shift;
    %$self = map {
        $self->sanitize_property_name_and_value( $_, $self->{$_} )
    } keys %$self;
    $self
}

sub as_string
{
    my $self = shift;
    local $Data::Dumper::Indent = 1;
    local $Data::Dumper::Terse = 1;
    local $Data::Dumper::Quotekeys = 0;
    my @a = split /\n/, Dumper($self);
    pop @a; shift @a;
    s/,$// for @a;
    s/'$// for @a;
    s/ => '/: / for @a;
    s/ => /: / for @a;
    join "\n", sort @a;
}

sub show_info
{
    my $self = shift;
    if ( ::Gui_mw() )
    {
        ::alert( $self->as_string );
    }
    else
    {
        warn $self->as_string;
    }
}

sub name
{
    my $self = shift;
    $on_Windows
        ? lc( $self->{'filename'} )
        : $self->{'filename'}
}

sub set_as_current
{
    my $self = shift;
    ::List_set_current_item( $self );
    $self
}

sub set_properties
{
    my( $self, $hr ) = @_;
    $self->{$_} = $hr->{$_} for keys %$hr;
    $self
}
sub property
{
    my( $self, $propname ) = @_;
    $self->{$propname}
}

sub set_scrolledto
{
    my $self = shift;
    $self->{'scrolledto_x'} = shift;
    $self->{'scrolledto_y'} = shift;
    $self
}
sub scrolledto_x
{
    exists $_[0]{'scrolledto_x'} ? $_[0]{'scrolledto_x'} : 0.5
}
sub scrolledto_y
{
    exists $_[0]{'scrolledto_y'} ? $_[0]{'scrolledto_y'} : 0.5
}

sub set_scalefactor
{
    my( $self, $sf ) = @_;
    $self->{'scale_factor'} = $sf;
    $self
}
sub scalefactor
{
    my( $self ) = @_;
    $self->{'scale_factor'} || 0
}

sub is_selected
{
    my $self = shift;
    $self->{'selected'} 
}
sub select
{
    my $self = shift;
    $self->{'selected'} = 'selected';
    $self
}
sub unselect
{
    my $self = shift;
    delete $self->{'selected'};
    $self
}
sub toggle_selection_state
{
    my $self = shift;
    $self->is_selected ? $self->unselect : $self->select
}

# List_current_item()->update_pos( Gui_scrolled()->xview, Gui_scrolled
+()->yview );
sub update_pos
{
    my( $self, $xlo,$xhi, $ylo,$yhi ) = @_;
    # these are all normalized to the current size of the image [0,1]
    # that is, when the image exactly fits in the viewport,
    # lo=0 and hi=1.
    #my($xlo,$xhi) = Gui_scrolled()->xview;
    #my($ylo,$yhi) = Gui_scrolled()->yview;
    $self->set_scrolledto( ( $xhi + $xlo ) / 2, ( $yhi + $ylo ) / 2 );
}

} # end of package FileItem






sub initialize_data_structures
{
my $read_from_stdin; # -i means get specs from stdin, NOT from cmdline
my $initial_scalefactor;
my @initial_commands; # those which affect the loaded data, principall
+y the list.
my @postinit_commands; # those which affect the gui, e.g. call GUI com
+mands
my $slideshow_file;
my $slideshow_dir;
my $use_File_Wildcard;
my $directory_recursion_depth; # undef means unlimited.
$::auto_advance_time = 2000; # milliseconds


=pod

These are the commands which it might make some sense to allow "callin
+g" via commandline switches:

Edit_order_by_file_name
Edit_order_by_file_size
Edit_order_random
Edit_order_reverse
File_open
File_print_to_stdout
File_save_as
File_write_batch_copier_onto_clipboard
File_write_onto_clipboard

=cut


GetOptions(
    'input|stdin!' => \$read_from_stdin,
    'iconified|iconify|iconized!' => \$::begin_iconified,
    'destination=s' => \$::dest_dir,
    'file=s' => \$slideshow_file,
    'directory|folder=s' => \$slideshow_dir,
    'recurse|recursion_limit=i' => \$directory_recursion_depth,

    # initial commands: those which affect the loaded data, principall
+y the list:
    'scale|factor=i' => sub { my $scale = pop; push @initial_commands,
+ sub { List_for_each( set_scalefactor => $scale ) } },
    'grep=s' => sub { my $code = pop; push @initial_commands, sub { ru
+n_custom_filter('grep',$code) } },
    'sort=s' => sub { my $code = pop; push @initial_commands, sub { ru
+n_custom_filter('sort',$code) } },

    # commands which can't be run until after the gui is initialized:
    'exit!' => sub { push @postinit_commands, \&File_exit },
    'auto!' => sub { push @postinit_commands, \&View_start_slideshow }
+,
    'first!' => sub { push @postinit_commands, \&View_first },
    'byname!' => sub { push @postinit_commands, \&Edit_order_by_file_n
+ame },
    'bysize!' => sub { push @postinit_commands, \&Edit_order_by_file_s
+ize },
    'random!' => sub { push @postinit_commands, \&Edit_order_random },
);

# note that any post-init commands on the commandline *after* --exit w
+ill never get executed!

# Changed: No longer reads from cwd by default.
# You must now specify the files/folders you want to read, explicitly 
+- even the cwd (.).

my @args = grep {
    chomp;
    s/\s*#.*//; # kill comments
    s,\\,\/,g; # XXX system specific!
    /\S/
} $read_from_stdin ? <> : @ARGV;

my $slideshow_on_disk_type; # value will be a keyword string, one of: 
+'xml', 'symlinks',

defined $slideshow_file &&
defined $slideshow_dir and exit
    alert("You can't specify both a slideshow file AND a slideshow dir
+ectory, Silly!");

if ( defined $slideshow_file )
{
    -e $slideshow_file && !-f $slideshow_file and exit
        alert("$slideshow_file exists but is not a file!");

    if ( -e $slideshow_file )
    {
        warn "reading list from XML file $slideshow_file\n";
        # attempt to load the file as XML
        List_initialize_from_file( $slideshow_file );
        $slideshow_on_disk_type = 'xml';
    }
    else # doesn't exist yet. Don't try to read it now, but remember i
+t for later.
    {
    }
}

if( defined $slideshow_dir )
{
    -e $slideshow_dir && !-d $slideshow_dir and exit
        alert("$slideshow_dir exists but is not a directory!");

    if ( -e $slideshow_dir ) # exists a directory already
    {
        warn "Using $slideshow_dir as directory of symlinks\n";
        # first, assert that the folder contains no files of any type 
+other than symlink
exit alert( "Not implemented yet!" );
        $slideshow_on_disk_type = 'symlinks';
    }
    else # doesn't exist yet. Don't try to read it now, but remember i
+t for later.
    {
    }
}

# now handle filespecs from the commandline:

if ( @args ) # filespecs
{
    $use_File_Wildcard &&= grep /File.Wildcard.Find/, keys %INC; # can
+'t use it if it hasn't been loaded.

    my @filenames;
    if ( $use_File_Wildcard )
    {
        #warn "using File::Wildcard::Find\n";
        @filenames =
            map File::Wildcard->new(
                path => $_,
                case_insensitive => 1,
                follow => 1,
                ellipsis_order => 'breadth-first',
                sort => 1,
                debug => 0,
            )->all, @args;
    }
    else
    {
        warn "\nusing glob\n\n";
        @filenames =
            #map { real_path($_) } # resolves symlinks/shortcuts
            map { glob( /\s/ ? qq("$_") : $_ ) }
            @args;
    }

    if ( @filenames )
    {
        while ( !defined($directory_recursion_depth) or $directory_rec
+ursion_depth-- )
        {
            my $n_dirs_expanded;
            @filenames = map {
                -d $_ ? do { $n_dirs_expanded++; glob( /\s/ ? qq("$_/*
+") : qq($_/*) ) } : $_
            } @filenames;
            $n_dirs_expanded or last;
        }

        if ( List_count() )
        {
            my $choice = choice_prompt(
                -title => 'List Spec Conflict',
                -text => "There is already a slideshow resident, but y
+our commandline args have specified ".@filenames." other files.\nWhat
+ do you want to do?",
                -buttons => [
                    "Add spec'd files to the current slideshow",
                    "Replace current slideshow contents with spec'd fi
+les",
                    "Discard the list of spec'd files",
                ],
            );
            defined $choice or exit alert( "BOGUS!  choice_prompt() re
+turned undef!" );
            if ( $choice =~ /^A/ )
            {
                List_add_from_filenames( @filenames );
            }
            elsif ( $choice =~ /^R/ )
            {
                List_initialize_from_filenames( @filenames );
            }
        }
        else
        {
            List_initialize_from_filenames( @filenames );
        }
    }
    else
    {
        alert("You gave some filespecs on the commandline, but no file
+names resulted!");
    }
}


alert( "Loaded ".List_count()." files.\n" );

$_->() for @initial_commands;

*process_postinit_commands = sub { $_->() for @postinit_commands };

} # end initialize_data_structures




{
my $autoadvancing;
my $showimage_timer;
sub clear_showimage_timer
{ 
    Gui_mw() or return;
    Gui_mw()->afterCancel( $showimage_timer );
    $showimage_timer = undef;
}
sub set_showimage_timer
{
    Gui_mw() or return;
    clear_showimage_timer();
    $showimage_timer = Gui_mw()->after( 100, \&show_image );
}

my $autoadvance_timer;
sub start_autoadvancing
{
    Gui_mw() or return;
    stop_autoadvancing();
    $autoadvance_timer = Gui_mw()->after( $::auto_advance_time, sub { 
+View_next(); start_autoadvancing(); } );
    $autoadvancing=1;
}
sub stop_autoadvancing
{
    Gui_mw() or return;
    Gui_mw()->afterCancel( $autoadvance_timer ) if defined $autoadvanc
+e_timer;
    undef $autoadvance_timer;
    $autoadvancing=0;
}
sub Menu_add_autoadvancing_checkbutton
{
    my $menu = shift; # a Menu widget
$menu->checkbutton(
    -label => 'AutoAdvance',
    -command => sub { $autoadvancing ? View_start_slideshow() : View_s
+top_slideshow(); },
    -onvalue => 1,
    -offvalue => 0,
    -variable => \$autoadvancing,
);
}
}



sub Gui_die_die_die
{
    my $mw = Gui_mw() or return;
    $mw->destroy;
    undef $mw;
    no warnings;
    *Gui_mw = sub { };
}

sub Gui_initialize
{
    my $mw = new MainWindow;

    !List_count() and alert( "No files found!\n" );

    $mw->iconify if $::begin_iconified;

    my $menubar = $mw->Menu( -type => 'menubar' );
    $mw->configure( -menu => $menubar );

    my $scrolled = $mw
        ->Scrolled( 'Pane', -scrollbars => 'osoe', ) # -width => 640, 
+-height => 480, )
        ->pack( -expand => 1, -fill => 'both', );

    my $imagit = $scrolled
        ->Label
        ->pack( -expand => 1, -fill => 'both', );

    no warnings;
    *Gui_mw       = sub { $mw };
    *Gui_menubar  = sub { $menubar };
    *Gui_scrolled = sub { $scrolled };
    *Gui_imagit   = sub { $imagit };


# create menu and other bindings:



    my $commands_config = <<EOF;

File    Open    File_open    Control-KeyPress-o
File    Save as...    File_save_as    KeyPress-s
File    Print to stdout    File_print_to_stdout    KeyPress-l
File    List on Clipboard    File_write_onto_clipboard    KeyPress-c
File    Batch Copier on Clipboard    File_write_batch_copier_onto_clip
+board    KeyPress-b
File    ~Exit    File_exit    KeyPress-q    Escape

# a bunch of things for altering the order of the list.
Edit    Order by file name    Edit_order_by_file_name    KeyPress-F3
Edit    Order by file size    Edit_order_by_file_size    KeyPress-F4
Edit    Randomize the order    Edit_order_random    KeyPress-F5
Edit    Reverse the order    Edit_order_reverse    KeyPress-F6
Edit    custom grep    grep_bed_popup    KeyPress-G
Edit    custom sort    sort_bed_popup    KeyPress-S
Edit    Select/unSelect current image    Edit_current_toggle_selection
+    space
Edit    Remove current element from list    Edit_remove_current    Del
+ete
# this originally had KeyPress-r associated with it:
Edit    Remove selected    Edit_remove_selected
Edit    Remove unselected    Edit_remove_unselected

View    Go to first image    View_first    KeyPress-0
View    Previous    View_prev    Prior
View    Next    View_next    Next
View    --------
View    Zoom In    View_zoom_in    KeyPress-plus    KeyPress-=
View    Zoom Out    View_zoom_out    KeyPress-minus
View    Up    View_scroll_up    Up
View    Down    View_scroll_down    Down
View    Left    View_scroll_left    Left
View    Right    View_scroll_right    Right
#View    Start Slideshow    View_start_slideshow
#View    Stop Slideshow    View_stop_slideshow

ImageFile    Edit current    ImageFile_edit_current    KeyPress-e
ImageFile    Delete current    ImageFile_delete_current    Control-Del
+ete
ImageFile    Rename current    ImageFile_rename_current
# these should not be menu items, but either command-line switches, or
+ exit-time prompted actions (or both).
#ImageFile    Copy all files to destination directory    ImageFile_cop
+y_all_to_destdir    KeyPress-d
#ImageFile    Create symlink (in current directory) to this imagefile 
+   ImageFile_current_createsymlink
#ImageFile    Create symlinks (in current directory) to all imagefiles
+    ImageFile_all_createsymlinks
ImageFile    View info    ImageFile_view_info

EOF

    for ( split /\n/, $commands_config )
    {
        my( $menu, $label, $funcname, @keysyms ) = split /\t/;
        defined $label or next;
        $menu =~ /^#/ and next;
        $label =~ /^----/ and add_menu_separator($menu), next;
        defined $funcname or next;
        @keysyms
        ? add_command( \&{ $funcname }, $menu, $label, @keysyms )
        : add_menu_command( \&{ $funcname }, $menu, $label );
    }

    Menu_add_autoadvancing_checkbutton( $::Menu{'View'} );


    # other bindings:

    Gui_imagit()->bind( '<Button1-ButtonRelease>' => sub { undef $::la
+st_x } );
    Gui_imagit()->bind( '<Button1-Motion>' => [ \&drag, Ev('X'), Ev('Y
+'), ] );
    Gui_mw()->bind( "<MouseWheel>" => [ sub {
        my( $xscroll, $yscroll ) = Gui_scrolled()->Subwidget( 'xscroll
+bar', 'yscrollbar' );
        if ( $yscroll->ismapped )
        {
            $_[1] > 0 ? View_scroll_up() : View_scroll_down()
        }
#        elsif ( $xscroll->ismapped )
#        {
#            $_[1] > 0 ? View_scroll_left() : View_scroll_right()
#        }
# maybe use button3down to indicate that we want horizontal scrolling.
    }, Ev('D') ] );

    add_event_handler( \&Help, 'KeyPress-F1' );

    # display the keysym of keypresses not otherwise bound:
    Gui_mw()->bind( '<KeyPress>' => [ sub { shift; print "KeyPress = @
+_ \n"; }, Ev('s'), Ev('K'), Ev('k'), ] );

    # if there's ever anything you want to do when the window is resiz
+ed:
    #Gui_mw()->bind( "<Configure>" => [ sub { my(undef,$W,$h,$w)=@_; r
+eturn unless $W == Gui_mw(); %scale_factor=(); }, Ev('W'), Ev('h'), E
+v('w') ] );
    # however, it looks like the <Expose> handler does what we need.


# and start me up!

    Gui_mw()->after( 100, sub {
        process_postinit_commands();
        Gui_mw()->geometry( $geom . '+0+0' ); # set initial width, hei
+ght
        View_first();
    });
    Gui_mw()->bind( '<Expose>' => [ sub { $_[0] == Gui_mw() and show_i
+mage() }, Ev('c'), Ev('h'), Ev('w'), ] );
    warn "\nReady!\n";

} # Gui_initialize.




{ # start of subs

sub Help
{
    alert(<<EOF);
Help!

Menu

Hotkeys

Commandline

EOF
}

sub View_scroll_up    { Gui_scrolled()->yview( scroll => -0.1, 'pages'
+ ); List_current_item()->update_pos( Gui_scrolled()->xview, Gui_scrol
+led()->yview ); }
sub View_scroll_down  { Gui_scrolled()->yview( scroll =>  0.1, 'pages'
+ ); List_current_item()->update_pos( Gui_scrolled()->xview, Gui_scrol
+led()->yview ); }
sub View_scroll_left  { Gui_scrolled()->xview( scroll => -0.1, 'pages'
+ ); List_current_item()->update_pos( Gui_scrolled()->xview, Gui_scrol
+led()->yview ); }
sub View_scroll_right { Gui_scrolled()->xview( scroll =>  0.1, 'pages'
+ ); List_current_item()->update_pos( Gui_scrolled()->xview, Gui_scrol
+led()->yview ); }

sub choice_prompt
{
    my %args = @_; # just as for Tk::DialogBox, i.e. -title and -butto
+ns, but also -text
    my $text = delete $args{'-text'};
    my $response;
    if ( Gui_mw() )
    {
        my $d = Gui_mw()->DialogBox( %args );
        $d->add('Label', -text => $text );
        $response = $d->Show;
    }
    else
    {
        local @ARGV; # so that <> doesn't try to read files.
        my $n;
        print "\n$text\n\n";
READ_NUMBER_INPUT:
        for ( 0 .. $#{ $args{'-buttons'} } )
        {
            print ''.($_+1).") $args{'-buttons'}[$_]\n";
        }
        $n = <>; chomp $n;
        $n =~ /^\d+$/ or goto READ_NUMBER_INPUT;
        $n--;
        $n >= 0 && $n <= $#{ $args{'-buttons'} } or goto READ_NUMBER_I
+NPUT;
        $response = $args{'-buttons'}[$n];
    }
    $response
}

sub alert
{
    if ( Gui_mw() )
    {
        Gui_mw()->messageBox( -message => $_[0],
            -type => 'Ok', -icon => 'warning', -title => 'Warning' );
    }
    else
    {
        warn "$_[0]\n";
    }
    1 # since we often do things like <c> exit alert('...'); </c>
}

sub filter # rearrange the list or remove items from it.
{
    my $func = pop;
    if ( List_current_item() )
    {
        my $current = List_current_item();
        clear_showimage_timer();
        List_filter( $func );
        $current->set_as_current(); # re-find the proper index.
        set_showimage_timer(); # necessary?
    }
    else
    {
        # running this filter before we've begun displaying.
        List_filter( $func );
    }
}

# binds a given command to a key or a menu item.
# the keysym(s) get bound directly to the cmd.
# the menu entry (bound to the cmd) is added to the menu.
sub add_menu_command
{
    my( $cmd, $menu, $label, $accel_string ) = @_;
    $::Menu{$menu} ||= Gui_menubar()->cascade( -label => $menu, -under
+line => 0, -tearoff => 1, );
    $::Menu{$menu}->command( -label => $label, -command => $cmd, defin
+ed($accel_string) ? ( -accelerator => $accel_string ) : () );
    1;
}
sub add_menu_separator
{
    my( $menu, ) = @_;
    $::Menu{$menu} ||= Gui_menubar()->cascade( -label => $menu, -under
+line => 0, -tearoff => 1, );
    $::Menu{$menu}->separator();
    1;
}
sub add_event_handler
{
    my( $cmd, @eventsyms ) = @_;
    Gui_mw()->bind( $_, $cmd ) for map { /^<.*>$/ ? $_ : "<$_>" } @eve
+ntsyms;
}
sub add_command
{
    my( $cmd, $menu, $label, $keysym, @additional_keysyms ) = @_;
# $keysym should be the full keysym spec, NOT including the angle brac
+kets.
    my $accel = $keysym;
    $accel =~ s/KeyPress-//i;
    add_menu_command( $cmd, $menu, $label, $accel );
    add_event_handler( $cmd, $keysym, @additional_keysyms );
}



sub Edit_order_by_file_name
{
# the 'name' method is special, in that it returns a string which is
# case-sensitive or not, depending on the OS.
    filter( sub { sort { $a->name cmp $b->name } @_ } )
}
sub Edit_order_by_file_size
{
    filter( sub { sort { $a->property('FileSize') <=> $b->property('Fi
+leSize') } @_ } )
}
sub Edit_order_random
{
    filter( sub { List::Util::shuffle(@_) } )
}
sub Edit_order_reverse
{
    filter( sub { reverse @_ } )
}


# let the user define a custom filter.
# they have a choice of grep or sort.
# we use string eval on whatever they enter. (Shhh!)
# see the note above about how to grep/sort using the
# info stored in %fileinfo.
sub run_custom_filter
{
    my( $fltyp, $code ) = @_;
    $code =~ s#(\$[ab_])\.(\w+)#$1->property('$2')#g;
    undef $@;
    my $evalcode = "sub { $fltyp {\n$code\n} \@_ }";
    #warn "Will eval this code to create a lambda:\n$evalcode\n";
    my $sub = eval $evalcode;
    unless ( $@ )
    {
        my $before = List_count();
        eval { filter( $sub ); };
        my $after = List_count();
        $fltyp eq 'grep' and warn "$before files before grep, $after f
+iles after.\n";
        $@ or return 0;
    }
    local $_ = $@;
    s/ at \(eval \d+\) line \d+.*//;
    alert( qq(Error:\n  $fltyp {\n    $code\n  }\n$_) );
    1; # failure
}


sub grep_bed_popup
{
    $::grep_bed ||= new BrowseEntryDialog Gui_mw(), "Enter grep code",
+ sub { run_custom_filter( grep => $_[0] ) };
    $::grep_bed->popup;
}
sub sort_bed_popup
{
    $::sort_bed ||= new BrowseEntryDialog Gui_mw(), "Enter sort code",
+ sub { run_custom_filter( sort => $_[0] ) };
    $::sort_bed->popup;
}


=pod

Image scaling here is designed to strike a balance
between not wanting to scroll too much and not
wanting to lose too much resolution by downsampling.
The heuristic is:

1. if the image fits within the scrolled pane in one
or both dimensions (that is, only zero or one scrollbar
would be shown), no downsampling is done.

2. otherwise (i.e. if two scrollbars would be needed),
the downsampling factor is incremented (from 1) until
condition #1 (above) is met.

(Of course, we don't actually increment and check like
that; we calculate the desired factor algebraically.)

This way, when you do have to scroll, it will often be
on one axis only; and the distance you'll have to 
scroll will be minimized (or rather, optimized).

Another approach would be to downsample the picture
sufficiently such that the image always fits entirely
within the pane, and scrolling won't be necessary, but
I'd rather give minimization of resolution loss 
slightly more weight than eliminating the need to scroll.

=cut

    sub factor
    {
        my( $n, $m ) = @_;
        ($n>$m) ? int($n/$m) : 1
    }

    sub min { $_[0] < $_[1] ? $_[0] : $_[1] }

sub clear_window_title
{
    Gui_mw() or return;
    Gui_mw()->configure( -title => "- - - - - - - - - - -" );
}

sub set_window_title
{
    Gui_mw() or return;
    defined List_current_item() or return
        Carp::cluck("No 'current' defined (#files=".List_count().")");
    my $z = List_current_item()->property('FileSize');
    $z =~ s/000000$/mb/;
    $z =~ s/000$/kb/;
    Gui_mw()->configure( -title => join ' ',
        (List_current_item()->is_selected() ? '#' : ' '),
        #(List_current_item()->symlinked() ? 'K' : ' '),
        "[".List_current_item_seqno()."/".List_count()."]",
        List_current_item()->name,
        "(". List_current_item()->property('ImageWidth') ." x ". List_
+current_item()->property('ImageHeight') . ")",
        $z,
    );
}


sub clear_image
{
    Gui_imagit()->configure( -image => undef );
}

sub logo_imagedata_64 
{
qq{/9j/4AAQSkZJRgABAQEAYABgAAD/2wBDAAgGBgcGBQgHBwcJCQgKDBQNDAsLDBkSEw8
+UHRofHh0a
HBwgJC4nICIsIxwcKDcpLDAxNDQ0Hyc5PTgyPC4zNDL/2wBDAQkJCQwLDBgNDRgyIRwhMj
+IyMjIy
MjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjL/wAARCAB5AH
+ADASIA
AhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAw
+UFBAQA
AAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKS
+o0NTY3
ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZmq
+KjpKWm
p6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx8vP09fb3+Pn6/8
+QAHwEA
AwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREAAgECBAQDBAcFBAQAAQJ3AAECAx
+EEBSEx
BhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERU
+ZHSElK
U1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsr
+O0tba3
uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPw
+D3+iii
gAorJ1nxPovh/YNU1CK3d8bY+Xcg552qCccHnGKp674lt7bwVceINPuPOiEavA8YDBmLAA
+MD23HD
DhgN2MEVDqRV9djpp4SvNwtF2k0k7Ozb8zoqKy7LWo77X9U0pIWVtOWHfIx4cyKWwB6AAc
++pPHGS
3U9TuLfWdI021jy95JI80jRF1jhjXLdGGCWZFBORz9AXzq1/67ErD1Ofkas7X+Vua/3amt
+RRWTrP
ifRfD+wapqEVu742x8u5BzztUE44POMU3JRV2yKdKdWXJTi2+yV2a1Fc34g8TRweDJNW0e
+VbmW5V
YrHyz8zyOdo2qQcsOTtxn5SDjmukpKSbsip0J04Kcla7a87q1/zCiiiqMQooooAKqarff2
+ZpF7f+
X5n2WCSbZuxu2qTjPbOKt1k6tquhJ5+latf2sHnQfvIp5hFvjfcvBJGejDg5HtkVMnZbmt
+CDnNe6
2uqXYyNG8C2MO++15ItX1i4y1xcXC70ycfKiHgAYABxn6D5RR1iw02DxPo+j2cEFnZwTNr
+d95eI1
iEahI35+UKSMMAM8Z45JwZfH2o+HdZTS7W/tfE1oZNkWzd9owVUIhkUbGOT1AYkg5wTgVv
+EVxqB1
vxPJJb3kWqXGlQpFbjEkcNsUD3BLEbdoKsuR1ZjgZPHDKpT5bRWz1/PfzsfU0cFjXX5689
+JRbjrZ
atR+HRpRvfaysdhpnjDSItIk1uWO6gOq3bm2tiBJLcMirGBGq88iNRz0Y4zggnL0nxDHca
+lrfjTV
LSeytrC2j05IcZffkNIjDruEjKATtGDyBzjGttYB8W2a2VvdTPa2kVl4fhuopEWRWUq10+
+P4AqnJ
C/MpHA2kjDnP2jwfaQXcGqLbQXdxLrVwsO5lu23LFneQSQANwyB84ydxFS68vu/P+nf0N6
+eWUrtN
Nc9lvqou7sl6RUbu95OyR6HpfxBmvbe8e70KWzki0x9TgVpwwmiUkddoK5IGODkc9MZt6N
+4FsYd9
9ryRavrFxlri4uF3pk4+VEPAAwADjP0Hyjk/DOp6XfE211d/ZbB4y95earc7LjVt0bxAfe
+wI1O/g
M2Cq9Dk0S+PtR8O6yml2t/a+JrQybItm77RgqoRDIo2McnqAxJBzgnAuNWNlKq7/ANdjmq
+4Ct7Sd
HAx5Hu1rql05ne3dptXur6qy1vEkui6H4h0bTYbGJLdZ21Se2tkIdpVTy4BGoIBLPgbV/u
+5OBuJ1
rDx9Yy+F7nWtTt5dPNrO1tLbOdzmUAHYvQkkEcEDGDngZrMs9Mutf+J76lq1ktsul2VuYo
+D82ZHU
sDnBDhWMo3DHKrjoa53SLkaZpNj4g1ux1aWKDUbue9UQoF+1sUVHKHHyjDjPVZARx0o9pK
+Mm1onf
p2sv6+YvqtCvShTneU4qN/e1blzSsumqsr/4V3v32i+Jr69voLTV9FbSZbqEy2gkuUczBc
+blxwys
AwOCM43dMUN4qlvLFrjRdLa9P2mS3i824jgW4KdTExJ3g/MR2wj5IIAPJR3GseNJ7/xLFb
+z2thp9
ldR6SkfE0szIVLcAkn6HghQMkMaZo+rJZaT4XvUhltvDmmZF1ctGzeZcSQuGZQAW2K7Mpb
+gFnwBh
c1SrPa+nf7te3f8AAxnltPWSguZbxTbSdpPl35m37qsnvzdEd94c16HxFpf2uOCW3mjkMN
+xbyqQ0
Mq43KcjnGRz784OQNauV8BRSHSb/AFFo2ji1TUZ76BJBhxG5AXcPU7c8EjBBzXVV1Um5QT
+Z4mNpw
p4icKeyf3eXy2CsbWvCmh+IZoptUsFnliUqrh2RsdcEqRkfXpk+prZoqpRUlZq5jSrVKMu
+enJxfd
OzMvSfDmj6EoGm6dBbsFK+Yq5kIJyQXOWIz6nsPStSoba6hu4mkgfeiyPGTgj5kYow59GU
+j8Kmoi
kl7uwVZ1JzbqtuXW+4UUUUzMxta8KaH4hmim1SwWeWJSquHZGx1wSpGR9emT6mpdJ8OaPo
+Sgabp0
FuwUr5irmQgnJBc5YjPqew9K1KKnkjfmtqbvFV3T9k5vl7Xdvu2CiiiqMAooooAKKKKACi
+isPxjq
X9k+D9VvA0qOsDJG8Rwyu/yKQcjGGYHPtSlJRTb6GlGk6tSNOO8ml95R8Fa7ZX+hWheeCC
+8vprm5
S0aYGTDTytwOCQMHnHY10l1dW9lbvcXdxFBAmN0krhFXJwMk8dSBXkGoaL4f8LXGiW8X7z
+WtPkjv
9TnWRmVY0G5l5woLNtVBgE5XJG4E3vDf2rW9f0q3v51lleaTxBeQ7uIyVVLdVIYtlRtbaS
+BtYA5x
XHCvJJQa1PocVldGpKWKpyag7vVa2u3pq9Glo33V9z1eiiiu0+aCiiigAooooAKKKKACii
+igArL1
3RI9fsY7SW8vLVUmWYPaS7GJXkZODwDg/UA9q1KKTSasy6dSVOanB2aOdXwToq6He6V5Mp
+S+w11c
NKWmlcch2c99w3Y6ZJ45NY3gC2tbXWvE0cMV4kq3KIXuH3iZULp5m4jJZpFlLdgSAOhru6
+qWGmWe
mfafscPl/ap2uZvmJ3SNjc3J4zgcDisnSXNGSWx2xx9R0KtKpJvnt103V7/JJFuiiitjzw
+ooooAK
KKKACiiigAooooAKKKo61eSadoWoX0Kq0ttbSTIHGVJVSRnHbik3ZXKhBzkordlTw7eahf
+rqc18q
iNdRnhtQoGPJjIQe+dyvnPf2xVaO6l1Dx5Nbx3H+iaVaL5sau6kzzHI3D7rgIuRnoX9enN
+2nirVp
dJs9IsV05dXl046hd3zSLHBaqx3b3XHLkMGYYADMDgqTVTwrrmpLB59tbwX+seIWmugMFR
+aBH8se
a24sYQN20cEFSoyWyOX2yfLH7/69bHvvLakfa1LJdIq/4vsuVSd3a+/VX9RorjbjxVq9hp
+klpPY2
t14iN39jgt7Rz5cjGNZN+GwwRVcbvcdQDkFlf6x4e1nT7LxHrUV8moQTPvFukS2zxKHb5w
+RlCpbk
j+EdMmtvbRv/AFoed/ZtXlbur6tLrJJXbVltbq7X2Wuh2VZ2ial/a2mm8DROjTzpG8RyrI
+kropBy
c5VQc+9ec6r4p8T634RTWNNnXToSyWggWP8AfXsrgBzESCQAxwoU54ckggCqk2peJPA+lR
+acNb06
S4842UVmtsFjh+RH83zSEG4eYmd2Qd+STg4xeKSd7Ox6FPIqkqfI5x9o3a2ult72TXVeS6
+u+h7FR
Xm1h4y1LR9G1C71jUbXUIY54VtbhEVDdDcq3AiXK7wmSA2ME85xwOq0OLXLpl1TVL9oY51
+Ekelxw
qFgBBwruy72bBUn7uGBHI4rWFZT0SPPxGW1KCcpyVlonrq7J2Wl9L63tZ6PU36KKK2PPCi
+iigArJ
8U/8ihrX/XhP/wCi2rWrhPFWl+LZJ7+z0NLOSw1hh9olk+WS3+RI2HJwVKp1Ck8txkAnOr
+JqLsrn
bl9KNSvHmmo2s9dFo119P8jmPDvhXxPdaHNZqFgtdStlmk1D7Vlpo/JAggxyVVS2G45XIB
+wBufot
x4st/EswtvD0U15pekw6YYTdIBHkB0djnDZIJwuOCBnIyfV9Ps49O021sYWZoraFIULnLE
+KABnHf
is7StJa08Qa9qUgYNfTQhMsCpjjiUAgDkHcXHPoPx5/q3Ly2b/r/AIJ67zv2vtnUhFprTf
+V3S11/
l+6ytZaHNP4Y13RNOs9R0tLDUddjknluhOhCyyTlN7xncoUgIF7AqW4BODXs/CWuX9treu
+a/tk1u
7sp7a0tFKlbcMpAAOSATnAwejHJJY49GorX6vC/9ff6nAs4xCi1ZXfW2tr35fKN+i9L2OP
+1/Q75v
DWgRaTaNNLpNza3AtZ5kSR1jXG0sPl3cjJ6cHGeAeW1fwT4iuXGtzafYapqN/HsvbKVtqw
+HcChjY
MvRVVD8xPXlgxx6zRRPDxnuPDZxXw6XIlu9db662vfa+ulndLU8/i8JandNoWo6zumvLe9
+jcWtmU
jhsIAGIRVyAQGEe48thQBnGT6BRRWkKahsceKxlTEtc9tL2S0Su7/wBfjqFFFFWcoUUUUA
+FFFFAB
RRRQAUUUUAFFFFABRRRQAUUUUAFFFFAH/9k=
}
}

sub show_default_image
{
    my $logo_image;
    eval {
        my $oi = Gui_mw()->Photo( 'logo',
            -data => logo_imagedata_64(),
        );
        $logo_image = $oi;
    };
    if ( $@ )
    {
        alert( $@ );
        return;
    }
    $logo_image or alert( "Failed to create a Photo object from in-mem
+ory data" );
    clear_window_title();

    Gui_imagit()->configure(
        -image => 'logo',
        -width => $logo_image->width,
        -height => $logo_image->height,
    );

    Gui_imagit()->update; Gui_scrolled()->update; Gui_mw()->update;
}

sub show_image
{
    Gui_mw() or return; # not ready to do GUI stuff.

    List_current_item() or return show_default_image();

    clear_window_title();

    my $original_image;
    eval {
        my $oi = Gui_mw()->Photo( 'fullscale',
            -file => List_current_item()->name,
        );
        $original_image = $oi;
    };
    if ( $@ )
    {
        print STDERR "\nDon't worry about the above; it was caused whe
+n trying to read the file\n\t".List_current_item()->{'filename'}."\n(
+which was subsequently removed from the list.)\n\n";
        alert( "Failed to create a Photo object from file\n".List_curr
+ent_item()->name."\n$@\n\nImage removed from list!" );
        Edit_remove_current();
        goto &show_image;
        #return;
    }

    $original_image or alert( "Failed to create a Photo object from fi
+le\n".List_current_item()->name );

    # it's possible to manipulate an image during reading
    # from disk, but unfortunately you don't get quite as
    # much control as you do when copying one image to another,
    # and some of the things we need to do we can only do
    # during copy, not reading.
    my $factor = min(
        factor( $original_image->width,  Gui_scrolled()->width ),
        factor( $original_image->height, Gui_scrolled()->height ),
    ) + ( List_current_item()->scalefactor() || 0 );
    my $scaled_image = Gui_mw()->Photo( 'myScaledImage' );
    $scaled_image or return alert( "Failed to create a Photo(myScaledI
+mage)!" );
    $scaled_image->copy( $original_image, -shrink => -subsample => $fa
+ctor, $factor );
    Gui_imagit()->configure(
        -image => 'myScaledImage', # the (arbitrary) name we have assi
+gned to the image we've stored in memory.
        -width => $scaled_image->width,
        -height => $scaled_image->height,
    );

    # do these later?
    Gui_imagit()->update; Gui_scrolled()->update; Gui_mw()->update;

    ( $::iwidth, $::iheight ) = ( $scaled_image->width, $scaled_image-
+>height );
    #( $::iwidth, $::iheight ) = ( Gui_imagit()->width, Gui_imagit()->
+height );
    # imagit width and height are 4 pixels greater than image width an
+d height.

    my $xmid = List_current_item()->scrolledto_x();
    my $ymid = List_current_item()->scrolledto_y();
    my $xscrollto = $xmid - Gui_scrolled()->width  / ( $::iwidth  * 2 
+);
    my $yscrollto = $ymid - Gui_scrolled()->height / ( $::iheight * 2 
+);
    my $kx = Gui_imagit()->width  / $scaled_image->width;
    my $ky = Gui_imagit()->height / $scaled_image->height;
    $kx = 1 + 5 * ( $kx - 1 );
    $ky = 1 + 5 * ( $ky - 1 );
    $xscrollto *= $kx;
    $yscrollto *= $ky;
    $xscrollto <= 0.002 and $xscrollto = 0;
    $yscrollto <= 0.002 and $yscrollto = 0;
    $xscrollto >= 0 and Gui_scrolled()->xview( moveto => $xscrollto );
    $yscrollto >= 0 and Gui_scrolled()->yview( moveto => $yscrollto );
    List_current_item()->update_pos( Gui_scrolled()->xview, Gui_scroll
+ed()->yview );

    set_window_title();
}

sub drag
{
    my( $w, $x, $y ) = @_;
    if ( defined $::last_x )
    {
        my( $xscroll, $yscroll ) = Gui_scrolled()->Subwidget( 'xscroll
+bar', 'yscrollbar' );
        my( $dx, $dy ) = ( $x-$::last_x, $y-$::last_y );
        my( $xf1, $xf2 ) = $xscroll->get;
        my( $yf1, $yf2 ) = $yscroll->get;
        if ( $dx < 0 )
        {
            Gui_scrolled()->xview( moveto => $xf1-($dx/$::iwidth) );
        }
        else
        {
            Gui_scrolled()->xview( moveto => $xf1-($xf2*$dx/$::iwidth)
+ );
        }
        if ( $dy < 0 )
        {
            Gui_scrolled()->yview( moveto => $yf1-($dy/$::iheight) );
        }
        else
        {
            Gui_scrolled()->yview( moveto => $yf1-($yf2*$dy/$::iheight
+) );
        }
        List_current_item()->update_pos( Gui_scrolled()->xview, Gui_sc
+rolled()->yview );
    }
    ( $::last_x, $::last_y ) = ( $x, $y );
}



sub File_exit { Gui_die_die_die(); }

sub File_open
{
    List_count() and alert("Warning! If you open a slideshow file, you
+ will lose any changes you have made to the current slideshow!");

    my $open_file = Gui_mw()->getOpenFile(
        -defaultextension => '.slideshow',
        -filetypes => [ ['Slideshow Files', '.slideshow' ], ['All File
+s', '*' ] ],
    ) or return;
    List_initialize_from_file( $open_file );
    View_first();
}

sub File_save_as
{
    my $saveas_file = Gui_mw()->getSaveFile(
        -defaultextension => '.slideshow',
        -filetypes => [ ['Slideshow Files', '.slideshow' ], ['All File
+s', '*' ] ],
        List_slideshow_filename() ? ( -initialfile => List_slideshow_f
+ilename() ) : ()
    ) or return;
    open F, '>', $saveas_file or return alert("Unable to open file for
+ writing:\n$saveas_file\n$!");
    print F List_as_xml();
    close F;
}

sub File_print_to_stdout
{
    print List_as_xml();
}

sub File_write_onto_clipboard {
    Gui_mw()->clipboardClear;
    List_for_each( sub {
        local $_ = shift;
        Gui_mw()->clipboardAppend($_->name."\n");
    } );
}

sub File_write_batch_copier_onto_clipboard {
    my $dd = defined $::dest_dir ? $::dest_dir : '.';
    if ( ! -d $dd )
    {
        alert( "The dest dir '$dd' does not exist, or is not valid fro
+m where you launched the program." );
        return;
    }

    Gui_mw()->clipboardClear;
    Gui_mw()->clipboardAppend(qq{\@echo off\n});
    List_for_each( sub {
        my $fi = shift;
        local $_ = $fi->name;
        s#\/#\\#g;
        Gui_mw()->clipboardAppend( qq{copy /y "}.$_->name.qq{" "$dd"\n
+} );
    });
    Gui_mw()->clipboardAppend(qq{\@echo on\n});
}


sub Edit_current_toggle_selection # for the current: toggle its select
+ion state
{
    List_current_item()->toggle_selection_state();
    View_next();
}

# if the list storage mode is "use directory of symlinks", then the "S
+ave"
# operation should udpate the directory with the current contents of t
+he list.
# it can use the remove_symlink() function.

sub Edit_remove_current
{
    List_remove_current_item();
    clear_showimage_timer();
    show_image();
}

sub Edit_remove_selected
{
    run_custom_filter('grep','! $_.selected');
    List_clear_selection();
}

sub Edit_remove_unselected
{
    run_custom_filter('grep','$_.selected');
    List_clear_selection();
}


    sub _twiddle_view_pointer
    {
        my $cr = shift; # a sub which sets the List's current index.
        if ( List_count() )
        {
            if ( List_current_item() )
            {
                # the normal situation
                $cr->();
            }
            else
            {
                # unusual: there are items in the list, but $ii==-1
                List_set_index_0();
            }
        }
        else
        {
            List_set_no_current_item(); # should be already, but just 
+to make sure.
        }
        clear_showimage_timer();
        show_image();
    }

sub View_first
{
    _twiddle_view_pointer( \&List_set_index_0 );
    Gui_mw() or return;
    Gui_mw()->focus;
}

sub View_prev
{
    _twiddle_view_pointer( \&List_advance_index );
}

sub View_next
{
    _twiddle_view_pointer( \&List_retreat_index );
}



sub View_zoom_in
{
    List_current_item()->scalefactor() or return; # can only be positi
+ve (or rather, non-negative)
    List_current_item()->set_scalefactor( List_current_item()->scalefa
+ctor() - 1 );
    clear_showimage_timer();
    show_image();
}

sub View_zoom_out
{
    List_current_item()->set_scalefactor( List_current_item()->scalefa
+ctor() + 1 );
    clear_showimage_timer();
    show_image();
}

sub View_no_item
{
    clear_image();
    clear_window_title();
    List_set_no_current_item();
}

sub View_start_slideshow
{
    List_current_item() or return;
    start_autoadvancing();
}
sub View_stop_slideshow
{
    List_current_item() or return;
    stop_autoadvancing();
}


sub ImageFile_edit_current { List_current_item()->external_edit() }

sub ImageFile_rename_current
{
    my $old_name = List_current_item()->property('FileName');
    my $rename_dialog = Gui_mw()->DialogBox( -title => 'Rename Image F
+ile', -buttons => [qw( OK Cancel )] );
    $rename_dialog->bind( '<Escape>', sub { $rename_dialog->Subwidget(
+'B_Cancel')->invoke } );
    my $rename_entry = 
    $rename_dialog->add('Frame')->pack( -expand => 1, -fill => 'both' 
+)
    ->Entry( 
        -width => 80,
        -validate => 'all',
        -validatecommand => sub {
            local $_ = shift; # proposed new value
            /./ and not /[\\\/:?*"<>|]/;
        },
    )->pack;
    $rename_entry->insert('end',$old_name);
    my $b = $rename_dialog->Show;
    my $new_name = $rename_entry->get;
    $rename_dialog->destroy;
    undef $rename_dialog;
    $b eq 'OK' or return;
    lc($old_name) eq lc($new_name) and $on_Windows and return alert("S
+orry, mere case changes are not allowed!");
    rename $old_name, $new_name or return alert(<<EOF);
Error trying to rename
  $old_name
to
  $new_name
$!
EOF
    my $long_name = List_current_item()->property('filename');
    $long_name =~ s/\Q$old_name\E/$new_name/;
    List_current_item()->set_properties({
        FileName => $new_name,
        filename => $long_name,
    });
    set_showimage_timer(); # since title has changed
}

sub ImageFile_delete_current
{
    warn "Going to delete current imagefile!";
    unlink( List_current_item()->name ) or return alert("Failed to rem
+ove current file!\n".List_current_item()->name."\n$!");
    Edit_remove_current();
}

sub ImageFile_current_createsymlink
{
    # just do current image, and advance
    undef $@;
    eval {
        my $msg = List_current_item()->create_symlink();
        warn qq(Created symlink "$msg"\n);
        #View_next();
    };
    $@ and warn $@;
}

sub ImageFile_all_createsymlinks
{
    print "Creating ".List_count()." symlinks.\n";
    List_for_each( sub {
        my $f = shift;
        undef $@;
        eval {
            my $msg = $f->create_symlink();
            warn qq(Created symlink "$msg"\n);
        };
        $@ and warn $@;
    });
    print "Done.\n";
}

# also need a "copy selected to..."
sub ImageFile_copy_all_to_destdir
{
    defined $::dest_dir && -d $::dest_dir or return alert("No valid de
+st dir defined!");
    List_for_each( sub {
        my $fi = shift;
        local $_ = $fi->name;
        s#\/#\\#g; # XXX system specific
        print( qq{copy /y "$_" "$::dest_dir" \n} );
        system( qq{copy /y "$_" "$::dest_dir" \n} );
    });
}

sub ImageFile_view_info
{
    List_current_item()->show_info();
}

} # end of subs


### MAIN PROGRAM!

initialize_data_structures();

Gui_initialize();

MainLoop;



# for more information, visit this project's home page at:
#     http://www.perlmonks.com/?node_id=600092

=pod TO DO

Enable assigning tags (i.e. keywords) to an image.
Enable filtering by tags. 

Enable assigning a free-text comment to an image.
Enable displaying (overlaying) the comment text on the image.

Improve platform independence.
Get a Better Glob.

Strategize slideshow storage management.
Add strategy for storing a slideshow as a directory of symlinks. Lots 
+of existing code to salvage.

Allow overriding/canceling commands entered on the commandline.
(Obviously, commands which execute immediately aren't eligible.)

Enable setting various config params via commandline switches AND via 
+dialogs.
(e.g. the auto-advance dwell time).

Implement Undo.

Implement an 'ex'-like command interface.
Implement a 'vi'-like command interface.


Support a s/// style of file renaming.
Can re-invoke a stored filename renaming transformation on subsequent 
+files.
Apply a renaming transformation on all of the selection.

Allow selecting (adding to selection) based on a filter.

Add more Selection-aware variants of commands.

Add transition effects. (Idea credit to [bart].)

=cut

__END__
:endofperl
[download]