home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / FileSelect.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  16.3 KB  |  532 lines
  1. package Tk::FileSelect; 
  2.  
  3. use Tk qw(Ev);
  4. use English;
  5. use strict;
  6. use Carp;
  7. require Tk::Listbox;
  8. require Tk::Button;
  9. require Tk::Dialog;
  10. require Tk::Toplevel;
  11. require Tk::LabEntry;       
  12. require Cwd;
  13. @Tk::FileSelect::ISA = qw(Tk::Toplevel);           
  14.  
  15. Construct Tk::Widget 'FileSelect';
  16.  
  17. =head1 NAME
  18.  
  19. FileSelect - a widget for choosing files
  20.  
  21. =head1 SYNOPSIS
  22.  
  23.  use Tk::FileSelect;
  24.  
  25.  $FSref = $top->FileSelect(-directory => $start_dir);
  26.                $top            - a window reference, e.g. MainWindow->new
  27.                $start_dir      - the starting point for the FileSelect
  28.  $file = $FSref->Show;
  29.                Executes the fileselector until either a filename is
  30.                accepted or the user hits Cancel. Returns the filename
  31.                or the empty string, respectively, and unmaps the
  32.                FileSelect.
  33.  $FSref->configure(option => value[, ...])
  34.                Please see the Populate subroutine as the configuration
  35.                list changes rapidly.
  36.  
  37. =head1 DESCRIPTION
  38.  
  39.    This Module pops up a Fileselector box, with a directory entry on
  40.    top, a list of directories in the current directory, a list of
  41.    files in the current directory, an entry for entering/modifying a
  42.    file name, an accept button and a cancel button.
  43.  
  44.    You can enter a starting directory in the directory entry. After
  45.    hitting Return, the listboxes get updated. Double clicking on any
  46.    directory shows you the respective contents. Single clicking on a
  47.    file brings it into the file entry for further consideration,
  48.    double clocking on a file pops down the file selector and calls
  49.    the optional command with the complete path for the selected file.
  50.    Hitting return in the file selector box or pressing the accept
  51.    button will also work. *NOTE* the file selector box will only then
  52.    get destroyed if the file name is not zero length. If you want
  53.    yourself take care of it, change the if(length(.. in sub
  54.    accept_file.
  55.  
  56. =head1 AUTHORS
  57.  
  58. Based on original FileSelect by
  59. Klaus Lichtenwalder, Lichtenwalder@ACM.org, Datapat GmbH, Munich, April 22, 1995 
  60. adapted by  Frederick L. Wagner, derf@ti.com, Texas Instruments Incorporated, Dallas, 21Jun95
  61.  
  62. =head1 HISTORY 
  63.  
  64.  950621 -- The following changes were made:
  65.    1: Rewrote Tk stuff to take advantage of new Compound widget module, so
  66.       FileSelect is now composed of 2 LabEntry and 2 ScrlListbox2 
  67.       subwidgets.
  68.    2: Moved entry labels (from to the left of) to above the entry fields.
  69.    3: Caller is now able to control these aspects of widget, in both
  70.         FileSelect (new) and configure :
  71.  
  72.         (Please see subroutine Populate    for details, as these options 
  73.          change rapidly!)
  74.  
  75.    4: I changed from Double-Button-1 to Button-1 in the Files listbox,
  76.       to work with multiple mode in addition to browse mode.  I also
  77.       made some name changes (LastPath --> saved_path, ...).
  78.    5: The show method is not yet updated.  
  79.    6: The topLevel stuff is not done yet.  I took it out while I toy with
  80.       the idea of FileSelect as a subwidget.  Then the 'normal' topLevel
  81.       thing with Buttons along the bottom could be build on top of it. 
  82.  
  83.  By request of Henry Katz <katz@fs09.webo.dg.com>, I added the functionality
  84.  of using the Directory entry as a filter. So, if you want to only see the
  85.  *.c files, you add a .c (the *'s already there :) and hit return.
  86.  
  87.  95/10/17, SOL, LUCC.  lusol@Lehigh.EDU 
  88.    
  89.   . Allow either file or directory names to be accepted.
  90.   . Require double click to move into a new directory rather than a single 
  91.     click.  This allows a single click to select a directory name so it can
  92.     be accepted.
  93.   . Add -verify list option so that standard Perl file test operators (like
  94.     -d and -x) can be specified for further name validation.  The default
  95.     value is the special value '!-d' (not a directory), so any name can be
  96.     selected as long as it's not a directory - after all, this IS FileSelect!
  97.  
  98.     For example:
  99.  
  100.       $fs->configure(-verify => ['-d', [\&verify_code, $P1, $P2, ... $Pn]]);
  101.  
  102.     ensures that the selected name is a directory.  Further, if an element of
  103.     the list is an array reference, the first element is a code reference to a
  104.     subroutine and the remaining optional elements are it's parameters.  The
  105.     subroutine is called like this:
  106.  
  107.       &verify_code($cd, $leaf, $P1, $P2, ... $Pn);
  108.  
  109.     where $cd is the current directory, $leaf is a directory or file name, and
  110.     $P1 .. $Pn are your optional parameters.  The subroutine should return TRUE
  111.     if success or FALSE if failure.
  112.  
  113.  961008 -- derf@ti.com :
  114.    By request of Jim Stern <js@world.northgrum.com> and Brad Vance
  115.    <bvance@ti.com>, I updated the Accept and Show functions to support 
  116.    selection of multiple files.  I also corrected a typo in the -verify code.
  117.  
  118. =cut 
  119.  
  120. sub Cancel
  121. {
  122.  my ($cw) = @_;
  123.  $cw->{Selected} = undef;
  124. }
  125.  
  126. sub Accept {
  127.  
  128.     # Accept the file or directory name if possible.
  129.     
  130.     my ($cw) = @_;
  131.  
  132.     my($path, $so) = ($cw->cget('-directory'), $cw->SelectionOwner);
  133.     my $leaf = undef;
  134.     my $leaves;
  135.     my %error_text = (
  136.         '-r' => 'is not readable by effective uid/gid',
  137.         '-w' => 'is not writeable by effective uid/gid',
  138.         '-x' => 'is not executable by effective uid/gid',
  139.         '-R' => 'is not readable by real uid/gid',
  140.         '-W' => 'is not writeable by real uid/gid',
  141.         '-X' => 'is not executable by real uid/gid',
  142.         '-o' => 'is not owned by effective uid/gid',
  143.         '-O' => 'is not owned by real uid/gid',
  144.         '-e' => 'does not exist',
  145.         '-z' => 'is not of size zero',
  146.         '-s' => 'does not exists or is of size zero',
  147.         '-f' => 'is not a file',
  148.         '-d' => 'is not a directory',
  149.         '-l' => 'is not a link',
  150.         '-S' => 'is not a socket',
  151.         '-p' => 'is not a named pipe',
  152.         '-b' => 'is not a block special file',
  153.         '-c' => 'is not a character special file',
  154.         '-u' => 'is not setuid',
  155.         '-g' => 'is not setgid',
  156.         '-k' => 'is not sticky',
  157.         '-t' => 'is not a terminal file',
  158.         '-T' => 'is not a text files',
  159.         '-B' => 'is not a binary file',
  160.         '-M' => 'has no modification date/time',
  161.         '-A' => 'has no access date/time',
  162.         '-C' => 'has no inode change date/time',
  163.     );
  164.  
  165.     if (defined $so and
  166.       $so == $cw->Subwidget('dir_list')->Subwidget('listbox')) {
  167.     $leaves = [$cw->Subwidget('dir_list')->Getselected];
  168.     $leaves = [$cw->Subwidget('dir_entry')->get] if !scalar(@$leaves);
  169.     } else {
  170.     $leaves = [$cw->Subwidget('file_list')->Getselected];
  171.     $leaves = [$cw->Subwidget('file_entry')->get] if !scalar(@$leaves);
  172.     }
  173.  
  174.     foreach $leaf (@$leaves)
  175.     {
  176.       if (defined $leaf and $leaf ne '') {
  177.     foreach (@{$cw->cget('-verify')}) {
  178.         my $r = ref $_;
  179.         if (defined $r and $r eq 'ARRAY') {
  180.         #local $_ = $leaf; # use strict var problem here
  181.         return if not &{$_->[0]}($cw, $path, $leaf, @{$_}[1..$#{$_}]);
  182.         } elsif ($_ eq '!-d') {
  183.         if (-d "$path/$leaf") {
  184.             $cw->Error("Selecting a directory is not permitted.");
  185.             return;
  186.         }
  187.         } else {
  188.         my $s = eval "$_ '$path/$leaf'";
  189.         print $@ if $@;
  190.         if (not $s) {
  191.             my $err;
  192.             $err = $error_text{$_} ?  $error_text{$_} : 
  193.                 "failed '$_' test";
  194.             $cw->Error("Name '$leaf' $err.");
  195.             return;
  196.         }
  197.         }
  198.     } # forend
  199.     $leaf = $path . '/' . $leaf;
  200.       } else {
  201.     $leaf =  undef;
  202.       }
  203.     }
  204.     if (scalar(@$leaves))
  205.     {
  206.       my $sm = $cw->Subwidget('file_list')->cget(-selectmode);
  207.       $cw->{Selected} = $leaves;
  208.     }
  209.  
  210. } # end Accept
  211.  
  212. sub Accept_dir
  213. {
  214.  my ($cw,$new) = @_;
  215.  my $dir  = $cw->cget('-directory');
  216.  $cw->configure(-directory => "$dir/$new");
  217. }
  218.  
  219.  
  220. sub Populate {
  221.     
  222.     my ($w, $args) = @_;
  223.     
  224.     $w->SUPER::Populate($args);
  225.     $w->protocol('WM_DELETE_WINDOW' => ['Cancel', $w ]);
  226.     
  227.     $w->{'reread'} = 0;  
  228.     $w->withdraw;
  229.     
  230.     # Create filter (or directory) entry, place at the top.
  231.     
  232.     my $e = $w->Component(
  233.         LabEntry       => 'dir_entry', 
  234.     -textvariable  => \$w->{Directory},
  235.     -labelVariable => \$w->{Configure}{-dirlabel},
  236.     );
  237.     $e->pack(-side => 'top', -expand => 0, -fill => 'x');
  238.     $e->bind('<Return>' => [$w => 'validateDir', Ev(['get'])]);
  239.  
  240.     # Create file entry, place at the bottom.
  241.  
  242.     $e = $w->Component(
  243.         LabEntry       => 'file_entry', 
  244.     -labelVariable => \$w->{Configure}{-filelabel},
  245.     );
  246.     $e->pack(-side => 'bottom', -expand => 0, -fill => 'x');
  247.     $e->bind('<Return>' => [$w => 'validateFile', Ev(['get'])]); 
  248.     
  249.     # Create directory scrollbox, place at the left-middle.
  250.     
  251.     my $b = $w->Component(
  252.         ScrlListbox    => 'dir_list', 
  253.     -labelVariable => \$w->{Configure}{-dirlistlabel},
  254.         -scrollbars    => 'se',
  255.     );
  256.     $b->pack(-side => 'left', -expand => 1, -fill => 'both');
  257.     $b->bind('<Double-Button-1>' => [$w => 'Accept_dir', Ev(['Getselected'])]);
  258.     
  259.     # Add a label.
  260.     
  261.     my $f = $w->Frame();
  262.     $f->pack(-side => 'right', -fill => 'y', -expand => 0);
  263.     $b = $f->Button('-text' => 'Accept', -command => [ 'Accept', $w ]);
  264.     $b->pack(-side => 'top', -fill => 'x', -expand => 1);
  265.     $b = $f->Button('-text' => 'Cancel', -command => [ 'Cancel', $w ]);
  266.     $b->pack(-side => 'top', -fill => 'x', -expand => 1);
  267.     $b = $f->Button( '-text'  => 'Reset', 
  268.                      -command => [$w => 'configure','-directory','.'],
  269.     );
  270.     $b->pack(-side => 'top', -fill => 'x', -expand => 1);
  271.     $b = $f->Button( '-text'  => 'Home', 
  272.                      -command => [$w => 'configure','-directory',$ENV{'HOME'}],
  273.     );
  274.     $b->pack(-side => 'top', -fill => 'x', -expand => 1);
  275.     
  276.     # Create file scrollbox, place at the right-middle.
  277.     
  278.     $b = $w->Component(
  279.         ScrlListbox    => 'file_list',
  280.     -labelVariable => \$w->{Configure}{-filelistlabel},
  281.         -scrollbars    => 'se',
  282.     );
  283.     $b->pack(-side => 'right', -expand => 1, -fill => 'both');
  284.     $b->bind('<Double-1>' => [$w => 'Accept']);
  285.     
  286.     # Create -very dialog.
  287.  
  288.     my $v = $w->Component(
  289.         Dialog   => 'dialog',
  290.         -title   => 'Verify Error',
  291.         -bitmap  => 'error',
  292.         -buttons => ['Dismiss'],
  293.     );
  294.     
  295.     $w->ConfigSpecs(
  296.         -width           => [ ['file_list','dir_list'], undef, undef, 14 ], 
  297.     -height          => [ ['file_list','dir_list'], undef, undef, 14 ], 
  298.     -directory       => [ 'METHOD', undef, undef, '.' ],
  299.     -filelabel       => [ 'PASSIVE', undef, undef, 'File' ],
  300.     -filelistlabel   => [ 'PASSIVE', undef, undef, 'Files' ],
  301.     -filter          => [ 'METHOD', undef, undef, '*' ],
  302.     -filterlabel     => [ 'PASSIVE', undef, undef, 'Files Matching' ],
  303.     -regexp          => [ 'PASSIVE', undef, undef, undef ],
  304.     -dirlistlabel    => [ 'PASSIVE', undef, undef, 'Directories'],
  305.     -dirlabel        => [ 'PASSIVE', undef, undef, 'Directory'],
  306.     '-accept'        => [ 'CALLBACK',undef,undef, undef ],
  307.         -verify          => [ 'PASSIVE', undef, undef, ['!-d'] ],
  308.         -create          => [ 'PASSIVE', undef, undef, 0 ],
  309.     DEFAULT          => [ 'file_list' ],
  310.     );
  311.     $w->Delegates(DEFAULT => 'file_list');
  312.  
  313.     return $w;
  314.     
  315. } # end Populate
  316.  
  317. sub translate
  318.   {
  319.       my ($bs,$ch) = @_;
  320.       return "\\$ch" if (length $bs);
  321.       return ".*"  if ($ch eq '*');
  322.  return "."   if ($ch eq '?');
  323.  return "\\."  if ($ch eq '.');
  324.  return "\\/" if ($ch eq '/');
  325.  return "\\\\" if ($ch eq '\\');
  326.  return $ch;
  327. }
  328.  
  329. sub filter
  330. {
  331.  my ($cw,$val) = @_;
  332.  my $var = \$cw->{Configure}{'-filter'};
  333.  if (@_ > 1)
  334.   {
  335.    my $regex = $val;
  336.    $$var = $val; 
  337.    $regex =~ s/(\\?)(.)/&translate($1,$2)/ge;
  338.    $cw->{'match'} = sub { shift =~ /^${regex}$/ };
  339.    unless ($cw->{'reread'}++)
  340.     {
  341.      $cw->Busy;
  342.      $cw->DoWhenIdle(['reread',$cw,$cw->cget('-directory')]) 
  343.     }
  344.   }
  345.  return $$var;
  346. }
  347.  
  348. sub directory
  349. {
  350.  my ($cw,$val) = @_;
  351.  $cw->idletasks if $cw->{'reread'};
  352.  my $var = \$cw->{Configure}{'-directory'};
  353.  my $dir = $$var;
  354.  if (@_ > 1 && defined $val)
  355.   {
  356.    if (substr($val,0,1) eq '~')
  357.     {
  358.      if (substr($val,1,1) eq '/')
  359.       {
  360.        $val = $ENV{'HOME'} . substr($val,1); 
  361.       }
  362.      else
  363.       {my ($uid,$rest) = ($val =~ m#^~([^/]+)(/.*$)#);
  364.        $val = (getpwnam($uid))[7] . $rest;
  365.       }
  366.     }
  367.    unless ($cw->{'reread'}++)
  368.     {
  369.      $cw->Busy;
  370.      $cw->afterIdle(['reread',$cw,$val]) 
  371.     }
  372.   }
  373.  return $$var;
  374. }
  375.  
  376. sub reread
  377. { 
  378.  my ($w,$dir) = @_;
  379.  my $pwd = Cwd::getcwd();
  380.  unless ($^T)
  381.   {
  382.    if (chdir($dir))
  383.     {
  384.      my $new = Cwd::getcwd();
  385.      if ($new)
  386.       {
  387.        $dir = $new;
  388.       }
  389.      else
  390.       {
  391.        carp "Cannot getcwd in '$dir'" unless ($new);
  392.       }
  393.      chdir($pwd) || carp "Cannot chdir($pwd) : $!"; 
  394.     }
  395.    else
  396.     {
  397.      $w->Unbusy;                                        
  398.      $w->{'reread'} = 0;                                
  399.      $w->{Directory} = $dir . "/" . $w->cget('-filter');
  400.      $w->BackTrace("Cannot chdir($dir) :$!");
  401.     }
  402.   }
  403.  if (opendir(DIR, $dir))                            
  404.   {                                                 
  405.    $w->Subwidget('dir_list')->delete(0, "end");       
  406.    $w->Subwidget('file_list')->delete(0, "end");      
  407.    my $accept = $w->cget('-accept');                  
  408.    my $f;                                           
  409.    foreach $f (sort(readdir(DIR)))                  
  410.     {                                               
  411.      next if ($f eq '.');                           
  412.      my $path = "$dir/$f";                          
  413.      if (-d $path)                                  
  414.       {                                             
  415.        $w->Subwidget('dir_list')->insert('end', $f);
  416.       }                                             
  417.      else                                           
  418.       {                                             
  419.        if (&{$w->{match}}($f))                       
  420.         {                                            
  421.          if (!defined($accept) || $accept->Call($path))
  422.           {                                          
  423.            $w->Subwidget('file_list')->insert('end', $f) 
  424.           }                                          
  425.         }                                            
  426.       }                                             
  427.     }                                               
  428.    closedir(DIR);                                   
  429.    $w->{Configure}{'-directory'} = $dir;                                        
  430.    $w->Unbusy;                                        
  431.    $w->{'reread'} = 0;                                
  432.    $w->{Directory} = $dir . "/" . $w->cget('-filter');
  433.   }                                                 
  434.  else
  435.   {
  436.    my $panic = $w->{Configure}{'-directory'};
  437.    $w->Unbusy;                                        
  438.    $w->{'reread'} = 0;                                
  439.    chdir($panic) || $w->BackTrace("Cannot chdir($panic) : $!");
  440.    $w->{Directory} = $dir . "/" . $w->cget('-filter');
  441.    $w->BackTrace("Cannot opendir('$dir') :$!");
  442.   }
  443. } 
  444.  
  445. sub validateDir
  446. {
  447.  my ($cw,$name) = @_;
  448.  my ($base,$leaf) = ($name =~ m#^(.*)/([^/]+)$#);
  449.  if ($leaf =~ /[*?]/)
  450.   {
  451.    $cw->configure('-directory' => $base);
  452.    $cw->configure('-filter' => $leaf);
  453.   }
  454.  else
  455.   {
  456.    $cw->configure('-directory' => $name);
  457.   }
  458. }
  459.  
  460. sub validateFile
  461. { 
  462.  my ($cw,$name) = @_;
  463.  my $i = 0;
  464.  my $n = $cw->index('end');
  465.  # See if it is an existing file
  466.  for ($i= 0; $i < $n; $i++)
  467.   {
  468.    my $f = $cw->get($i);
  469.    if ($f eq $name)
  470.     {
  471.      $cw->selection('set',$i);
  472.      $cw->Accept;
  473.     }
  474.   }
  475.  # otherwise allow if -create is set, directory is writable
  476.  # and it passes filter and accept criteria
  477.  if ($cw->cget('-create'))
  478.   {
  479.    my $path = $cw->cget('-directory');
  480.    if (-w $path)
  481.     {
  482.      if (&{$cw->{match}}($name))                       
  483.       {                                            
  484.        my $accept = $cw->cget('-accept');                  
  485.        my $full   = "$path/$name";
  486.        if (!defined($accept) || $accept->Call($full))
  487.         {                                          
  488.          $cw->{Selected} = [$full];
  489.         }                                          
  490.        else
  491.         {
  492.          $cw->Error("$name is not 'acceptable'");
  493.         }
  494.       }                                            
  495.      else
  496.       {
  497.        $cw->Error("$name does not match '".$cw->cget('-filter')."'");
  498.       }
  499.     }
  500.    else
  501.     {
  502.      $cw->Error("Directory '$path' is not writable");
  503.      return;
  504.     }
  505.   }
  506. } 
  507.  
  508. sub Error
  509. {
  510.  my $cw  = shift;
  511.  my $msg = shift;
  512.  my $dlg = $cw->Subwidget('dialog');
  513.  $dlg->configure(-text => $msg);
  514.  $dlg->Show;
  515. }
  516.  
  517. sub Show
  518. {
  519.  my ($cw,@args) = @_;
  520.  $cw->Popup(@args); 
  521.  $cw->waitVisibility;
  522.  $cw->focus;
  523.  $cw->waitVariable(\$cw->{Selected});
  524.  $cw->withdraw;
  525.  return defined($cw->{Selected}) 
  526.       ? (wantarray) ? @{$cw->{Selected}} : $cw->{Selected}[0]
  527.       : undef;
  528.  
  529. }
  530.  
  531. 1;  
  532.