view release on metacpan or  search on metacpan

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

######################################## SOH ###########################################
## Function : Additional Tk Class for a nicer Checkbutton
##
## Copyright (c) 2002-2007 Michael Krause. All rights reserved.
## This program is free software; you can redistribute it and/or modify it
## under the same terms as Perl itself.
##
## History  : V2.1	24-Oct-2002 	Class released. MK
##            V2.2	12-Nov-2002 	Small Bugfix. MK
##            V2.3	30-Sep-2004 	Enhanced state disabled w/o highlightthickness. MK
##            V2.4	03-May-2005 	Added variable size option. MK
##            V2.5	19-Jul-2005 	Bugfix for noInitialCallback option - executed never if set. MK
##            V2.6	03-Apr-2007 	Added activeForeground option. MK
##            V2.7	14-Feb-2008 	Added -variable retrieval. MK
##            V2.8	21-Sep-2011 	Added -background update during set for catching unchanged BGs due to earlier invisibility. MK
##
######################################## EOH ###########################################
package Tk::Checkbox;

##############################################
### Use
##############################################
use Tk;
use Tk::Canvas;
use Tk::Frame;

use strict;
use Carp;

use vars qw ($VERSION);
$VERSION = '2.7';

use base qw (Tk::Derived Tk::Frame);

########################################################################
Tk::Widget->Construct ('Checkbox');

#---------------------------------------------
sub ClassInit {
	my ($class, $window) = (@_);
	$class->SUPER::ClassInit($window);

	# Note these keyboard-Keys are only usable, if the widget gets 'focus'
	$window->bind ($class, '<ButtonPress-1>', 'set');
	$window->bind ($class, '<space>', 'set');
	$window->bind ($class, '<Control-Tab>','focusNext');
	$window->bind ($class, '<Control-Shift-Tab>','focusPrev');
	$window->bind ($class, '<Tab>', 'focus');
}

#---------------------------------------------
sub Populate {
	my ($this, $args) = @_;

	# Retrieve standard background
	if (defined ($args->{-bg})) {
		$args->{-background} = $args->{-bg};
	}
	# Retrieve standard foreground
	if (defined ($args->{-fg})) {
		$args->{-foreground} = $args->{-fg};
	}
	my $common_background = (defined($args->{-background})) ? 
										$args->{-background} :
										$this->cget ('-background');
	my $common_foreground = (defined($args->{-foreground})) ? 
										$args->{-foreground} :
										$this->parent->cget('-foreground');

	# retrieve extra option
	$this->{m_noInitialCallback} = delete $args->{-noinitialcallback};
	my $size = delete $args->{-size} || 15;
	
	# Create a Closure for saving the current value,
	# if there is no variable spec'd
	unless (defined $args->{-variable}) {
		my $gen = (defined ($args->{-offvalue})) ? $args->{-offvalue} : 0;
		my $var = \$gen;
		$args->{-variable} = $var;
	}
	# retrieve default values
	$this->{m_OffValue} = (defined($args->{-offvalue})) ? delete $args->{-offvalue} : 0;
	$this->{m_OnValue}  = (defined($args->{-onvalue} )) ? delete $args->{-onvalue}  : 1;
	

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

	#Widget Creation
	my $canvas = $this->Canvas(
    	-height => $size,
    	-width => $size,
	)->pack(
    	-fill => 'both',