view release on metacpan or  search on metacpan

lib/Tk/ListBrowser/LBHeader.pm  view on Meta::CPAN

package Tk::ListBrowser::LBHeader;

use strict;
use warnings;
use vars qw($VERSION);
$VERSION = 0.11;

use base qw(Tk::Derived Tk::Frame);
Construct Tk::Widget 'LBHeader';

use Tk;

my $down_arrow = '#define down_width 10
#define down_height 10
static unsigned char down_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0xff, 0x03, 0xfe, 0x01, 0xfc, 0x00, 0x78, 0x00,
   0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 };
';

my $empty_icon = '#define empty_width 10
#define empty_height 10
static unsigned char empty_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 };
';

my $up_arrow = '#define up_width 10
#define up_height 10
static unsigned char up_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x30, 0x00, 0x78, 0x00, 0xfc, 0x00,
   0xfe, 0x01, 0xff, 0x03, 0x00, 0x00, 0x00, 0x00 };
';

sub Populate {
	my ($self,$args) = @_;

	my $column = delete $args->{'-column'};
	die "You need to specify the -column option" unless defined $column;

	my $lb = delete $args->{'-listbrowser'};
	die "You need to specify the -listbrowser option" unless defined $lb;

	$self->SUPER::Populate($args);
	
	$self->{ACTIVE} = 0;
	$self->{COLUMN} = $column;
	$self->{LISTBROWSER} = $lb;
	
	my $label = $self->Label(
	)->pack(-side => 'left');
	$self->Advertise(Label => $label);

	my $sizer = $self->Label(
		-borderwidth => 2,
	)->pack(-side => 'right', -fill => 'y');
	$self->Advertise(Sizer => $sizer);
	$sizer->bind('<Enter>', [$self, 'SizerEnter']);
	$sizer->bind('<Leave>', [$self, 'SizerLeave']);
	$sizer->bind('<Button-1>', [$self, 'SizerClick', $self, Ev('x'), Ev('y')]);
	$sizer->bind('<ButtonRelease-1>', [$self, 'SizerRelease']);
	$sizer->bind('<B1-Motion>', [$self, 'Resize', $self, Ev('x'), Ev('y')]);
	

	my $sort = $self->Label->pack(-side => 'right');
	$self->Advertise(Sort => $sort);
	
	for ($self, $label, $sort) {
		my $item = $_;