view release on metacpan or  search on metacpan

Thumbnail.pm  view on Meta::CPAN

$Tk::Thumbnail::VERSION = '1.3';

package Tk::Thumbnail;

use Carp;
use File::Basename;
use Tk::widgets qw/ Animation JPEG LabEntry MultiMediaControls Pane PNG /;
use base qw/ Tk::Derived Tk::Pane /;
use vars qw/ $err $info /;
use strict;

Construct Tk::Widget 'Thumbnail';

sub ClassInit {

    my( $class, $mw ) = @_;

    $err  = $mw->Photo( -data => $class->err );
    $info = Tk->findINC( 'Thumbnail/images/info3.png' );

    $class->SUPER::ClassInit( $mw );

} # end ClassInit

sub Populate {

    my( $self, $args ) = @_;

    $self->SUPER::Populate( $args );

    $self->ConfigSpecs(
        -background => [ [ 'DESCENDANTS', 'SELF' ], 'background', 'Background',   undef ],
        -blank      => [ 'PASSIVE',                 'blank',      'Blank',            1 ],
        -columns    => [ 'PASSIVE',                 'columns',    'Columns',      undef ],
        -command    => [ 'CALLBACK',                'command',    'Command',  \&button1 ],
        -iheight    => [ 'PASSIVE',                 'iheight',    'Iheight',         32 ],
        -images     => [ 'PASSIVE',                 'images',     'Images',       undef ],
        -ilabels    => [ 'PASSIVE',                 'ilabels',    'Ilabels',          1 ],
        -iwidth     => [ 'PASSIVE',                 'iwidth',     'Iwidth',          32 ],
        -scrollbars => [ 'PASSIVE',                 'scrollbars', 'Scrollbars',  'osow' ],
    );

    $self->OnDestroy(
        sub {
            $err->delete;
            $self->free_photos;
        }
    );
      
} # end Populate

sub button1 {

    my( $label, $file, $bad_photo, $w, $h, $animated, $blank ) = @_;
    return if $bad_photo;

    my $tl = $label->Toplevel;
    $tl->withdraw;
    $tl->title( $file );
    $tl->minsize( 120, 120 );

    my ( $can_del, $p );
    if( UNIVERSAL::isa( $file, 'Tk::Photo' ) ) {
	$p = $file;
	$can_del = 0;
    } elsif( $animated ) {
	$p = $tl->Animation( -file => $file, -format => 'gif' );
	$p->blank( $blank );