view release on metacpan or  search on metacpan

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

package Tk::FileTree;

# FileTree -- TixFileTree widget
#
# Derived from Tk::DirTree

use strict;
use vars qw($VERSION);
$VERSION = '1.01';

use Tk;
use Tk::Derived;
use Tk::Tree;
use Tk::ItemStyle;
use Cwd;
use DirHandle;
use File::Spec qw();

use base  qw(Tk::Derived Tk::Tree);
use strict;

Construct Tk::Widget 'FileTree';

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

	$class->SUPER::ClassInit($mw);
	$mw->bind($class,'<FocusIn>','focus');
	$mw->bind($class,'<FocusOut>','unfocus');
	$mw->bind($class,'<Double-1>' => ['MouseButton','Double1',Ev('index',Ev('@'))]);
	$mw->bind($class,'<B1-Motion>',['MouseButton','Button1Motion',Ev('index',Ev('@'))]);
	$mw->bind($class,'<ButtonPress-1>',['FileTree_ButtonPress1', Ev('index',Ev('@'))]);
	$mw->bind($class,'<ButtonRelease-1>',['FileTree_ButtonRelease1']);
	$mw->bind($class,'<Shift-ButtonPress-1>',['MouseButton','ShiftButton1',Ev('index',Ev('@'))]);  #JWT:ADDED 20091020!
	$mw->bind($class,'<Control-ButtonPress-1>',['MouseButton','CtrlButton1',Ev('index',Ev('@'))]);
	$mw->bind($class,'<Alt-ButtonPress-1>',['MouseButton','Button1', Ev('index',Ev('@'))]);
	#THESE NEEDED TO GET TAB-FOCUS CYCLING RIGHT:
	$mw->bind($class,'<Tab>', sub { my $w = shift; $w->focusNext; });
	$mw->bind($class,'<<LeftTab>>', sub { my $w = shift; $w->focusPrev; });
	$mw->MouseWheelBind($class); # XXX Both needed?  M$-Windows seems to ignore (bummer!)
	$mw->YMouseWheelBind($class);

	return $class; 
}

my $bummer = ($^O eq 'MSWin32') ? 1 : 0;
my $sep = $bummer ? '\\' : '/';

*_fs_encode = eval { require Encode; 1 } ? sub { Encode::encode("iso-8859-1", $_[0]) } : sub { $_[0] };

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

	$cw->toplevel->bind('<<setPalette>>' => [$cw => 'fixPalette']);
	$cw->{'-showcursoralways'} = delete($args->{'-showcursoralways'})  if (defined $args->{'-showcursoralways'});
	$cw->{Configure}{'-font'} = $args->{'-font'}   #MUST ACTUALLY SET THE HList "DEFAULT" FONT FOR BOTH PLATFORMS!:
			|| ($bummer ? "{MS Sans Serif} 8" : "Helvetica -12 bold");
	my $disableFG = (defined $args->{'-disabledforeground'})
			? delete($args->{'-disabledforeground'}) : ($Tk::DISABLED_FG || '#a3a3a3');

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

    $cw->ConfigSpecs(
        -dircmd             => [qw/CALLBACK dirCmd DirCmd DirCmd/],
        -dirtree            => [qw/CALLBACK dirTree DirTree 0/],
        -showhidden         => [qw/PASSIVE showHidden ShowHidden 0/],
        -image              => [qw/PASSIVE image Image folder/],
        -fileimage          => [qw/PASSIVE image Image file/],
        -font               => [qw/METHOD font    Font/],
        -root               => [qw/PASSIVE root Directory 0/],
        -include            => [qw/PASSIVE include Include undef/],
        -exclude            => [qw/PASSIVE exclude Exclude undef/],
        -directory          => [qw/SETMETHOD directory Directory/, '.'],
		-showcursoralways   => [qw/PASSIVE showcursoralways showcursoralways 0/],
		-state              => ['METHOD', 'state', 'State', 'normal'],
		-disabledforeground => ['PASSIVE', 'disabledForeground', 'DisabledForeground', $disableFG],
		-background         => [qw/METHOD background Background/, ''],
		-foreground         => [qw/METHOD foreground Foreground/, ''],