It is quite fast, and it is better than Tk, since it dosn't need to base64 encode images.
#!/usr/bin/perl use strict; use warnings; use Glib qw/TRUE FALSE/; use Gtk2 '-init'; use File::Find; use File::Basename; # any commandline arg will make this recurse into subdirs my $recursive; if($ARGV[0]){ $recursive = 1 } #try to find all format extensions which Pixbuf recognizes my @formats = Gtk2::Gdk::Pixbuf->get_formats(); my @exts; my @files; #go thru Pixbuf formats and grab extensions foreach my $format ( @formats ) { foreach my $key ( keys( %$format ) ) { next unless $key eq 'extensions'; foreach my $elem ( @{ $format->{ $key } } ) { push @exts, $elem; } } } @exts = grep { $_ ne 'svg' } @exts; #svg dosn't work for me yet #although it is in formats #if recursive, use File::Find to recurse, else use a glob if($recursive){ find( sub { my $file = $File::Find::name; my ($name, $path, $extension) = fileparse($file,'\..*'); substr $extension, 0, 1, ''; #remove leading . if( grep {$_ eq $extension} @exts ){ push @files, $file ; } }, '.' ); }else{ @exts = map { $_ = "*.$_" } @exts; #map to setup the glob below #print "@exts\n"; #uncomment to see extensions @files = <@exts>; #non recursive } if(scalar @files == 0){ die "No photo files found\n" } #print "@files\n"; my $mw = Gtk2::Window->new; $mw->set_size_request( 400, 400 ); my $vbox = Gtk2::VBox->new( FALSE, 1 ); my $vp = Gtk2::Viewport->new( undef, undef ); my $sw = Gtk2::ScrolledWindow->new(undef, undef ); $sw->set_policy( 'automatic', 'automatic' ); $sw->add( $vp ); #set to last file, so first is next unshift(@files,pop (@files)); my $image = &load_image(1); #1 for forward, -1 for back #--------------------------- my $hbox= Gtk2::HBox->new( FALSE, 6 ); $hbox->set_border_width(2); my $font = Gtk2::Pango::FontDescription->from_string("Sans Bold 14"); my $lab1 = Gtk2::Label->new('Next ->'); $lab1->modify_font($font); $hbox->pack_end( $lab1, 1, 1, 1 ); my $lab2 = Gtk2::Label->new('<- Back'); $lab2->modify_font($font); $hbox->pack_end( $lab2, 1, 1, 1 ); $vbox->pack_start($sw, 1, 1, 1 ); $vbox->pack_end($hbox,0,0,0); $mw->add($vbox); $mw->show_all(); $mw->signal_connect( 'destroy', sub { Gtk2->main_quit } ); $mw->signal_connect('key-press-event' => \&proc_key); Gtk2->main; ########################################################### sub load_image { my $mode = shift; if($mode > 0){ push (@files,shift(@files)); #rotate files by 1 } else {unshift(@files,pop (@files)) } #go back 1 # It would seem that it would be better to load the # image from file, but it is actually faster to # use the PixbufLoader shown below # It is really noticable when you hold down the # forward key # # my $image = Gtk2::Image->new_from_file ( $files[0] ); # my $pb = $image->get_pixbuf; # my ( $x, $y ) = ( $pb->get_width, $pb->get_height ); #----faster and/or if you want to load an image from a scalar ------ my $image_data; open( FH, "< $files[0]" ); read( FH, $image_data, -s FH ); close FH; my $loader = Gtk2::Gdk::PixbufLoader->new; $loader->write( $image_data ); $loader->close; my $pixbuf = $loader->get_pixbuf; my $image = Gtk2::Image->new_from_pixbuf( $pixbuf ); my ( $x, $y ) = ( $pixbuf->get_width, $pixbuf->get_height ); #------------------------------------------------------ $vp->add( $image ); # if you want to adjust scrollbars ------------- # my $hadj = $sw->get_hadjustment; # my $vadj = $sw->get_vadjustment; # $hadj->set_value($x/4); # $vadj->set_value($y/4); #---------------------------------------------- $mw->show_all(); $mw->set_title( "$files[0] ${x}x${y}" ); return $image; } ##################################################### sub proc_key { my ($widget,$event,$parameter)= @_; my $key_val = $event->keyval(); # print "$key_val\n"; #right arrow or space if(($key_val == 32) || ($key_val == 65363)){ $image->clear; $vp->remove($image); $image = &load_image(1); return TRUE; } #left arrow if($key_val == 65361){ $image->clear; $vp->remove($image); $image = &load_image(-1); return TRUE; } # catch Esc or q to exit if( ($key_val == 113) || ($key_val == 65307) ) { &delete_event } #good practice to let the event propagate, should we need it somewhe +re else return FALSE; } ##################################### sub delete_event { Gtk2->main_quit; return FALSE; }
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re: zimg -- Perl/Gtk2 quick slideshow
by zentara (Cardinal) on Jan 06, 2006 at 21:30 UTC | |
|
Re: zimg -- Perl/Gtk2 quick slideshow
by Anonymous Monk on Oct 27, 2006 at 07:58 UTC | |
by zentara (Cardinal) on Oct 27, 2006 at 09:31 UTC |