package Tk::DocumentTree;

=head1 NAME

Tk::DocumentTree - Tk::ListBrowser based document list

=cut

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

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

require Tk::ListBrowser;
use File::Basename;
use Tk;
use Config;

Construct Tk::Widget 'DocumentTree';

my $save_pixmap = '
/* XPM */
static char *save[]={
"16 16 4 1",
". c None",
"# c #000000",
"a c #808080",
"b c #ffff00",
"................",
"..############..",
".#aaaaaaaaaaaa#.",
".#aaaaaaaaaaaa#.",
".#aaaaaaaaaaaa#.",
".#aaaaaaaaaaaa#.",
".#aaaaaaaaaaaa#.",
".#aaaaaaaaaaaa#.",
".#aa########aa#.",
".#aa########aa#.",
".#aa########aa#.",
".#aa########aa#.",
".#aa#bbbbbb#aa#.",
".#aa#bbbbbb#aa#.",
"..############..",
"................"};
';

=head1 SYNOPSIS

 require Tk::DocumentTree;
 my $tree= $window->DocumentTree(@options)->pack;

=head1 DESCRIPTION

B<Tk::DocumentTree> is a Tree like megawidget. It consists of a Label and a ListBrowser widget.

The Label on top displays the path all added entries have in commom.
It automatically creates a folder tree as entries are added.

Entries can have the status I<file> or I<untracked>
An entry is untracked when it does not exist as a file.

=head1 CONFIG VARIABLES

=over 4

=item Switch: B<-contextmenu>

Specify menuitems for a menu that pops on Button-3.
By default it has entries for collapseAll and expandAll,

=item Switch: B<-diriconcall>

Callback for obtaining the dir icon. By default it is set
to a call that returns the default folder.xpm in the Perl/Tk
distribution.

=item Switch: B<-entryselect>

Callback to execute when the user clicks (selects) and entry.

=item Switch: B<-fileiconcall>

Callback for obtaining the file icon. By default it is set
to a call that returns the default file.xpm in the Perl/Tk
distribution.

=item Switch: B<-saveiconcall>

Callback for obtaining the save icon. By default it is set
to a call that returns save icon embedded in this package.

=back

=head1 METHODS

=over 4

=cut

sub Populate {
	my ($self,$args) = @_;
	$self->SUPER::Populate($args);

	my $sep = '/';
	$sep = '\\' if $Config{osname} eq 'MSWin32';

	$self->{HAVECELLSIZE} = 0;
	my $topbar = $self->CreatePathBar;
	$self->Advertise(PATH => $topbar);
	my $tree = $self->ListBrowser(
		-arrange => 'tree',
		-autorefresh => 0,
		-browsecmd => ['EntryClick', $self],
		-filterforce => 1,
		-itemtype => 'imagetext',
		-selectmode => 'exclusive',
		-separator => $sep,
		-textanchor => 'w',
		-textside => 'right',
		-width => 250,
	)->pack(
		-padx => 2, 
		-pady => 2,
		-expand => 1, 
		-fill => 'both',
	);
	$self->Advertise(Tree => $tree);
	my $c = $tree->Subwidget('Canvas');
	$c->Tk::bind('<ButtonRelease-3>', sub { $self->lmPost(Ev('X'), Ev('Y')) });

	my (@contextmenu) = (
		['command' => 'Collapse All', -command => ['collapseAll', $self]],
		['command' => 'Expand All', -command => ['expandAll', $self]],
	);
	$self->ConfigSpecs(
		-background => ['SELF', 'DESCENDANTS'],
		-contextmenu => ['PASSIVE', undef, undef, \@contextmenu],
		-diriconcall => ['CALLBACK', undef, undef, ['DefaultDirIcon', $self]],
		-entryselect => ['CALLBACK', undef, undef, sub {}],
		-fileiconcall => ['CALLBACK', undef, undef, ['DefaultFileIcon', $self]],
		-refreshdelay => ['PASSIVE', undef, undef, 300],
		-saveiconcall => ['CALLBACK', undef, undef, ['DefaultSaveIcon', $self]],
		DEFAULT => [$tree],
	);
	$self->Delegates(
		'DEFAULT' => $tree,
	);
}

sub Add {
	my ($self, $new, $type) = @_;
	if ($type eq 'untracked') {
		my @peers = $self->infoRoot;
		my @op = (-image => $self->GetFileIcon($new));
		for (@peers) {
			if ($self->isDir($_)) {
				push @op, -before => $_;
				last;
			} elsif ($self->isFile($_)) {
				push @op, -before => $_;
				last;
			} elsif ($new lt $_) {
				push @op, -before => $_;
				last;
			}
		}
		my $n = $self->add($new, @op,
			-text => $new,
			-data => $type,
		);
	} else {
		my $sep = $self->cget('-separator');
		my $nsep = quotemeta($sep);

		my $name = '';
		my @path = ($new);
		@path = split /$nsep/, $new if $new =~ /$nsep/;

		while (@path) {
			my $title = shift @path;
			my $data = 'file';
			$data = 'dir' if @path;
			if ($name eq '') {
				$name = $title;
			} else {
				$name = $name . $sep . $title;
			}
			unless ($self->infoExists($name)) {
				my @op = (
					-data => $data,
				);
				my @peers = $self->GetPeers($name);
				
				#We want a sorted list, directories first
				if ($data eq 'dir') {
					for (@peers) {
						my $peer = $_;
						if ($self->isUntracked($peer)) { #ignore untracked entries
						} elsif ($self->isFile($peer)) { #we arrived at the end of the directory section
							push @op, -before => $peer;
							last;
						} elsif ($name lt $peer) {
							push @op, -before => $peer;
							last;
						}
					}
					push @op, -image => $self->GetDirIcon($self->GetFileName($name));
				} else {
					for (@peers) {
						my $peer = $_;
						if ($self->isDir($peer) or $self->isUntracked($peer)) { #weed through the untracked and directory section of the list
						} elsif ($name lt $peer) {
							push @op, -before => $peer;
							last;
						}
					}
					push @op, -image => $self->GetFileIcon($self->GetFileName($name));
				}
				my $n = $self->add($name, @op,
					-text => $title,
					-data => $data,
				);
			}
		}
	}
	$self->refreshList;
}

sub collapse {
	my ($self, $entry) = @_;
	
	my @children;
	if (defined $entry) {
		@children = $self->GetChildren($entry);
	} else {
		@children = $self->infoRoot;
	}

	for (@children) {
		if ($self->infoChildren($_)) {
			$self->collapse($_);
		}
		$self->close($_);
		$self->update;
	}
}

=item B<collapseAll>

Closes all folders in the Tree widget, except for the
path leading to the currently selected entry.

=cut

sub collapseAll {
	my $self = shift;
	my ($sel) = $self->infoSelection;
	$self->collapse;
	$self->update;
	$self->entryShow($self->GetFileName($sel)) if defined $sel;
	$self->refreshList;
}

sub CreatePathBar {
	return $_[0]->Label(
		-anchor => 'w',
	)->pack(
		-fill => 'x',
		-padx => 2,
		-pady => 2,
	)
}

sub DefaultDirIcon {
	return $_[0]->Pixmap(-file => Tk->findINC('folder.xpm'))
}

sub DefaultFileIcon {
	return $_[0]->Pixmap(-file => Tk->findINC('file.xpm'))
}

sub DefaultSaveIcon {
	return $_[0]->Pixmap(-data => $save_pixmap)
}

sub Delete {
	my ($self, $entry) = @_;
	my $par = $self->GetParent($entry);
	$self->delete($entry);
	if ($par ne '') {
		my @peers = $self->infoChildren($par);
		$self->Delete($par) unless @peers;
	}
	$self->refreshList;
}

sub DirList {
	my ($self, $path, $list) = @_;
	$list = [] unless defined $list;
	$path = '' unless defined $path;
	my @children = $self->GetChildren($path);
	for (@children) {
		if ($self->isDir($_)) {
			push @$list, $_;
			$self->ItemList($_, $list);
		}
	}
	return @$list;
}

=item B<entryAdd>I<($filename)>

Adds the entry $filename.
$filename can also be an untracked entry.

=cut

sub entryAdd {
	my ($self, $new) = @_;

	if (-d $new) {
		warn "You can not add a directory\n";
		return
	}
	my $untracked = not -e $new;

	my $type = 'file';
	if ($untracked) {
		$type = 'untracked';
	} else {
		my $sep = quotemeta($self->cget('-separator'));
		$new =~ s/^$sep// unless $Config{osname} eq 'MSWin32';
		my $compath = quotemeta($self->GetCommonPath($new));
		my $reg = $compath . $sep;
		$new =~ s/^$reg//
	}
#	$self->pause(5500);
	$self->Add($new, $type);
	$self->refreshList;
}

sub EntryClick {
	my ($self, $entry) = @_;
	return if $self->isDir($entry);
	$entry = $self->GetFileName($entry) unless $self->isUntracked($entry);
	$self->Callback('-entryselect', $entry);
}

=item B<entryDelete>I<($filename)>

Deletes the entry $filename.
$filename can also be an untracked entry.

=cut

sub entryDelete {
	my ($self, $entry) = @_;
	my $sep = $self->cget('-separator');
	$entry =~ s/^$sep// unless $Config{osname} eq 'MSWin32';
	$entry = $self->StripPath($entry);

	if ($self->isDir($entry)) {
		warn "You cannot delete a directory: $entry";
		return
	}

	$self->Delete($entry);
	my @c = $self->infoRoot;
	if (@c) {
		$self->GetCommonPath
	} else {
		$self->SetPath('');
	}
}

=item B<entryModified>I<($filename)>

Sets the icon in the $filename entry to the save icon, indicating the entry is modified.

=cut

sub entryModified {
	my ($self, $entry) = @_;
	my $sep = $self->cget('-separator');
	$entry =~ s/^$sep// unless $Config{osname} eq 'MSWin32';
	$entry = $self->StripPath($entry);
	$self->entryConfigure($entry, -image => $self->GetSaveIcon);
}

=item B<entrySaved>I<($filename)>

Sets the icon in the $filename entry to the default file icon, indicating the entry is saved.

=cut

sub entrySaved {
	my ($self, $entry) = @_;
	my $sep = $self->cget('-separator');
	$entry =~ s/^$sep// unless $Config{osname} eq 'MSWin32';
	$entry = $self->StripPath($entry);
	$self->entryConfigure($entry, -image => $self->GetFileIcon($entry));
}

=item B<entrySelect>I<($filename)>

Call this method if you want to change the selection.

=cut

sub entrySelect {
	my ($self, $entry) = @_;

	my $sep = $self->cget('-separator');
	my $sel = $entry;
	$sel =~ s/^$sep// unless $Config{osname} eq 'MSWin32';
	$sel = $self->StripPath($sel);

	$self->entryShow($entry);
	$self->selectionClear;
	$self->anchorClear;
	$self->selectionSet($sel);
}

=item B<entryShow>I<($filename)>

Expands the parth to $filename so it becomes visible.

=cut

sub entryShow {
	my ($self, $entry) = @_;
	my $sep = $self->cget('-separator');
	$entry =~ s/^$sep// unless $Config{osname} eq 'MSWin32';
	$entry = $self->StripPath($entry);
	my $parent = $self->infoParent($entry);
	while (defined $parent) {
		my $p = $self->get($parent);
		unless ($p->opened) {
			$self->open($parent);
		}
		$parent = $self->infoParent($parent);
	}
	$self->selectionSet($entry);
	$self->see($entry);
	$self->refreshList;
}

=item B<expandAll>

Opens all folders in the Tree widget.

=cut

sub expandAll {
	my ($self, $entry) = @_;
	my @children;
	if (defined $entry) {
		@children = $self->GetChildren($entry);
	} else {
		@children = $self->infoRoot;
	}
	for (@children) {
		if ($self->infoChildren($_)) {
			$self->open($_);
			$self->expandAll($_);
		}
	}
	$self->refreshList;
}

=item B<fileList>

Returns a list of all files in the document tree.
Untracked items are not included.

=cut

sub fileList {
	my $self = shift;
	my @list = $self->ItemList;
	my @out = ();
	for (@list) {
		push @out, $self->GetFileName($_);
	}
}

sub GetChildren {
	my ($self, $name) = @_;
	return $self->infoRoot if $name eq'';
	return $self->infoChildren($name)
}

sub GetCommonPath {
	my ($self, $new) = @_;

	my @items = $self->ItemList;
	my @files = ();
	while (@items) {
		my $item = shift @items;
		push @files, $self->GetFullPath($item);
	}
	
	my @xfiles = @files;
	push @xfiles, $new if defined $new;

	my @ifiles = ();
	my $sep = quotemeta($self->cget('-separator'));
	for (@xfiles) {
		my $file = $_;
		$file = $self->GetParent($file);
		my @p = split /$sep/, $file;
		push @ifiles, \@p;
	}

	my $newpath = '';
	if (@ifiles) {
		my $level = 0;
		while ($level >= 0) {
			my $equal = 1;
			my $value = $ifiles[0]->[$level];
			unless (defined $value) {
				$equal = 0;
				$level = -1;
			} else {
				for (0 .. @ifiles - 1) {
					if (defined $ifiles[$_]->[$level]) {
						unless ($ifiles[$_]->[$level] eq $value) {
							$equal = 0;
							last;
						}
					} else {
						$equal = 0;
						last;
					}
				}
				if ($equal) {
					if ($newpath eq '') {
						$newpath = $value
					} else {
						$newpath = $newpath . $self->cget('-separator') . $value;
					}
					$level ++;
				} else {
					$level = -1;
				}
			}
		}
	}

	my $oldpath = $self->GetPath;
	if ($newpath ne $oldpath) {
		$self->SetPath($newpath);
		my @untrack = $self->untrackedList;
		$self->deleteAll;
		for (@untrack) {
			$self->Add($_, 'untracked');
		}
		for (@files) {
			my $item = $_;
			my $reg = quotemeta($newpath) . $sep;
			$item =~ s/^$reg// unless $newpath eq '';
			$self->Add($item);
		}
	}
	return $newpath
}

sub GetDirIcon {
	my ($self, $name) = @_;
	return $self->Callback('-diriconcall', $name);
}

sub GetFileIcon {
	my ($self, $name) = @_;
	return $self->Callback('-fileiconcall', $name);
}

sub GetFileName {
	my ($self, $item) = @_;
	$item = $self->GetFullPath($item);
	unless ($Config{osname} eq 'MSWin32') {
		$item = $self->cget('-separator') . $item; #unless ($Config{osname} eq 'MSWin32');
	}
	return $item;
}

sub GetFullPath {
	my ($self, $name) = @_;
	my $commonpath = $self->GetPath;
	my $sep = $self->cget('-separator');
	$name = $commonpath . $sep . $name if $commonpath ne'';
	return $name;
}

sub GetParent {
	my ($self, $name) = @_;
	my $dir = dirname($name);
	$dir = '' if $dir eq '.';
	return $dir
}

sub GetPath {
	my $self = shift;
	my $path = $self->Subwidget('PATH')->cget('-text');
	my $sep = quotemeta($self->cget('-separator'));
	$path =~ s/^$sep//;
	return $path;
}

sub GetPeers {
	my ($self, $name) = @_;
	my $par = $self->decodeParent($name);
	return $self->infoRoot unless defined $par;
	return $self->infoChildren($par) if $self->infoExists($par);
	return ()
}

sub GetSaveIcon {
	my ($self, $name) = @_;
	return $self->Callback('-saveiconcall', $name);
}

sub isDir {
	my ($self, $item) = @_;
	return 1 if $self->infoData($item) eq 'dir';
	return 0;
}

sub isFile {
	my ($self, $item) = @_;
	return 1 if $self->infoData($item) eq 'file';
	return 0;
}

sub isUntracked {
	my ($self, $item) = @_;
	return 1 if $self->infoData($item) eq 'untracked';
	return 0;
}

sub ItemList {
	my ($self, $path, $list) = @_;
	$list = [] unless defined $list;
	$path = '' unless defined $path;
	my @children = $self->GetChildren($path);
	for (@children) {
		if ($self->isUntracked($_)) { #ignoring untracked
		} elsif ($self->isDir($_)) {
			$self->ItemList($_, $list)
		} else {
			push @$list, $_
		}
	}
	return @$list;
}

sub lmPost {
	my $self = shift;
	my ($x, $y) = $self->pointerxy;
	my $items = $self->cget('-contextmenu');
	if (@$items) {
		my $menu = $self->Menu(
			-menuitems => $items,
			-tearoff => 0,
		);
		$menu->bind('<Leave>', [$self, 'lmUnpost']);
		$self->{'l_menu'} = $menu;
		$menu->post($x - 6, $y - 6);
	}
}

sub lmUnpost {
	my $self = shift;
	my $menu = $self->{'l_menu'};
	if (defined $menu) {
		delete $self->{'l_menu'};
		$menu->unpost;
		$menu->destroy;
	}
}

sub PathCompare {
	my ($self, $path1, $path2) = @_;
	my @l1 = $self->PathList($path1);
	my @l2 = $self->PathList($path2);
	my $size1 = @l1;
	my $size2 = @l2;
	if ($size1 > $size2) {
		return 1
	} elsif ($size1 eq $size2) {
		return 0
	} else {
		return -1
	}
}

sub PathList {
	my ($self, $path) = @_;
	my $sep = $self->cget('-separator');
	return split /$sep/, $path
}

sub pause {
	my ($self, $time) = @_;
	my $var = 0;
	$self->after($time, sub { $time = 1 });
	$self->waitVariable(\$time);
}

sub refreshList {
	my ($self, $flag) = @_;
	
	my $delay = $self->cget('-refreshdelay');
	unless (defined $flag) {
		my $id = $self->{'timer_id'};
		$self->afterCancel($id) if defined $id;
		
		$id = $self->after($delay, [refreshTimer => $self]);
		$self->{'timer_id'} = $id;
		
		return
	}

	$self->setCellSize;
	my $c = $self->Subwidget('Tree')->Subwidget('Canvas');
	my ($view) = $c->yview;
	$self->refreshPurge;
	$self->after($delay, sub { $c->yview('moveto', $view) });

}

sub refreshTimer {
	my $self = shift;
	delete $self->{'timer_id'};
	$self->refreshList(1);
}

sub setCellSize {
	my ($self, $name) = @_;
	my $t = $self->Subwidget('Tree');
	unless ($self->{HAVECELLSIZE}) {
#		my $i = $t->get($name);
		$t->cellSize;
		$self->{HAVECELLSIZE} = 1
	}
#	$t->refreshPurge($t->index($name))
}

sub SetPath {
	my ($self, $path) = @_;
	$path = $self->cget('-separator') . $path unless ($Config{osname} eq 'MSWin32');
	$self->Subwidget('PATH')->configure(-text => $path);
}

sub StripPath {
	my ($self, $name) = @_;
	my $path = quotemeta($self->GetPath);
	my $sep = quotemeta($self->cget('-separator'));
	$name =~ s/^$path$sep// if $path ne '';
	return $name;
}

=item B<untrackedList>

=over 4

Returns a list of all untracked items.

=back

=cut

sub untrackedList {
	my $self = shift;
	my @top = $self->infoRoot('');
	my @untracked = ();
	for (@top) {
		push @untracked, $_ if $self->infoData($_) eq 'untracked'
	}
	return @untracked
}

=back

=head1 LICENSE

Same as Perl.

=head1 AUTHOR

Hans Jeuken (hanje at cpan dot org)

=head1 BUGS

Unknown. If you find any, please contact the author.

=head1 SEE ALSO

=over 4

=item L<Tk::ListBrowser>

=back

=cut

1;

__END__



