Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??

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.

Features:

  • View any image type supported by Tk::Image.
  • Multiple ways to get a list of image files into the program: command line args (with recursive glob), read from stdin, slideshow file, etc.
  • Manually navigate through the list of images.
  • Pan/scroll around an image if it is larger than the window.
  • Shrink an image.
  • Save and load a slideshow file (it is XML formatted).
  • Filter (grep) and order (sort) the list of images based on any metadata criteria.
  • Automatic slideshow mode: advances to next image every 2 seconds.
  • Execute an external command on the current image (for example, launch an image editor)
  • All metadata for each image are persisted when you save the slideshow file.
  • A number of commands, accessible via menus, for operating on the slideshow file, the list, and the currently displayed item. Many commands are also bound to keys, and some can be executed via command-line switches.
Command line options: (NB - All of the following is subject to change!)
  • --grep pattern = filter the image list
  • --sort sortcode = order the image list
  • --byname = order the image list by file name
  • --bysize = order the image list by file size
  • --random = randomize the order of the image list
  • --first = jump to the first image in the list. Useful if any of the above are specified.
  • --auto = start the automatic slideshow right away.
  • --file FILE = load slideshow file. format as generated by the Save as... command.
  • --input = read file specifications from stdin rather than getting them on the command line
  • --scale N = pre-scale all images. The default, 0, means full scale. 1 = 1/2 scale, 2 = 1/3 scale, etc. You can think of it as the number of times you hit the - key.
  • --icon = start the gui in the iconified state.
  • --exit = exit, rather than lauching gui. still does all the data initialization.
Some of the commands accessible through the GUI:
  • PageUp / PageDown = go to previous/next image (loops around)
  • Up / Down arrows = scroll the image vertically
  • Left / Right arrows = scroll the image horizontally
  • + / - = zoom in/out
  • F3 = Order list by file name
  • F4 = Order list by file size
  • F5 = Randomize the list's order
  • F5 = Reverse the list's order
  • G = Enter custom filter (grep) code
  • S = Enter custom ordering (sort) code
  • 0 = Jump to the first image in the list
  • Delete = Remove the current image from the list
  • space = Select/unselect the current image (and go to next)
  • s = Save slideshow file as...
  • l = List slideshow to stdout
  • c = Copy list to the Clipboard
  • q = Exit
  • Escape = Exit
  • mouse Click+Drag on the image = move the image around in the viewport
  • mouse wheel = scroll up/down
and many more. See the actual menus for complete set.

List-oriented commands, such as s, l, and c, operate on the entire list currently in memory, in its current order. The filtering and ordering functions operations alter the image list.

Currently, very few operations are aware of the selected subset of images. More are planned.

For the custom grep and custom sort operations, the text you enter is whatever you'd put inside the curlies if you were writing a grep or sort block in perl. $_, $a, and $b are filenames, as displayed in the window title bar.

Grep and sort can be invoked on the command line as well, via the --grep and --sort commandline options. Multiple --grep and --sort options can be given; their effects will be cumulative.

Note that the sorting is stable: if the current sort operation's comparator finds no difference between two files ($a and $b), their relative ordering will remain unchanged.

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

In reply to Tk Photo Slideshow - Production Release by jdporter
in thread Tk Photo Slideshow, with scrolling and scaling by jdporter

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others avoiding work at the Monastery: (8)
    As of 2014-10-01 14:46 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      What is your favourite meta-syntactic variable name?














      Results (26 votes), past polls