1 files changed, 113 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Tk/Dirlist.pm b/Master/tlpkg/tlperl0/lib/Tk/Dirlist.pm
new file mode 100755
index 00000000000..f16ce021f41
--- /dev/null
+++ b/Master/tlpkg/tlperl0/lib/Tk/Dirlist.pm
@@ -0,0 +1,113 @@
+package Tk::Dirlist;
+require Tk::Derived;
+require Tk::HList;
+require DirHandle;
+use Cwd;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dirlist.pm#5 $
+
+use base  qw(Tk::Derived Tk::HList);
+use strict;
+Construct Tk::Widget 'Dirlist';
+
+sub getimage
+{
+ my ($w,$key) = @_;
+ unless (exists $w->{$key})
+  {
+   $w->{$key} = $w->Pixmap(-id => $key);
+   unless ($w->{$key})
+    {
+     $w->{$key} = $w->Bitmap($key);
+    }
+  }
+ return $w->{$key};
+}
+
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ $cw->configure(-separator => '/', -itemtype => 'imagetext');
+ $cw->ConfigSpecs(-directory => ['SETMETHOD','directory','Directory','.']);
+}
+
+sub fullpath
+{
+ my ($path) = @_;
+ my $cwd = getcwd;
+ if (chdir($path))
+  {
+   $path = getcwd;
+   chdir($cwd);
+  }
+ else
+  {
+   warn "Cannot cd to $path:$!"
+  }
+# print "$path\n";
+ return $path;
+}
+
+sub AddDir
+{
+ my ($w,$dir) = @_;
+ my $path = '';
+ my $prefix = '';
+ my $first = 0;
+ my $name;
+ foreach $name (split m#/#,$dir)
+  {
+   $first++;
+   if ($name eq '')
+    {
+     next unless ($first == 1);
+     $path = '/';
+     $name = '/';
+    }
+   else
+    {
+     $path .= $prefix;
+     $path .= $name;
+     $prefix = '/';
+    }
+   unless ($w->info('exists' => $path))
+    {
+#     print "Add $path\n";
+     $w->add($path,-image => $w->getimage('folder'), -text => $name);
+    }
+  }
+}
+
+sub choose_image
+{
+ my ($w,$path) = @_;
+ return 'folder' if (-d $path);
+ return 'srcfile'  if ($path =~ /\.[ch]$/);
+ return 'textfile' if (-T $path);
+ return 'file';
+}
+
+
+sub directory
+{
+ my ($w,$key,$val) = @_;
+ my $h = DirHandle->new($val);
+ $w->AddDir($val = fullpath($val));
+ my $f;
+ $w->entryconfigure($val,-image => $w->getimage('act_fold'));
+ foreach $f (sort $h->read)
+  {
+   next if ($f =~ /^\.+$/);
+   my $path = "$val/$f";
+   unless ($w->info('exists' => $path))
+    {
+     my $image = $w->getimage($w->choose_image($path));
+     $w->add($path,-image => $image, -text => $f);
+    }
+  }
+ $h->close;
+}
+
+1;