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