view release on metacpan or  search on metacpan

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

######################################## SOH ###########################################
## Function : Additional Tk Class for Listbox-type HList with Data per Item, Sorting
##
## Copyright (c) 2004 - 2009 Michael Krause. All rights reserved.
## Special Thanks to B<Shaun Wandler> <wandler@unixmail.compaq.com>, whose
## Tk::HeaderResizeButton V1.3 has been used here.
## This program is free software; you can redistribute it and/or modify it
## under the same terms as Perl itself.
## 
## History  : V0.1	14-Jan-2004 	Class compound from HList, ResizeButton. MK
##            V0.2	20-Jan-2004 	Bugfix 'headerCreate' was not catched and %args->@args. MK
##            V0.3	14-Jul-2005 	Bugfix 'header Height' was not called correctly for TK 804.xx. MK
##            V0.4	13-Oct-2006 	Enhancement based on feedback from Rob Seegel. MK
##            V0.5	06-Apr-2009 	Enhancement based on feedback from Kai Ludick (DblClick on Header always raised HBttn-Cmd-CB). MK
##            V0.6	07-Apr-2009 	Enhancement based on feedback from Kai Ludick (configurable closedcolWidth, ResizeWidth). MK
######################################## EOH ###########################################

##############################################
### Use
##############################################
use Tk::HList;
use Tk::ItemStyle;
use Tk qw(Ev);

use strict;
use Carp;

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

########################################################################
package Tk::HeaderResizeButton;
#########################################################################
# Tk::HeaderResizeButton
# NOTE: This is an improved version of the Tk::ResizeButton
# Summary:  This widget creates a button for use in an HList header which
#           provides methods for resizing a column. This was heavily 
#	    leveraged from Columns.pm by Damion Wilson.
# Author:   Shaun Wandler, Updated by Slaven Rezic and Frank Herrmann, Michael Krause
# Date:     2009/04/07
# Revision: 0.6
#########################################################################=
# Note: For space reason all other documentation of Tk::HeaderResizeButton has
# been removed See Tk::HeaderResizeButton-Pod for details.
#
use base qw(Tk::Derived Tk::Button);

Construct Tk::Widget 'HeaderResizeButton';

sub ClassInit {
    my ($class, $window) = @_;

    $class->SUPER::ClassInit($window);
	$window->bind($class, '<ButtonRelease-1>', 'ButtonRelease');
	$window->bind($class, '<ButtonPress-1>',   'ButtonPress');
	$window->bind($class, '<Motion>',          'ButtonOver');
	$window->bind($class, '<ButtonRelease-3>', 'ColumnFullSize');
	$window->bind($class, '<Double-1>',        'ButtonDouble1');
	# Override these ones too
	$window->bind($class, '<Enter>', 'BttnEnter' );
	$window->bind($class, '<Leave>', 'BttnLeave' );
	return $class;
}

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

	# CREATE THE RESIZE CONTROL
	my $r_Widget;
	my $r_width = delete $args->{-resizerwidth} || 1;
	$r_Widget = $this->Component(
		'Frame'      => 'Trim_R',
		#-background  => 'white',
		#-relief      => 'raised',
		-borderwidth => 1,
		-width       => $r_width,
		-cursor 	 => 'sb_h_double_arrow',
	)->place(
		-bordermode => 'outside',
		-relheight => '1.0',
		-anchor	=> 'ne',
		-relx  	=> '1.0',
	);

	# CREATE THE COLUMNBAR
	$this->{columnBar} = $this->parent->Frame(
		-background  => 'white',
		-relief      => 'raised',
		-borderwidth => 2,
		-width       => 2,
	);

	$r_Widget->bind( '<ButtonRelease-1>'	=> sub { $this->ButtonRelease(1); } );
	$r_Widget->bind( '<ButtonPress-1>'		=> sub { $this->ButtonPress(1); } );
	$r_Widget->bind( '<Motion>' 			=> sub { $this->ButtonOver(1); } );
	$r_Widget->bind( '<Enter>'				=> sub { $this->TrimEnter(); } ); 
	$r_Widget->bind( '<Leave>'				=> sub { $this->TrimLeave(); } );

	# Override these ones too
	$this->bind( '<Enter>'					=> sub { $this->BttnEnter(); } );
	$this->bind( '<Leave>'					=> sub { $this->BttnLeave(); } );

	$this->SUPER::Populate($args);
	$this->ConfigSpecs(
		-column 			=> [ [ 'SELF', 'PASSIVE' ], 'column', 'Column', 0 ],

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

}
# AVOID ACTIVATING THE BUTTON, IF WE ARE IN THE TRIM
sub StateSalvation
{
	my ($this, $newlevel) = @_;
	if ($newlevel > 0) {
		$this->{m_Level}  |= $newlevel;
	}
	else {
		$this->{m_Level}  &= ~$newlevel;
	}
	if ($this->{m_Level} == 1 and not $this->{m_EdgeSelected}) {
		$this->configure(-state => 'active');
	}
	else {
		$this->configure(-state => 'normal');
	}
}

# Move a column bar which displays on top of the HList widget
# to indicate the eventual size of the column.
sub MoveColumnBar
{
	my $this = shift;

	my $hlist = $this->parent;
	my $height = $hlist->height() - $this->height();
	my $x      = $hlist->pointerx() - $hlist->rootx() + 1; # +1 for move right into gap

	$this->{columnBar}->place(
		'-x'      => $x,
		'-height' => $height - 5,
		'-y'      => $this->height() + 5,
	) unless $this->cget(-lastcolumn);
}
# REMOVES IT FROM DISPLAY without destroying it
sub HideColumnBar
{
	my $this = shift;
	$this->{columnBar}->placeForget();
}

1;


# sub EnterFocus
# {
# 	print "reached EnterFocus of HList\n";
#  my $w  = shift;
#  	print "widget is >$w<\n";
# # return unless defined $w;
# # my $Ev = $w->XEvent;
# # my $d  = $Ev->d;
# # $w->Tk::focus() if ($d eq 'NotifyAncestor' ||  $d eq 'NotifyNonlinear' ||  $d eq 'NotifyInferior');
# 	
# }

########################################################################
package Tk::HListplus;

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

Construct Tk::Widget 'HListplus';

# needed to include also the aliased commands
use Tk::Submethods ( 'header'    => [qw(configure cget create delete exists size)] );


#---------------------------------------------
# internal Setup function
#---------------------------------------------
sub CreateArgs
{
    my ($class, $this, $args) = @_;		

	# New for V0.4 auto-increase the Column-num by 1 to have a more Win32 behavior
	$args->{-columns}++ if $args->{-columns};

	return $class->SUPER::CreateArgs($this, $args);
}
sub Populate
{
    my ($this, $args) = @_;		

	my $data_background = delete $args->{-databackground};
	$data_background = $this->cget ('-background') unless defined $data_background;
	$this->{m_headerstyle} = delete $args->{-headerstyle} || $this->ItemStyle ('window', -padx => '0', -pady => '0', );

	#Invoke Superclass fill func
    $this->SUPER::Populate($args);
}

#---------------------------------------------
# OVERRIDE: new header function
#---------------------------------------------
sub header 
{
	# Parameters
	my ($this, $cmd, $column, @args) = @_;
	# Locals
	my (%args, %hlist_args, $key);
	#print "initial header args = >@_<\n" . "- " x 60 .  "\n";

	# Note that we process here only the create command
	if ($cmd eq 'create') {
		%args = @args;
	 	if (defined $args{-itemtype} and $args{-itemtype} eq 'resizebutton') {
			# Rip off all relevant options
			foreach $key (qw(-itemtype -widget -style -borderwidth -headerbackground -relief)) {
				$hlist_args{$key} = delete $args{$key} if defined $args{$key};
			}
			# Take over those that make sense
			$args{relief} = delete $hlist_args{relief} if $hlist_args{relief};
			$args{background} = delete $hlist_args{headerbackground} if $hlist_args{headerbackground};

			# Create a new Resize Button
			my $header = $this->HeaderResizeButton( 
					-column => $column,
					-lastcolumn => ($this->cget(-columns) == $column + 1),
					-highlightthickness => 0,
					%args,