Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

Tk-thumbnail-viewer

by zentara (Archbishop)
on Mar 10, 2006 at 22:41 UTC ( [id://535837]=CUFP: print w/replies, xml ) Need Help??

Thur Mar 16,2006 UPDATE 3 I ran into a problem with some filenames having extended ascii(unicode chars) in them. graff explained it, so I changed the glob to a readdir with a utf8 decode. Also I added a tag to the dashed lines separating the thumbnails, so they would work right with the callback.

Mon Mar 13, 2006 UPDATE 2 This can easily be extended to include jpg and gifs( as well as png ), So I made the few line changes, so you won't have to :-) Additionally switched to bsd_glob for allowing spaces in filenames

Sat Mar 11, 2006 UPDATE I found a way to copy the file path to the mouse clipboard, when you click on the main image, without the obnoxious extra "Tk phantom" newline. Handy. Also fixed bad sub name.

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.

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 ); } ###############################################################

I'm not really a human, but I play one on earth. flash japh

Replies are listed 'Best First'.
Re: Tk-thumbnail-viewer
by zentara (Archbishop) on Mar 11, 2006 at 15:31 UTC
    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.

    Second update: Made the easy fix so jpg's and gif's will show too.


    I'm not really a human, but I play one on earth. flash japh
Re: Tk-thumbnail-viewer
by Rudif (Hermit) on Mar 13, 2006 at 22:19 UTC
    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).

    Rudif

      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.

      Yeah I just looked at it, and File::Glob will do the trick on linux. Change

      # my @files = glob "$path/*"; use File::Glob ':glob'; my @files = bsd_glob( "$path/*"); #includes spaces

      I'm not really a human, but I play one on earth. flash japh
      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 changed the glob to a readdir and used Encode::decode.


      I'm not really a human, but I play one on earth. flash japh

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://535837]
Approved by GrandFather
Front-paged by Arunbear
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others goofing around in the Monastery: (4)
As of 2024-03-29 13:10 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found