Tk::CheckbuttonGroup - widget displays and manages a group of related checkbuttons

	use Tk::CheckbuttonGroup;

	my($top) = MainWindow->new();
	my @selected = qw(two four);
	my $checkbuttongroup = $top->CheckbuttonGroup (
		-list => [qw( one two three four five )],
		-orientation => 'vertical',
		-variable => \@selected,
		-command => sub {
			print @selected, "\n";
		}
	);

# CheckbuttonGroup.pl
# Version: 0.2.2
#
# By: Joseph Annino - jannino@jannino.com - http://www.jannino.com
# Copyright 2002 American Museum of Natural History
#
# 
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#

$Tk::CheckbuttonGroup::VERSION = '0.2.2';
package Tk::CheckbuttonGroup;

use Tk::widgets qw( Frame Checkbutton );
use base qw( Tk::Frame );
use strict;

use Tie::IxHash;

Construct Tk::Widget 'CheckbuttonGroup';

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

sub Populate {
	my ($self, $args) = @_;
		
	$self->SUPER::Populate($args);	
	
	#
	# configure the mega-widget
	#

	$self->{'_orientations'} = {
		'horizontal' => 'left',
		'h' => 'left',
		'vertical' => 'top',
		'v' => 'top',	
	};
	$self->{'_orientation'}	= 'horizontal';
	
	$self->ConfigSpecs(
		DEFAULT => ['ADVERTISED'],
		-command => ['CALLBACK', 'command', 'Command', sub { }],
		-variable => ['METHOD', 'variable', 'Variable', [ ]],
		-list =>	['METHOD', 'list', 'List', { }],
		-orientation => ['METHOD', 'orientation', 'Orientation', 'horizontal'],
	);
	
#	$self->Delegates( );
	
}


sub list {
	my ($self, $val) = @_;

	if (defined($val)) {
		# Remove old children
		foreach my $child ($self->Descendants('Checkbutton')) {
			$child->destroy();	
		}
		# Add checkboxes
		$val = $self->_newhash($val);
		foreach my $item (keys(%$val)) {
			$self->Component(
				Checkbutton => $item,
				-text => $item,
				-onvalue => $val->{$item},
				-command => sub {
					my $widget = $Tk::widget;
					my $onvalue = $widget->cget('-onvalue');
					my @todelete = ( );
					for (my $i = 0; $i < @{$self->{'_variable'}}; $i ++) {
						if ($self->{'_variable'}[$i] eq $onvalue) { push(@todelete, $i); }  
					}
					foreach (@todelete) {
						splice(@{$self->{'_variable'}}, $_, 1);
					}
					if (${$widget->cget('-variable')} eq $onvalue) {
						push (@{$self->{'_variable'}}, $onvalue);
					}
					$self->Callback('-command');	
				}
			)->pack( 
				-side => $self->{'_orientations'}{$self->{'_orientation'}},
				-anchor => 'w'
			);
		}
		$self->configure( -variable => $self->{'_variable'} );
	} else {
		my $result = { };
		foreach my $child ($self->Descendants('Checkbutton')) {
			$result->{$child->cget('-text')} = $child->cget('-onvalue');
		}
		return $result;
	}

}

sub variable {
	my ($self, $val) = @_;

	if (defined($val)) {
		if ( ref($val) ne 'ARRAY' ) { 
			$val = [ split(',',$$val) ];
		}
#print Dumper('--set', $val);	
	
		# Turn off all checkboxes
		foreach my $child ($self->Descendants('Checkbutton')) {
			$child->deselect();
		}
		# Turn on the ones asked for
		foreach my $item (@$val) {
			my $obj = $self->Subwidget($item);
			if (defined($obj)) {
				$obj->select();
			}
		}
		# Save the variable
		$self->{'_variable'} = $val;
	} else {
#print Dumper('--get', $self->{'_variable'});
		return $self->{'_variable'};
	}

}

sub orientation {
	my ($self, $val) = @_;
	
	if (defined($val)) {
		$self->{'_orientation'} = $val;
		foreach my $child ($self->Descendants('Checkbutton')) {
			$child->packForget();
			$child->pack(
				-side => $self->{'_orientations'}{$self->{'_orientation'}},
				-anchor => 'w'
			);
		}			
	} else {
		return $self->{'_orientation'};
	}

}


sub _newhash {
	my ($self, $var) = @_;

	my %hash;
	my @list; 

	if (ref($var) eq 'HASH') {
		tie(%hash, 'Tie::IxHash', %{$var});
		return \%hash;
	}
	if (ref($var) eq 'ARRAY') {
		if (ref($var->[0]) eq 'ARRAY') {
			# ( one => 1, two => 2 ) format
			tie(%hash, 'Tie::IxHash', @{$var->[0]});
			return \%hash;
		} else {
			foreach my $item (@{$var}) {
				push(@list, $item, $item);
			}
		}
	}
	if (!ref($var)) {
		foreach my $item (split(',',$var)) {
			push(@list, $item, $item);			
		}
	}
	tie(%hash, 'Tie::IxHash', @list);
	return \%hash;
	
}

1;
# Preloaded methods go here.

1;
__END__