The following is a full-featured, production-quality image slideshow program.
It began life as an enhancement of Tk Photo Slideshow, with scrolling and scaling, which is the root of this thread.
and many more. See the actual menus for complete set.
Currently, this program has a number of unpleasant hacks for working on Windows.
It has only been tested on Windows, but my desire is for it to be cross-platform.
If you have any feedback on how well it doesn't work on another platform, please send it to me. I appreciate it very much.
@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