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::JPEG;
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');
my $textbox = $mw->Text(); # a utility text box used solely for
# copying to the system clipboard
# never shown(packed)
$mw->fontCreate('big',
-family=>'arial',
-weight=>'bold',
-size=>int(-18*18/14));
$mw->bind('<Control-c>', sub{ 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+BPzubPzybPzydPz2fMSOBMSSBMyaBLR6B
+PzuX
PzuZPz2hPz6hPz6jPz+lPz+nPzmTPzqVPzqXPzyfKx6BPziRPzmVMyWBKx2BPzeNPziPLy
+GBMS
KBKxyBPzaJPzaLLyCBPzWFPzeLKRyBPzSDPzSFPzWHPzmRKRuBPzOBPzSBKRqBJxmBAAAA
+AAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAA
+WABY
AAAbXQIBwSCwaj8aAMkBkIodOoRIwfT6XVuTSKRAMBtktk1AwHBDfhGK9aC+OjIajcDg8I
+BHJZ
D95GxkUFRYOZhcPERF8fkUYGYEaBYRnhxISG0ccHRkeFBQWHx8gCaMKGxtubiEiIx0eGSQ
+aFQ4
OdQiUfBMbISWrJgSuFBqDdLa3bycoKSocrK4rscOTEX4sLS4cyquanJ5ydJdCLy3VKCglK
+qsjG
Y7CDgpEL9Ut8+UqKiMmrY4JRTDz//TO3csHpt+LeCxChODAgQEBAgJIfMhCsaLFi0jsBAE
+AIf5
oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5N
+ywxO
Tk4LiBBbGwgcmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw=
+=');
my $closed_folder_bitmap = $mw->Photo(-data =>
'R0lGODlhEAAQAIMAAPwCBNSeBJxmBPz+nMzOZPz+zPzSBPz2nAQC/PzqnAAAAAAAAAAAA
+AAAA
AAAAAAAACH5BAEAAAAALAAAAAAQABAAAARTEMhJ6wwYC3uH98FmBURpElkmBUXrvsVgbOx
+wHB7
yeTPA3gdEcCC89X5AhBJ4OBZuSl3USCskkkugM3EVerVV7jXIbNIM6LQ6LRK433A4Z06n+
+yMAI
f5oQ3JlYXRlZCBieSBCTVBUb0dJRiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk
+5Nyw
xOTk4LiBBbGwgcmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AO
+w==');
$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 well on Tk
$photo->bind("<ButtonPress>", sub {
my (@parts) = split /\s+/ ,$info;
my $abs_path = File::Spec->rel2abs( $parts[0] );
$textbox->clipboardClear;
$textbox->delete('1.0','end');
$textbox->insert('end', $abs_path);
$textbox->selectAll;
#this line must come after the selectAll
$textbox->delete('end - 1 chars','end');
$textbox->clipboardColumnCopy;
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","<Button-1>", 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', $key],
-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 chi
+ldren
$hlistd->entryconfigure( $path, -image => $closed_folder_b
+itmap );
$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/*";
# use File::Glob ':glob';
# my @files = bsd_glob( "$path/*"); # forspaces in names
#this decode utf8 routine is used so filenames with extended
# ascii characters (unicode) in filenames, will work properly
use Encode;
opendir my $dh, $path or warn "Error: $!";
my @files = grep !/^\.\.?$/, readdir $dh;
closedir $dh;
@files = map { decode( 'utf8', "$path/".$_ ) } sort @files;
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|jpg|gif)$/ ){ push @thumbs, $file }
}
}
$mw->configure( -cursor => $oldcursor );
#print "@thumbs\n";
load_thumbs( \@thumbs );
}
###############################################################