<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package ProjektExplorer;

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

use Tk;
use Tk::Derived;
use Tk::Tree;
use Cwd;
use DirHandle;

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

use strict;

Construct Tk::Widget 'ProjektExplorer';

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

    $cw-&gt;SUPER::Populate( $args );

    $cw-&gt;ConfigSpecs(
        -dircmd         =&gt; [qw/CALLBACK dirCmd DirCmd DirCmd/],
        -showhidden     =&gt; [qw/PASSIVE showHidden ShowHidden 0/],
        -closeFolderImage          =&gt; [qw/PASSIVE closeFolderImage closeFolderImage folder/],
        -openFolderImage          =&gt; [qw/PASSIVE openFolderImage openFolderImage folder/],
        -pageImage          =&gt; [qw/PASSIVE pageImage pageImage folder/],
        -projectImage          =&gt; [qw/PASSIVE projectImage projectImage folder/],
        -root          =&gt; [qw/PASSIVE root root/],
        -directory      =&gt; [qw/SETMETHOD directory Directory ./],
        -value          =&gt; '-directory');

    $cw-&gt;configure( -separator =&gt; '/', -itemtype =&gt; 'imagetext');
}

sub DirCmd {
	my($w, $dir, $showhidden)=@_;
	$dir.="/" unless $dir=~m/\/$/i;
	my $dirName=$w-&gt;cget('-root').$dir;
	my $h=DirHandle-&gt;new($dirName) or return();
	my @names=grep($_ ne '.' &amp;&amp; $_ ne '..', $h-&gt;read);
	@names = grep(!/^[.]/, @names ) unless $showhidden;
#	map {print "$_\n"}@names;
	return(@names);
}

sub directory{
	# Einstieg!
	my ($w,$key,$val) = @_;
	$w-&gt;delete('all');
	my $dirName=$w-&gt;cget('-directory');
	$dirName=~s/\/$//;
	$w-&gt;configure(-root=&gt;$dirName);
	if (defined $w-&gt;cget('-image')){
		$w-&gt;chdir($val);
	}
	else{
		$w-&gt;afterIdle([$w, 'chdir'=&gt;$val]);
	}
}


sub chdir{
	my($w,$val)=@_;
	my $name=$w-&gt;cget('-directory');
	($name)=($name=~m#([^/]+?)/$#);
	$w-&gt;add_to_tree('/', $name, "", '-projectImage') unless $w-&gt;infoExists('/');
	# $w-&gt;OpenCmd('/');
	$w-&gt;setmode('/', 'open' );
}


sub OpenCmd {
	my($w, $dir)=@_;

	my $parent=$dir;
	$dir='' if $dir eq '/';
	foreach my $name ($w-&gt;dirnames($parent)) {
		next if ($name eq '.' || $name eq '..');
        	my $subdir="$dir/$name";

        	# next unless -d $w-&gt;cget('-root').$subdir;

        	if($w-&gt;infoExists($subdir)) {
			$w-&gt;show(-entry=&gt;$subdir);
		}

		else{
			if(-d $w-&gt;cget('-root').$subdir){
				$w-&gt;add_to_tree($subdir, $name, $parent, '-openFolderImage');
			}
			else{
				if($name=~m/\.txt$/i){
					$w-&gt;add_to_tree($subdir, $name, $parent, '-pageImage');
				}
			}
		}
	}
}


sub add_to_tree{
	my($w, $dir, $name, $parent, $art ) = @_;
	# $art='-pageImage' unless $art;
	my $image = $w-&gt;cget($art);
	my $mode = 'none';
	$mode = 'open' if -d ($w-&gt;cget('-root').$dir);
	my $data=$w-&gt;cget('-root').$dir;
	my @args = (-image=&gt;$image, -text=&gt;$name, -data=&gt;$data);

	if($parent){ # Add in alphabetical order.
		foreach my $sib ($w-&gt;infoChildren($parent)){
			my $a;
			my $b;
			if (-d ($w-&gt;cget('-root').$sib)){
				$a="A".$sib;
			}
			else{
				$a="B".$sib;
			}

			if (-d ($w-&gt;cget('-root').$dir)){
				$b="A".$dir;
			}
			else{
				$b="B".$dir;
			}

			if($a gt $b) {
				push @args, (-before =&gt; $sib);
				last;
			}
		}
	}

	$w-&gt;add($dir, @args);

	$w-&gt;setmode( $dir, $mode );
}

sub has_subdir{
	my( $w, $dir ) = @_;
	foreach my $name ($w-&gt;dirnames($dir)){
		next if ($name eq '.' || $name eq '..');
		next if ($name =~ /^\.+$/);
		# print $w-&gt;cget('-root')."$dir/$name\n";
		return(1) if -d $w-&gt;cget('-root')."$dir/$name";
	}
	return( 1 );
}

sub dirnames {
	my ($w, $dir)=@_;
	my @names=$w-&gt;Callback('-dircmd', $dir, $w-&gt;cget('-showhidden'));
	return(@names);
}

sub getAktRoot{
	my $w=shift;
	return $w-&gt;cget('-root');
}

__END__
</pre></body></html>