Tk-thumbnail-viewer
I saw this nice free png clipart collection at free wpclipart 170 Megs. It had some Python WxWidget Viewer, which I could not get to work, :-). So here is a general purpose Tk viewer. screenshot Just run it from the top level of your image directory.
I'm not really a human, but I play one on earth. flash japh
It dosn't make any temp files, nor does it eat memory, so it might be instructive if you want to see how reusing Tk widgets, can prevent "memory leaks".
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::Pane;
use Tk::PNG;
use Tk::HList;
use File::Spec;
use File::Basename;
use MIME::Base64;
use Image::Magick;
# Fri, Mar 10, 2006 by zentara@zentara.net
# This is GPL'd code, do what you want with it. I hope
# you find it useful.
# General purpose thumbnail viewer. Run in the top directory
# of the images. It will show directories, and make dynamic
# thumbs for each directory clicked on. It does not store
# any images, so it is useful for viewing large collections.
# tested and does not "leak" memory
# setup to view images in the free PNG image collection
# available at http://www.wpclipart.com
my $im = Image::Magick->new; # a single object for thumbnails
my $photo; #my $photo label;
my %thumbs; #global for reusing Photo objects which hold thumbs
my %info; #reusable hash to hold photo file info
my $info = 'File Information';
my $mw = MainWindow->new(-bg=>'black');
$mw->geometry('800x600');
$mw->fontCreate('big',
-family=>'arial',
-weight=>'bold',
-size=>int(-18*18/14));
$mw->bind('', [sub{&save_it(); Tk::exit;}] );
my $topframe = $mw->Frame(-height =>30, -background=>'black')
->pack(-fill=>'both', -expand=>1);
$topframe->Label( -textvariable => \$info,
-background => 'black',
-foreground =>'yellow',
-font =>'big',
-padx=>40,
-relief=>'raised',
)->pack(-fill =>'both',-expand =>1);
my $leftframe = $mw->Frame( -width =>50,
-background=>'black',
)->pack(-side => "left", -anchor => "n",
-fill=> 'y',
-expand=>0,
);
my $midframe = $mw->Frame( -width =>150,
-background=>'black',
)->pack(-side => "left", -anchor => "n",
-fill=>'y',
-expand=>0,
);
my $mainframe = $mw->Frame(-background=>'black')
->pack(-side => "left", -anchor => "n",
-fill=>'both', -expand=>1);
#default empty image
my $image = $mw->Photo(-file => '' ) or die $!;
# an HList dir selector in left frame
my $hlistd = $leftframe->Scrolled(
'HList',
drawbranch => 1, # yes, draw branches
separator => '/', # filename separator
indent => 15, # pixels
background => 'White',
selectmode => 'single',
selectbackground => 'lightyellow',
selectforeground => 'red',
command => \&show_or_hide_dir
);
$hlistd->pack( -fill => 'both', -expand => 1 );
my $open_folder_bitmap = $mw->Photo(-data =>
'R0lGODlhFgAWAIUAAAT+BGRmnLSCBLyKBLR+BPzubPzybPzydPz2fMSOBMSSBMyaBLR6BPzuX
PzuZPz2hPz6hPz6jPz+lPz+nPzmTPzqVPzqXPzyfKx6BPziRPzmVMyWBKx2BPzeNPziPLyGBMS
KBKxyBPzaJPzaLLyCBPzWFPzeLKRyBPzSDPzSFPzWHPzmRKRuBPzOBPzSBKRqBJxmBAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAAWABY
AAAbXQIBwSCwaj8aAMkBkIodOoRIwfT6XVuTSKRAMBtktk1AwHBDfhGK9aC+OjIajcDg8IBHJZ
D95GxkUFRYOZhcPERF8fkUYGYEaBYRnhxISG0ccHRkeFBQWHx8gCaMKGxtubiEiIx0eGSQaFQ4
OdQiUfBMbISWrJgSuFBqDdLa3bycoKSocrK4rscOTEX4sLS4cyquanJ5ydJdCLy3VKCglKqsjG
Y7CDgpEL9Ut8+UqKiMmrY4JRTDz//TO3csHpt+LeCxChODAgQEBAgJIfMhCsaLFi0jsBAEAIf5
oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxO
Tk4LiBBbGwgcmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==');
my $closed_folder_bitmap = $mw->Photo(-data =>
'R0lGODlhEAAQAIMAAPwCBNSeBJxmBPz+nMzOZPz+zPzSBPz2nAQC/PzqnAAAAAAAAAAAAAAAA
AAAAAAAACH5BAEAAAAALAAAAAAQABAAAARTEMhJ6wwYC3uH98FmBURpElkmBUXrvsVgbOxwHB7
yeTPA3gdEcCC89X5AhBJ4OBZuSl3USCskkkugM3EVerVV7jXIbNIM6LQ6LRK433A4Z06n+yMAI
f5oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5Nyw
xOTk4LiBBbGwgcmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw==');
$hlistd->Subwidget("yscrollbar")->configure(
-background => 'lightgreen',
-activebackground => 'seagreen',
-troughcolor => 'lightyellow',
);
# canvas for midframe to hold thumbnails
my $ct = $midframe->Scrolled('Canvas',
-width => 110,
-background => 'black',
-scrollbars => 'w',
)->pack(-side => "left", -anchor => "n",
-fill => 'y',
-expand => 1
);
$ct->Subwidget("yscrollbar")->configure(
-background => 'lightsteelblue',
-activebackground => 'steelblue',
-troughcolor => 'mistyrose',
);
#fill mainframe with default screen
setup_pane();
$mw->waitVisibility;
# Start with the current directory
show_or_hide_dir(".");
MainLoop;
#########################################################################
sub setup_pane{
my $pane = $mainframe->Scrolled('Pane', Name => 'Main Display',
-width => 600,
-height =>1000,
-background => 'black',
-scrollbars => 'osoe',
-sticky => 'n',
)->pack(-side => "left", -anchor => "n",
-fill=>'both',-expand=>1);
$photo = $pane->Label(-image => $image,
-background =>'black'
)->pack(-side => 'top',
-anchor => 'n',
-fill => 'both',
-expand => 1,
);
# el cheapo clipboard, since clipboard dosn't work on Tk
$photo->bind("", sub {
my (@parts) = split /\s+/ ,$info;
my $abs_path = File::Spec->rel2abs( $parts[0] );
print "$abs_path\n";
print chr(07); #beep
});
}
##############################################################
sub browseThis {
my @tags = $ct->gettags( $ct->find(qw|withtag current|) );
@tags = grep { $_ ne 'temp' } @tags;
@tags = grep { $_ ne 'current' } @tags;
my $pic = $info{ $tags[0] }{'pic'} || '';
$image->blank;
$image->read($pic);
$photo->configure(-image => $image );
#update label
$info = $info{ $tags[0] }{'info'};
}
############################################################
sub load_thumbs{
#clean up last display -------------------------
$ct->delete( $ct->find(qw|withtag temp|) );
foreach my $key(keys %thumbs){
$thumbs{$key}->blank; #reuse thumbnail objects
}
foreach( keys %info ){
$info{$_}{'pic'} = '';
$info{$_}{'info'} = '';
$info{$_}{'thumbnail'} = '';
delete $info{$_}{'pic'};
delete $info{$_}{'info'};
delete $info{$_}{'thumbnail'};
delete $info{$_};
}
%info = ();
#-----------------------------------------------
#my @exts = qw(.jpg .png .gif); # list allowed extensions
my @exts = qw(.png); # list allowed extensions
my $picref = shift;
my @pics = @$picref;
my @slots = sort {$a<=>$b} keys %thumbs;
my $slot_prev = -1;
my $scrollreg = (scalar @pics) * 130;
$ct->configure(-scrollregion =>[0,0,100,$scrollreg]);
foreach my $pic (@pics){
my ($basename,$path,$suffix) = fileparse($pic,@exts);
$info{$basename}{'pic'} = $pic; #full path to image
#get image info
my ($width, $height, $size, $format) = $im->Ping($pic);
$info{$basename}{'info'} = "$pic $width x $height $size";
# Create smaller version
$im->Read($pic);
$im->Scale( geometry => '100x100' );
$info{$basename}{'thumbnail'} = $im->ImageToBlob();
undef @$im; # blank $im object
#reuse slots for thumbnails to avoid memory gain
my $slot = shift(@slots);
$slot ||= -1;
if($slot == -1){ $slot = $slot_prev + 1 }
&add_key( $basename, $slot );
$slot_prev = $slot;
$mw->update;
}
undef @$im;
$ct->bind("temp","", sub { &browseThis });
}
###################################################################
sub add_key{
my($key, $slot) = @_;
#print "$key $slot\n";
#Tk needs data images base64 encoded
my $content = encode_base64( $info{$key}{'thumbnail'} );
if(ref $thumbs{$slot} eq 'Tk::Photo'){
$thumbs{$slot}->put($content)
}else{
$thumbs{$slot} = $mw->Photo(-data => $content );
}
my $y = $slot * 130;
$ct->createText( 50,$y + 10,
-tags => ['temp', $key],
-fill => 'yellow',
-text => $key,
# -font => 'medium',
);
$ct->createImage( 0, $y +20 ,
-image =>$thumbs{$slot} ,
-tags => ['temp', $key],
-anchor => 'nw'
);
$ct->createLine( 0,$y,130,$y,
-tags => ['temp'],
-fill => 'white',
-width => 5,
-dash => [6,4],
);
}
#############################################################
sub show_or_hide_dir { # Called when an entry is double-clicked
my $path = $_[0];
return if ( !-d $path ); # Not a directory.
if ( $hlistd->info( 'exists', $path ) ) {
# Toggle the directory state.
# We know that a directory is open if the next entry is a
# a substring of the current path
my $next_entry = $hlistd->info( 'next', $path );
if ( !$next_entry || ( index( $next_entry, "$path/" ) == -1 ) ) {
# Nope. open it
$hlistd->entryconfigure( $path, -image => $open_folder_bitmap );
add_dir_contents($path);
}
else {
# Yes. Close it by changing the icon, and deleting its children
$hlistd->entryconfigure( $path, -image => $closed_folder_bitmap );
$hlistd->delete( 'offsprings', $path );
}
}
else {
die "'$path' is not a directory\n" if ( !-d $path );
$hlistd->add(
$path,
-itemtype => 'imagetext',
-image => $open_folder_bitmap,
-text => $path
);
add_dir_contents($path);
}
}
##########################################################################
sub add_dir_contents {
my $path = $_[0];
my $oldcursor = $mw->cget('cursor'); # Remember current cursor, and
$mw->configure( -cursor => 'watch' ); # change cursor to watch
$mw->update();
my @files = glob "$path/*";
my @thumbs=();
foreach my $file (@files) {
$file =~ s|//|/|g;
(my $text = $file ) =~ s|^.*/||g;
if ( -d $file ) {
$hlistd->add(
$file,
-itemtype => 'imagetext',
-image => $closed_folder_bitmap,
-text => $text
);
}
else {
if( $file =~ /.*\.png$/ ){ push @thumbs, $file }
}
}
$mw->configure( -cursor => $oldcursor );
#print "@thumbs\n";
load_thumbs( \@thumbs );
}
###############################################################
I'm not really a human, but I play one on earth. flash japh
Re: Tk-thumbnail-viewer
created: 2006-03-11 10:31:13
See update. Tk has had a problem with copying text selections
to the mouse clipboard reliably. I found a hack using an hidden
text widget.
I'm not really a human, but I play one on earth. flash japh
I'm not really a human, but I play one on earth. flash japh
Re: Tk-thumbnail-viewer
created: 2006-03-13 17:19:13
Very neat. Works for me on WinXP (after I installed ImageMagick and PerlMagick).
The directory browser seems to ignore (fails to open any images in) subdirectories whose names contain spaces or dashes (legal characters in Win32 filenames).
Re^2: Tk-thumbnail-viewer
created: 2006-03-13 17:54:45
I tried the - and space on linux, and the - works, but not the name with spaces. You can easily adjust it to suit your system,
just change the line my @files = glob "$path/*"; to whatever command works well on win32.
I'm not really a human, but I play one on earth. flash japh
I'm not really a human, but I play one on earth. flash japh
Re^2: Tk-thumbnail-viewer
created: 2006-03-16 11:20:04
Hi again. FYI, I don't know if you have encoding problems on WinXP,
but I had a problem with extended ascii characters in art/Paintings/Gellee, where the filename had European chars in them. This would cause errors in opening the file, if I retreived the filename from a stored string. See Re: problems with extended ascii characters in filenames
I'm not really a human, but I play one on earth. flash japh
I changed the glob to a readdir and used Encode::decode.
I'm not really a human, but I play one on earth. flash japh