view release on metacpan or  search on metacpan

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

######################################## SOH ###########################################
## Function : Replacement for Tk:Optionmenu (more flexible handling for 'image_only')
##
## Copyright (c) 2002-2009 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  : V1.0	30-Aug-2002 	Class derived from original Optionmenu. MK
##            V1.1  19-Nov-2002 	Added popup() function MK.
##            V1.2  07-Nov-2003 	Added -tearoff option MK.
##            V1.3  16-Dec-2004 	Added multicolumn & activate option (-rows/-activate option) MK.
##            V1.4  14-Jun-2005 	Added second hierarchy for the options,
##                                  Optionformat: [ label, value], [[keylabel, \@subopts], undef], [], ... MK.
##            V1.5  29-Jul-2005 	Added columnbreak for second hierarchy options
##            V1.6  14-Sep-2005 	Rewrite: Added TRUE multi-level hierarchy options with color opts. MK
##            V1.7  30-Sep-2005 	Added selection-validate operation. MK
##            V1.8  25-Sep-2006 	Added detection for loops, which might crash the app for linux. MK
##            V1.9  11-Mar-2009 	Added -popover 'cursor for popup() func. MK
##            V2.0  06-Feb-2014 	Added '-clearoption*' function to automatically add a 'clear entry'. MK
##
######################################## EOH ###########################################
package Tk::Optionbox;

##############################################
### Use
##############################################
use Storable qw(freeze);
use Tk;
use Tk::Menubutton;
use Tk::Menu;

use strict;
use Carp qw(:DEFAULT cluck);

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

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


use constant CLEAR_OPTION_TAG	=>	'__CLEAR__OPTIONBOX_ENTRY__';

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

my $ClearXPM;

#---------------------------------------------
sub ClassInit {
	my ($class, $window) = (@_);
	
	$class->SUPER::ClassInit($window);
	$window->bind ($class, '<Control-Tab>','focusNext');
	$window->bind ($class, '<Control-Shift-Tab>','focusPrev');
	$window->bind ($class, '<Tab>', 'focus');

	###################################################
	# The following Image is borrowed from free
	# Silk icon set 1.3 by Mark James
	# http://www.famfamfam.com/lab/icons/silk/
	###################################################
	$ClearXPM = $window->Pixmap( -data =>  <<'ClearXPM_EOP'
/* XPM */
static char *cancel[] = {
/* columns rows colors chars-per-pixel */
"16 16 10 1",
"  c #EE0000",
". c #F70706",
"X c #F9231D",
"o c #FB3230",
"O c #F84737",
"+ c #FC504A",
"@ c #FE6659",
"# c #FECACA",
"$ c #FFEFEF",
"% c None",
/* pixels */
"%%%%%%%%%%%%%%%%",
"%%%%....... %%%%",
"%%% o@@@@+@X.%%%",
"%% o@+ooooo@X %%",
"%.o@+#+oo+#++X %",
"%.@O#$$++$$#oO.%",
"%.@o@$$$$$$oXO.%",
"%.@oo+$$$$OX.O.%",
"%.@oX+$$$$oX.+ %",
"%.+o+$$$$$$o.O %",
"%.+o#$$oo$$#Xo.%",
"% X++#+..o#oOX %",
"%% X+X.X..XoX %%",
"%%% XOOOOOOX %%%",
"%%%% ... .  %%%%",
"%%%%%%%%%%%%%%%%"
};
ClearXPM_EOP
	) unless $ClearXPM;

}