home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _ee5218b67196c9708a5bea99c8466081 < prev    next >
Encoding:
Text File  |  2004-06-01  |  2.0 KB  |  114 lines
  1. package Tk::Dirlist;
  2. require Tk::Derived;
  3. require Tk::HList;
  4. require DirHandle;
  5. use Cwd;
  6.  
  7. use vars qw($VERSION);
  8. $VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dirlist.pm#5 $
  9.  
  10. use base  qw(Tk::Derived Tk::HList);
  11. use strict;
  12. Construct Tk::Widget 'Dirlist';
  13.  
  14. sub getimage
  15. {
  16.  my ($w,$key) = @_;
  17.  unless (exists $w->{$key})
  18.   {
  19.    $w->{$key} = $w->Pixmap(-id => $key);
  20.    unless ($w->{$key})
  21.     {
  22.      $w->{$key} = $w->Bitmap($key);
  23.     }
  24.   }
  25.  return $w->{$key};
  26. }
  27.  
  28.  
  29. sub Populate
  30. {
  31.  my ($cw,$args) = @_;
  32.  $cw->configure(-separator => '/', -itemtype => 'imagetext');
  33.  $cw->ConfigSpecs(-directory => ['SETMETHOD','directory','Directory','.']);
  34. }
  35.  
  36. sub fullpath
  37. {
  38.  my ($path) = @_;
  39.  my $cwd = getcwd;
  40.  if (chdir($path))
  41.   {
  42.    $path = getcwd;
  43.    chdir($cwd);
  44.   }
  45.  else
  46.   {
  47.    warn "Cannot cd to $path:$!"
  48.   }
  49. # print "$path\n";
  50.  return $path;
  51. }
  52.  
  53. sub AddDir
  54. {
  55.  my ($w,$dir) = @_;
  56.  my $path = '';
  57.  my $prefix = '';
  58.  my $first = 0;
  59.  my $name;
  60.  foreach $name (split m#/#,$dir)
  61.   {
  62.    $first++;
  63.    if ($name eq '')
  64.     {
  65.      next unless ($first == 1);
  66.      $path = '/';
  67.      $name = '/';
  68.     }
  69.    else
  70.     {
  71.      $path .= $prefix;
  72.      $path .= $name;
  73.      $prefix = '/';
  74.     }
  75.    unless ($w->info('exists' => $path))
  76.     {
  77. #     print "Add $path\n";
  78.      $w->add($path,-image => $w->getimage('folder'), -text => $name);
  79.     }
  80.   }
  81. }
  82.  
  83. sub choose_image
  84. {
  85.  my ($w,$path) = @_;
  86.  return 'folder' if (-d $path);
  87.  return 'srcfile'  if ($path =~ /\.[ch]$/);
  88.  return 'textfile' if (-T $path);
  89.  return 'file';
  90. }
  91.  
  92.  
  93. sub directory
  94. {
  95.  my ($w,$key,$val) = @_;
  96.  my $h = DirHandle->new($val);
  97.  $w->AddDir($val = fullpath($val));
  98.  my $f;
  99.  $w->entryconfigure($val,-image => $w->getimage('act_fold'));
  100.  foreach $f (sort $h->read)
  101.   {
  102.    next if ($f =~ /^\.+$/);
  103.    my $path = "$val/$f";
  104.    unless ($w->info('exists' => $path))
  105.     {
  106.      my $image = $w->getimage($w->choose_image($path));
  107.      $w->add($path,-image => $image, -text => $f);
  108.     }
  109.   }
  110.  $h->close;
  111. }
  112.  
  113. 1;
  114.