package Tk::DirTree;
use vars qw($VERSION);
$VERSION = '3.023'; # $Id: //depot/Tk8/Tixish/DirTree.pm#23 $
use Tk;
use Tk::Derived;
use Tk::Tree;
use Cwd;
use DirHandle;
use base  qw(Tk::Derived Tk::Tree);
use strict;
Construct Tk::Widget 'DirTree';
sub Populate{my($cw,$args)=@_;
$cw->SUPER::Populate($args);
$cw->ConfigSpecs(-dircmd=>[qw/CALLBACK dirCmd DirCmd DirCmd/],-showhidden=>[qw/PASSIVE showHidden ShowHidden 0/],-image=>[qw/PASSIVE image Image folder/],-directory=>[qw/SETMETHOD directory Directory ./],-value=>'-directory');
$cw->configure(-separator=>'/',-itemtype=>'imagetext');}sub DirCmd{my($w,$dir,$showhidden)=@_;
my$h=DirHandle->new($dir)or return();
my@names=grep($_ ne '.'&&$_ ne '..',$h->read);
@names=grep(!/^[.]/,@names)unless$showhidden;
return(@names);}*dircmd=\&DirCmd;
sub fullpath{my($path)=@_;
my$cwd=getcwd();
if(chdir($path)){$path=getcwd();
chdir($cwd)||die"Cannot cd back to $cwd:$!";}else{warn"Cannot cd to $path:$!"}return$path;}sub directory{my($w,$key,$val)=@_;
if(defined$w->cget('-image')){$w->chdir($val);}else{$w->afterIdle([$w,'chdir'=>$val]);}}sub chdir{my($w,$val)=@_;
my$fulldir=fullpath($val);
my$parent='/';
if($^O eq 'MSWin32'){if($fulldir=~s/^([a-z]:)//i){$parent=$1;}}$w->add_to_tree($parent,$parent)unless$w->infoExists($parent);
my@dirs=($parent);
foreach my $name(split(/[\/\\]/,$fulldir)){next unless length$name;
push@dirs,$name;
my$dir=join('/',@dirs);
$w->add_to_tree($dir,$name,$parent)unless$w->infoExists($dir);
$parent=$dir;}$w->OpenCmd($parent);
$w->setmode($parent,'close');}sub OpenCmd{my($w,$dir)=@_;
my$parent=$dir;
$dir='' if$dir eq '/';
foreach my $name($w->dirnames($parent)){next if($name eq '.'||$name eq '..');
my$subdir="$dir/$name";
next unless-d$subdir;
if($w->infoExists($subdir)){$w->show(-entry=>$subdir);}else{$w->add_to_tree($subdir,$name,$parent);}}}*opencmd=\&OpenCmd;
sub add_to_tree{my($w,$dir,$name,$parent)=@_;
my$image=$w->Getimage($w->cget('-image'));
my$mode='none';
$mode='open' if$w->has_subdir($dir);
my@args=(-image=>$image,-text=>$name);
if($parent){foreach my $sib($w->infoChildren($parent)){if($sib gt$dir){push@args,(-before=>$sib);
last;}}}$w->add($dir,@args);
$w->setmode($dir,$mode);}sub has_subdir{my($w,$dir)=@_;
foreach my $name($w->dirnames($dir)){next if($name eq '.'||$name eq '..');
next if($name=~/^\.+$/);
return(1)if-d"$dir/$name";}return(0);}sub dirnames{my($w,$dir)=@_;
my@names=$w->Callback('-dircmd',$dir,$w->cget('-showhidden'));
return(@names);}
__END__

#  Copyright (c) 1996, Expert Interface Technologies
#  See the file "license.terms" for information on usage and redistribution
#  of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#  The file man.macros and some of the macros used by this file are
#  copyrighted: (c) 1990 The Regents of the University of California.
#               (c) 1994-1995 Sun Microsystems, Inc.
#  The license terms of the Tcl/Tk distrobution are in the file
#  license.tcl.

