home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _d64fdd009b6f0a28ababd555bfe58edb < prev    next >
Text File  |  2004-06-01  |  16KB  |  579 lines
  1. package Tk::FileSelect;
  2.  
  3. use vars qw($VERSION @EXPORT_OK);
  4. $VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/;
  5. @EXPORT_OK = qw(glob_to_re);
  6.  
  7. use Tk qw(Ev);
  8. use strict;
  9. use Carp;
  10. use base qw(Tk::Toplevel);
  11. use Tk::widgets qw(LabEntry Button Frame Listbox Scrollbar);
  12. use File::Basename;
  13.  
  14. Construct Tk::Widget 'FileSelect';
  15.  
  16. use vars qw(%error_text);
  17. %error_text = (
  18.     '-r' => 'is not readable by effective uid/gid',
  19.     '-w' => 'is not writeable by effective uid/gid',
  20.     '-x' => 'is not executable by effective uid/gid',
  21.     '-R' => 'is not readable by real uid/gid',
  22.     '-W' => 'is not writeable by real uid/gid',
  23.     '-X' => 'is not executable by real uid/gid',
  24.     '-o' => 'is not owned by effective uid/gid',
  25.     '-O' => 'is not owned by real uid/gid',
  26.     '-e' => 'does not exist',
  27.     '-z' => 'is not of size zero',
  28.     '-s' => 'does not exists or is of size zero',
  29.     '-f' => 'is not a file',
  30.     '-d' => 'is not a directory',
  31.     '-l' => 'is not a link',
  32.     '-S' => 'is not a socket',
  33.     '-p' => 'is not a named pipe',
  34.     '-b' => 'is not a block special file',
  35.     '-c' => 'is not a character special file',
  36.     '-u' => 'is not setuid',
  37.     '-g' => 'is not setgid',
  38.     '-k' => 'is not sticky',
  39.     '-t' => 'is not a terminal file',
  40.     '-T' => 'is not a text file',
  41.     '-B' => 'is not a binary file',
  42.     '-M' => 'has no modification date/time',
  43.     '-A' => 'has no access date/time',
  44.     '-C' => 'has no inode change date/time',
  45.     );
  46.  
  47. # Documentation after __END__
  48.  
  49. sub import {
  50.     if (defined $_[1] and $_[1] eq 'as_default') {
  51.     local $^W = 0;
  52.     package Tk;
  53.     if ($Tk::VERSION < 804) {
  54.         *FDialog      = \&Tk::FileSelect::FDialog;
  55.         *MotifFDialog = \&Tk::FileSelect::FDialog;
  56.     } else {
  57.         *tk_getOpenFile = sub {
  58.         Tk::FileSelect::FDialog("tk_getOpenFile", @_);
  59.         };
  60.         *tk_getSaveFile = sub {
  61.         Tk::FileSelect::FDialog("tk_getSaveFile", @_);
  62.         };
  63.     }
  64.     }
  65. }
  66.  
  67. sub Cancel
  68. {
  69.  my ($cw) = @_;
  70.  $cw->{Selected} = undef;
  71.  $cw->withdraw unless $cw->cget('-transient');
  72. }
  73.  
  74. sub Accept {
  75.  
  76.     # Accept the file or directory name if possible.
  77.  
  78.     my ($cw) = @_;
  79.  
  80.     my($path, $so) = ($cw->cget('-directory'), $cw->SelectionOwner);
  81.     my $leaf = undef;
  82.     my $leaves;
  83.  
  84.     if (defined $so and
  85.           $so == $cw->Subwidget('dir_list')->Subwidget('listbox')) {
  86.         $leaves = [$cw->Subwidget('dir_list')->getSelected];
  87.         $leaves = [$cw->Subwidget('dir_entry')->get] if !scalar(@$leaves);
  88.     } else {
  89.         $leaves = [$cw->Subwidget('file_list')->getSelected];
  90.         $leaves = [$cw->Subwidget('file_entry')->get] if !scalar(@$leaves);
  91.     }
  92.  
  93.     foreach $leaf (@$leaves)
  94.     {
  95.       if (defined $leaf and $leaf ne '') {
  96.         if (!$cw->cget('-create') || -e "$path/$leaf")
  97.          {
  98.           foreach (@{$cw->cget('-verify')}) {
  99.               my $r = ref $_;
  100.               if (defined $r and $r eq 'ARRAY') {
  101.                   #local $_ = $leaf; # use strict var problem here
  102.                   return if not &{$_->[0]}($cw, $path, $leaf, @{$_}[1..$#{$_}]);
  103.               } else {
  104.                   my $s = eval "$_ '$path/$leaf'";
  105.                   print $@ if $@;
  106.                   if (not $s) {
  107.                       my $err;
  108.                       if (substr($_,0,1) eq '!')
  109.                        {
  110.                         my $t = substr($_,1);
  111.                         if (exists $error_text{$t})
  112.                          {
  113.                           $err = $error_text{$t};
  114.                           $err =~ s/\b(?:no|not) //;
  115.                          }
  116.                        }
  117.                       $err = $error_text{$_} unless defined $err;
  118.                       $err = "failed '$_' test" unless defined $err;
  119.                       $cw->Error("'$leaf' $err.");
  120.                       return;
  121.                   }
  122.               }
  123.           } # forend
  124.          }
  125.         else
  126.          {
  127.           unless (-w $path)
  128.            {
  129.             $cw->Error("Cannot write to $path");
  130.             return;
  131.            }
  132.          }
  133.         $leaf = $path . '/' . $leaf;
  134.       } else {
  135.         $leaf =  undef;
  136.       }
  137.     }
  138.     if (scalar(@$leaves))
  139.     {
  140.       my $sm = $cw->Subwidget('file_list')->cget(-selectmode);
  141.       $cw->{Selected} = $leaves;
  142.       my $command = $cw->cget('-command');
  143.       $command->Call(@{$cw->{Selected}}) if defined $command;
  144.     }
  145.  
  146. } # end Accept
  147.  
  148. sub Accept_dir
  149. {
  150.  my ($cw,$new) = @_;
  151.  my $dir  = $cw->cget('-directory');
  152.  $cw->configure(-directory => "$dir/$new");
  153. }
  154.  
  155. sub Populate {
  156.  
  157.     my ($w, $args) = @_;
  158.  
  159.     require Tk::Listbox;
  160.     require Tk::Button;
  161.     require Tk::Dialog;
  162.     require Tk::Toplevel;
  163.     require Tk::LabEntry;
  164.     require Cwd;
  165.  
  166.     $w->SUPER::Populate($args);
  167.     $w->protocol('WM_DELETE_WINDOW' => ['Cancel', $w ]);
  168.  
  169.     $w->{'reread'} = 0;
  170.     $w->withdraw;
  171.  
  172.     # Create directory/filter entry, place at the top.
  173.     my $e = $w->Component(
  174.         LabEntry       => 'dir_entry',
  175.         -textvariable  => \$w->{DirectoryString},
  176.         -labelVariable => \$w->{Configure}{-dirlabel},
  177.     );
  178.     $e->pack(-side => 'top', -expand => 0, -fill => 'x');
  179.     $e->bind('<Return>' => [$w => 'validateDir', Ev(['get'])]);
  180.  
  181.     # Create file entry, place at the bottom.
  182.     $e = $w->Component(
  183.         LabEntry       => 'file_entry',
  184.         -textvariable => \$w->{Configure}{-initialfile},
  185.         -labelVariable => \$w->{Configure}{-filelabel},
  186.     );
  187.     $e->pack(-side => 'bottom', -expand => 0, -fill => 'x');
  188.     $e->bind('<Return>' => [$w => 'validateFile', Ev(['get'])]);
  189.     $e->bind('<FocusIn>' => [$w => 'SelectionClear']);
  190.  
  191.     # Create directory scrollbox, place at the left-middle.
  192.     my $b = $w->Component(
  193.         ScrlListbox    => 'dir_list',
  194.         -labelVariable => \$w->{Configure}{-dirlistlabel},
  195.         -scrollbars    => 'se',
  196.     );
  197.     $b->pack(-side => 'left', -expand => 1, -fill => 'both');
  198.     $b->bind('<Double-Button-1>' => [$w => 'Accept_dir', Ev(['getSelected'])]);
  199.  
  200.     # Add a label.
  201.  
  202.     my $f = $w->Frame();
  203.     $f->pack(-side => 'right', -fill => 'y', -expand => 0);
  204.     $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-acceptlabel'},
  205.              -command => [ 'Accept', $w ],
  206.     );
  207.     $b->pack(-side => 'top', -fill => 'x', -expand => 1);
  208.     $b = $f->Button('-textvariable' => \$w->{'Configure'}{'-cancellabel'},
  209.              -command => [ 'Cancel', $w ],
  210.     );
  211.     $b->pack(-side => 'top', -fill => 'x', -expand => 1);
  212.     $b = $f->Button('-textvariable'  => \$w->{'Configure'}{'-resetlabel'},
  213.              -command => [$w => 'configure','-directory','.'],
  214.     );
  215.     $b->pack(-side => 'top', -fill => 'x', -expand => 1);
  216.     $b = $f->Button('-textvariable'  => \$w->{'Configure'}{'-homelabel'},
  217.                      -command => [$w => 'configure','-directory',$ENV{'HOME'}],
  218.     );
  219.     $b->pack(-side => 'top', -fill => 'x', -expand => 1);
  220.  
  221.     # Create file scrollbox, place at the right-middle.
  222.  
  223.     $b = $w->Component(
  224.         ScrlListbox    => 'file_list',
  225.         -labelVariable => \$w->{Configure}{-filelistlabel},
  226.         -scrollbars    => 'se',
  227.     );
  228.     $b->pack(-side => 'right', -expand => 1, -fill => 'both');
  229.     $b->bind('<Double-1>' => [$w => 'Accept']);
  230.  
  231.     # Create -very dialog.
  232.  
  233.     my $v = $w->Component(
  234.         Dialog   => 'dialog',
  235.         -title   => 'Verify Error',
  236.         -bitmap  => 'error',
  237.         -buttons => ['Dismiss'],
  238.     );
  239.  
  240.     $w->ConfigSpecs(
  241.         -width            => [ ['file_list','dir_list'], undef, undef, 14 ],
  242.         -height           => [ ['file_list','dir_list'], undef, undef, 14 ],
  243.         -directory        => [ 'METHOD', undef, undef, '.' ],
  244.         -initialdir       => '-directory',
  245.         -filelabel        => [ 'PASSIVE', 'fileLabel', 'FileLabel', 'File' ],
  246.         -initialfile      => [ 'PASSIVE', undef, undef, '' ],
  247.         -filelistlabel    => [ 'PASSIVE', undef, undef, 'Files' ],
  248.         -filter           => [ 'METHOD',  undef, undef, undef ],
  249.         -defaultextension => [ 'METHOD',  undef, undef, undef ],
  250.         -regexp           => [ 'METHOD', undef, undef, undef ],
  251.         -dirlistlabel     => [ 'PASSIVE', undef, undef, 'Directories'],
  252.         -dirlabel         => [ 'PASSIVE', undef, undef, 'Directory'],
  253.         '-accept'         => [ 'CALLBACK',undef,undef, undef ],
  254.         -command          => [ 'CALLBACK',undef,undef, undef ],
  255.         -transient        => [ 'PASSIVE', undef, undef, 1 ],
  256.         -verify           => [ 'PASSIVE', undef, undef, ['!-d'] ],
  257.         -create           => [ 'PASSIVE', undef, undef, 0 ],
  258.         -acceptlabel      => [ 'PASSIVE', undef, undef, 'Accept'],
  259.         -cancellabel      => [ 'PASSIVE', undef, undef, 'Cancel'],
  260.         -resetlabel       => [ 'PASSIVE', undef, undef, 'Reset'],
  261.         -homelabel        => [ 'PASSIVE', undef, undef, 'Home'],
  262.         DEFAULT           => [ 'file_list' ],
  263.     );
  264.     $w->Delegates(DEFAULT => 'file_list');
  265.  
  266.     return $w;
  267.  
  268. } # end Populate
  269.  
  270. sub translate
  271.   {
  272.       my ($bs,$ch) = @_;
  273.       return "\\$ch" if (length $bs);
  274.       return '.*'  if ($ch eq '*');
  275.  return '.'   if ($ch eq '?');
  276.  return "\\."  if ($ch eq '.');
  277.  return "\\/" if ($ch eq '/');
  278.  return "\\\\" if ($ch eq '\\');
  279.  return $ch;
  280. }
  281.  
  282. sub glob_to_re
  283. {
  284.  my $regex = shift;
  285.  $regex =~ s/(\\?)(.)/&translate($1,$2)/ge;
  286.  return sub { shift =~ /^${regex}$/ };
  287. }
  288.  
  289. sub filter
  290. {
  291.  my ($cw,$val) = @_;
  292.  my $var = \$cw->{Configure}{'-filter'};
  293.  if (@_ > 1 || !defined($$var))
  294.   {
  295.    $val = '*' unless defined $val;
  296.    $$var = $val;
  297.    $cw->{'match'} = glob_to_re($val)  unless defined $cw->{'match'};
  298.    unless ($cw->{'reread'}++)
  299.     {
  300.      $cw->Busy;
  301.      $cw->afterIdle(['reread',$cw,$cw->cget('-directory')])
  302.     }
  303.   }
  304.  return $$var;
  305. }
  306.  
  307. sub regexp
  308. {
  309.  my ($cw,$val) = @_;
  310.  my $var = \$cw->{Configure}{'-regexp'};
  311.  if (@_ > 1)
  312.   {
  313.    $$var = $val;
  314.    $cw->{'match'} = (defined $val) ? sub { shift =~ m|^${val}$| } : sub { 1 };
  315.    unless ($cw->{'reread'}++)
  316.     {
  317.      $cw->Busy;
  318.      $cw->afterIdle(['reread',$cw])
  319.     }
  320.   }
  321.  return $$var;
  322. }
  323.  
  324. sub defaultextension
  325. {
  326.  my ($cw,$val) = @_;
  327.  if (@_ > 1)
  328.   {
  329.    $val = '' unless defined $val;
  330.    $val = ".$val" if ($val !~ /^\./);
  331.    $cw->filter("*$val");
  332.   }
  333.  else
  334.   {
  335.    $val = $cw->filter;
  336.    my ($ext) = $val =~ /(\.[^\.]*)$/;
  337.    return $ext;
  338.   }
  339. }
  340.  
  341. sub directory
  342. {
  343.  my ($cw,$dir) = @_;
  344.  my $var = \$cw->{Configure}{'-directory'};
  345.  if (@_ > 1 && defined $dir)
  346.   {
  347.    if (substr($dir,0,1) eq '~')
  348.     {
  349.      if (substr($dir,1,1) eq '/')
  350.       {
  351.        $dir = (defined $ENV{'HOME'} ? $ENV{'HOME'} : '') . substr($dir,1);
  352.       }
  353.      else
  354.       {my ($uid,$rest) = ($dir =~ m#^~([^/]+)(/.*$)#);
  355.        $dir = (getpwnam($uid))[7] . $rest;
  356.       }
  357.     }
  358.    my $revert_dir = sub
  359.     {
  360.      my $message = shift;
  361.      $$var = $cw->{OldDirectory};
  362.      $cw->messageBox(-message => $message, -icon => 'error');
  363.      if (!defined $$var)
  364.       {
  365.        # OldDirectory was never set, so force reread...
  366.        $$var = $cw->{OldDirectory} = Cwd::getcwd(); # XXX maybe use check like code below...
  367.        unless ($cw->{'reread'}++)
  368.         {
  369.          $cw->Busy;
  370.          $cw->afterIdle(['reread',$cw])
  371.         }
  372.       }
  373.      $$var;
  374.     };
  375.    $dir =~ s#([^/\\])[\\/]+$#$1#;
  376.    if (-d $dir)
  377.     {
  378.      unless (Tk::tainting())
  379.       {
  380.        my $pwd = Cwd::getcwd();
  381.        if (chdir( (defined($dir) ? $dir : '') ) )
  382.         {
  383.          my $new = Cwd::getcwd();
  384.          if ($new)
  385.           {
  386.            $dir = $new;
  387.           }
  388.          else
  389.           {
  390.        return $revert_dir->("Cannot getcwd in '$dir'");
  391.           }
  392.          if (!chdir($pwd))
  393.           {
  394.        return $revert_dir->("Cannot change directory to $pwd:\n$!");
  395.           }
  396.      $$var = $dir;
  397.         }
  398.        else
  399.         {
  400.      return $revert_dir->("Cannot change directory to $dir:\n$!");
  401.         }
  402.        $$var = $cw->{OldDirectory} = $dir;
  403.       }
  404.      unless ($cw->{'reread'}++)
  405.       {
  406.        $cw->Busy;
  407.        $cw->afterIdle(['reread',$cw])
  408.       }
  409.     }
  410.   }
  411.  return $$var;
  412. }
  413.  
  414. sub reread
  415. {
  416.  my ($w) = @_;
  417.  my $dir = $w->cget('-directory');
  418.  if (defined $dir)
  419.   {
  420.    if (!defined $w->cget('-filter') or $w->cget('-filter') eq '')
  421.     {
  422.      $w->configure('-filter', '*');
  423.     }
  424.    my $dl = $w->Subwidget('dir_list');
  425.    $dl->delete(0, 'end');
  426.    $dl->selectionClear(0,'end');
  427.    my $fl = $w->Subwidget('file_list');
  428.    $fl->delete(0, 'end');
  429.    local *DIR;
  430.    if (opendir(DIR, $dir))
  431.     {
  432.      my $file = $w->cget('-initialfile');
  433.      my $seen = 0;
  434.      my $accept = $w->cget('-accept');
  435.      foreach my $f (sort(readdir(DIR)))
  436.       {
  437.        next if ($f eq '.');
  438.        my $path = "$dir/$f";
  439.        if (-d $path)
  440.         {
  441.          $dl->insert('end', $f);
  442.         }
  443.        else
  444.         {
  445.          if (&{$w->{match}}($f))
  446.           {
  447.            if (!defined($accept) || $accept->Call($path))
  448.             {
  449.              $seen = $fl->index('end') if ($file && $f eq $file);
  450.              $fl->insert('end', $f)
  451.             }
  452.           }
  453.         }
  454.       }
  455.      closedir(DIR);
  456.      if ($seen)
  457.       {
  458.        $fl->selectionSet($seen);
  459.        $fl->see($seen);
  460.       }
  461.      else
  462.       {
  463.        $w->configure(-initialfile => undef) unless $w->cget('-create');
  464.       }
  465.     }
  466.    $w->{DirectoryString} = $dir . ($dir ne '/' ? '/' : '') . $w->cget('-filter');
  467.   }
  468.  $w->{'reread'} = 0;
  469.  $w->Unbusy if $w->{'Busy'};
  470. }
  471.  
  472. sub validateDir
  473. {
  474.  my ($cw,$name) = @_;
  475.  my ($leaf,$base) = fileparse($name);
  476.  if ($leaf =~ /[*?]/)
  477.   {
  478.    $cw->configure('-directory' => $base,'-filter' => $leaf);
  479.   }
  480.  else
  481.   {
  482.    $cw->configure('-directory' => $name);
  483.   }
  484. }
  485.  
  486. sub validateFile
  487. {
  488.  my ($cw,$name) = @_;
  489.  my $i = 0;
  490.  my $n = $cw->index('end');
  491.  # See if it is an existing file
  492.  for ($i= 0; $i < $n; $i++)
  493.   {
  494.    my $f = $cw->get($i);
  495.    if ($f eq $name)
  496.     {
  497.      $cw->selection('set',$i);
  498.      $cw->Accept;
  499.     }
  500.   }
  501.  # otherwise allow if -create is set, directory is writable
  502.  # and it passes filter and accept criteria
  503.  if ($cw->cget('-create'))
  504.   {
  505.    my $path = $cw->cget('-directory');
  506.    if (-w $path)
  507.     {
  508.      if (&{$cw->{match}}($name))
  509.       {
  510.        my $accept = $cw->cget('-accept');
  511.        my $full   = "$path/$name";
  512.        if (!defined($accept) || $accept->Call($full))
  513.         {
  514.          $cw->{Selected} = [$full];
  515.          $cw->Callback(-command => @{$cw->{Selected}});
  516.         }
  517.        else
  518.         {
  519.          $cw->Error("$name is not 'acceptable'");
  520.         }
  521.       }
  522.      else
  523.       {
  524.        $cw->Error("$name does not match '".$cw->cget('-filter').'\'');
  525.       }
  526.     }
  527.    else
  528.     {
  529.      $cw->Error("Directory '$path' is not writable");
  530.      return;
  531.     }
  532.   }
  533. }
  534.  
  535. sub Error
  536. {
  537.  my $cw  = shift;
  538.  my $msg = shift;
  539.  my $dlg = $cw->Subwidget('dialog');
  540.  $dlg->configure(-text => $msg);
  541.  $dlg->Show;
  542. }
  543.  
  544. sub Show
  545. {
  546.  my ($cw,@args) = @_;
  547.  if ($cw->cget('-transient')) {
  548.    $cw->Popup(@args);
  549.    $cw->focus;
  550.    $cw->waitVariable(\$cw->{Selected});
  551.    $cw->withdraw;
  552.    return defined($cw->{Selected})
  553.      ? (wantarray) ? @{$cw->{Selected}} : $cw->{Selected}[0]
  554.        : undef;
  555.  } else {
  556.    $cw->Popup(@args);
  557.  }
  558. }
  559.  
  560. sub FDialog
  561. {
  562.  my($cmd, %args) = @_;
  563.  if ($cmd =~ /Save/)
  564.   {
  565.    $args{-create} = 1;
  566.    $args{-verify} = [qw(!-d -w)];
  567.   }
  568.  delete $args{-filetypes};
  569.  delete $args{-force};
  570.  Tk::DialogWrapper('FileSelect',$cmd, %args);
  571. }
  572.  
  573. 1;
  574.  
  575. __END__
  576.  
  577. =cut
  578.  
  579.