view release on metacpan or  search on metacpan

lib/Tk/JThumbnail.pm  view on Meta::CPAN

package Tk::JThumbnail;

use strict;
use warnings;
use Carp;
use File::Basename;
use Tk; # qw/Ev $XS_VERSION/;
#DEPRECIATED!:  use Tk::widgets qw/ Animation JPEG LabEntry MultiMediaControls Pane PNG /;
use Tk::widgets qw/ JPEG LabEntry Pane PNG Balloon /;
use base qw/ Tk::Derived Tk::Pane /;
use vars qw/ $VERSION $err $info $CORNER $haveAnimation/;

$VERSION = '2.4';
$haveAnimation = 0;
eval 'use Tk::widgets qw/ Animation /; $haveAnimation = 1; 1';

Tk::Widget->Construct('JThumbnail');

sub ClassInit {

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

#	$err  = $mw->Photo( -data => $class->err );
	$err  = Tk->findINC( 'JThumbnail/images/failimg.png' );
	$info = Tk->findINC( 'JThumbnail/images/info3.png' );
	$CORNER = __PACKAGE__ . "::corner";

	$class->SUPER::ClassInit( $mw );
	$mw->XscrollBind($class);
	$mw->YscrollBind($class);
	$mw->MouseWheelBind($class); # XXX Both needed?
	$mw->YMouseWheelBind($class);
	$mw->bind($class,'<FocusIn>','focus');
	$mw->bind($class,'<FocusOut>', 'unfocus');
	my $bits = pack("b15"x15,     #OPTIONAL IMAGE TO DISPLAY IN CORNER BETWEEN SCROLLBARS:
			"...............",
			".#############.",
			".############..",
			".###########...",
			".##########....",
			".#########.....",
			".########......",
			".#######.......",
			".######........",
			".#####.........",
			".####..........",
			".###...........",
			".##............",
			".#.............",
			"...............",
	);
	$mw->DefineBitmap($CORNER => 15,15, $bits);
	
	return $class;
} # end ClassInit

sub Populate {

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

	$self->toplevel->bind('<<setPalette>>' => [$self => 'fixPalette']);
	#Tk::Scrolled *EATS* THIS, AND DEFAULTS TO "osow"!:  $args->{'-scrollbars'} = 'osoe'  unless (defined $args->{'-scrollbars'});
	#NOTE:  Tk::Scrolled ALSO EATS (AND HANDLES FOR US): -width, -height, and -highlightthickness, -takefocus, AND POSSIBLY OTHERS!
	#SO THAT THOSE ARGS DO *NOT* APPEAR IN THE $args HASH HERE!:
	$self->{'-showcursoralways'} = delete($args->{'-showcursoralways'})  if (defined $args->{'-showcursoralways'});

	$self->{'-activebackground'} = delete($args->{'-activebackground'})  if (defined $args->{'-activebackground'});
	$self->SUPER::Populate( $args );
	$args->{'-activebackground'} = $self->{'-activebackground'}  if (defined $self->{'-activebackground'});