package Tk::FileSelect;
use vars qw($VERSION @EXPORT_OK);
$VERSION = '3.047'; # $Id: //depot/Tk8/Tk/FileSelect.pm#47 $
@EXPORT_OK=qw(glob_to_re);
use Tk qw(Ev);
use strict;
use Carp;
use base qw(Tk::Toplevel);
use Tk::widgets qw(LabEntry Button Frame Listbox Scrollbar);
use File::Basename;
Construct Tk::Widget 'FileSelect';
use vars qw(%error_text);
%error_text=('-r'=>'is not readable by effective uid/gid','-w'=>'is not writeable by effective uid/gid','-x'=>'is not executable by effective uid/gid','-R'=>'is not readable by real uid/gid','-W'=>'is not writeable by real uid/gid','-X'=>'is not executable by real uid/gid','-o'=>'is not owned by effective uid/gid','-O'=>'is not owned by real uid/gid','-e'=>'does not exist','-z'=>'is not of size zero','-s'=>'does not exists or is of size zero','-f'=>'is not a file','-d'=>'is not a directory','-l'=>'is not a link','-S'=>'is not a socket','-p'=>'is not a named pipe','-b'=>'is not a block special file','-c'=>'is not a character special file','-u'=>'is not setuid','-g'=>'is not setgid','-k'=>'is not sticky','-t'=>'is not a terminal file','-T'=>'is not a text file','-B'=>'is not a binary file','-M'=>'has no modification date/time','-A'=>'has no access date/time','-C'=>'has no inode change date/time',);
sub import{if(defined$_[1]and$_[1]eq 'as_default'){local$^W=0;
package Tk;
*FDialog=\&Tk::FileSelect::FDialog;
*MotifFDialog=\&Tk::FileSelect::FDialog;}}sub Cancel{my($cw)=@_;
$cw->{Selected}=undef;
$cw->withdraw unless$cw->cget('-transient');}sub Accept{my($cw)=@_;
my($path,$so)=($cw->cget('-directory'),$cw->SelectionOwner);
my$leaf=undef;
my$leaves;
if(defined$so and$so==$cw->Subwidget('dir_list')->Subwidget('listbox')){$leaves=[$cw->Subwidget('dir_list')->getSelected];
$leaves=[$cw->Subwidget('dir_entry')->get]if!scalar(@$leaves);}else{$leaves=[$cw->Subwidget('file_list')->getSelected];
$leaves=[$cw->Subwidget('file_entry')->get]if!scalar(@$leaves);}foreach$leaf(@$leaves){if(defined$leaf and$leaf ne ''){if(!$cw->cget('-create')||-e"$path/$leaf"){foreach(@{$cw->cget('-verify')}){my$r=ref$_;
if(defined$r and$r eq 'ARRAY'){return if not&{$_->[0]}($cw,$path,$leaf,@{$_}[1..$#{$_}]);}else{my$s=eval"$_ '$path/$leaf'";
print$@ if $@;
if(not$s){my$err;
if(substr($_,0,1)eq '!'){my$t=substr($_,1);
if(exists$error_text{$t}){$err=$error_text{$t};
$err=~s/\b(?:no|not) //;}}$err=$error_text{$_}unless defined$err;
$err="failed '$_' test" unless defined$err;
$cw->Error("'$leaf' $err.");
return;}}}}else{unless(-w$path){$cw->Error("Cannot write to $path");
return;}}$leaf=$path.'/'.$leaf;}else{$leaf=undef;}}if(scalar(@$leaves)){my$sm=$cw->Subwidget('file_list')->cget(-selectmode);
$cw->{Selected}=$leaves;
my$command=$cw->cget('-command');
$command->Call(@{$cw->{Selected}})if defined$command;}}sub Accept_dir{my($cw,$new)=@_;
my$dir=$cw->cget('-directory');
$cw->configure(-directory=>"$dir/$new");}sub Populate{my($w,$args)=@_;
require Tk::Listbox;
require Tk::Button;
require Tk::Dialog;
require Tk::Toplevel;
require Tk::LabEntry;
require Cwd;
$w->SUPER::Populate($args);
$w->protocol('WM_DELETE_WINDOW'=>['Cancel',$w]);
$w->{'reread'}=0;
$w->withdraw;
my$e=$w->Component(LabEntry=>'dir_entry',-textvariable=>\$w->{DirectoryString},-labelVariable=>\$w->{Configure}{-dirlabel},);
$e->pack(-side=>'top',-expand=>0,-fill=>'x');
$e->bind('<Return>'=>[$w=>'validateDir',Ev(['get'])]);
$e=$w->Component(LabEntry=>'file_entry',-textvariable=>\$w->{Configure}{-initialfile},-labelVariable=>\$w->{Configure}{-filelabel},);
$e->pack(-side=>'bottom',-expand=>0,-fill=>'x');
$e->bind('<Return>'=>[$w=>'validateFile',Ev(['get'])]);
my$b=$w->Component(ScrlListbox=>'dir_list',-labelVariable=>\$w->{Configure}{-dirlistlabel},-scrollbars=>'se',);
$b->pack(-side=>'left',-expand=>1,-fill=>'both');
$b->bind('<Double-Button-1>'=>[$w=>'Accept_dir',Ev(['getSelected'])]);
my$f=$w->Frame();
$f->pack(-side=>'right',-fill=>'y',-expand=>0);
$b=$f->Button('-textvariable'=>\$w->{'Configure'}{'-acceptlabel'},-command=>['Accept',$w],);
$b->pack(-side=>'top',-fill=>'x',-expand=>1);
$b=$f->Button('-textvariable'=>\$w->{'Configure'}{'-cancellabel'},-command=>['Cancel',$w],);
$b->pack(-side=>'top',-fill=>'x',-expand=>1);
$b=$f->Button('-textvariable'=>\$w->{'Configure'}{'-resetlabel'},-command=>[$w=>'configure','-directory','.'],);
$b->pack(-side=>'top',-fill=>'x',-expand=>1);
$b=$f->Button('-textvariable'=>\$w->{'Configure'}{'-homelabel'},-command=>[$w=>'configure','-directory',$ENV{'HOME'}],);
$b->pack(-side=>'top',-fill=>'x',-expand=>1);
$b=$w->Component(ScrlListbox=>'file_list',-labelVariable=>\$w->{Configure}{-filelistlabel},-scrollbars=>'se',);
$b->pack(-side=>'right',-expand=>1,-fill=>'both');
$b->bind('<Double-1>'=>[$w=>'Accept']);
my$v=$w->Component(Dialog=>'dialog',-title=>'Verify Error',-bitmap=>'error',-buttons=>['Dismiss'],);
$w->ConfigSpecs(-width=>[['file_list','dir_list'],undef,undef,14],-height=>[['file_list','dir_list'],undef,undef,14],-directory=>['METHOD',undef,undef,'.'],-initialdir=>'-directory',-filelabel=>['PASSIVE','fileLabel','FileLabel','File'],-initialfile=>['PASSIVE',undef,undef,''],-filelistlabel=>['PASSIVE',undef,undef,'Files'],-filter=>['METHOD',undef,undef,undef],-defaultextension=>['METHOD',undef,undef,undef],-regexp=>['METHOD',undef,undef,undef],-dirlistlabel=>['PASSIVE',undef,undef,'Directories'],-dirlabel=>['PASSIVE',undef,undef,'Directory'],'-accept'=>['CALLBACK',undef,undef,undef],-command=>['CALLBACK',undef,undef,undef],-transient=>['PASSIVE',undef,undef,1],-verify=>['PASSIVE',undef,undef,['!-d']],-create=>['PASSIVE',undef,undef,0],-acceptlabel=>['PASSIVE',undef,undef,'Accept'],-cancellabel=>['PASSIVE',undef,undef,'Cancel'],-resetlabel=>['PASSIVE',undef,undef,'Reset'],-homelabel=>['PASSIVE',undef,undef,'Home'],DEFAULT=>['file_list'],);
$w->Delegates(DEFAULT=>'file_list');
return$w;}sub translate{my($bs,$ch)=@_;
return"\\$ch" if(length$bs);
return '.*'  if($ch eq '*');
return '.'   if($ch eq '?');
return"\\."  if($ch eq '.');
return"\\/" if($ch eq '/');
return"\\\\" if($ch eq '\\');
return$ch;}sub glob_to_re{my$regex=shift;
$regex=~s/(\\?)(.)/&translate($1,$2)/ge;
return sub{shift=~/^${regex}$/};}sub filter{my($cw,$val)=@_;
my$var=\$cw->{Configure}{'-filter'};
if(@_>1||!defined($$var)){$val='*' unless defined$val;
$$var=$val;
$cw->{'match'}=glob_to_re($val)unless defined$cw->{'match'};
unless($cw->{'reread'}++){$cw->Busy;
$cw->afterIdle(['reread',$cw,$cw->cget('-directory')])}}return$$var;}sub regexp{my($cw,$val)=@_;
my$var=\$cw->{Configure}{'-regexp'};
if(@_>1){$$var=$val;
$cw->{'match'}=sub{shift=~m|^${val}$|};
unless($cw->{'reread'}++){$cw->Busy;
$cw->afterIdle(['reread',$cw])}}return$$var;}sub defaultextension{my($cw,$val)=@_;
if(@_>1){$val=".$val" if($val!~/^\./);
$cw->filter("*$val");}else{$val=$cw->filter;
my($ext)=$val=~/(\.[^\.]*)$/;
return$ext;}}sub directory{my($cw,$dir)=@_;
my$var=\$cw->{Configure}{'-directory'};
if(@_>1&&defined$dir){if(substr($dir,0,1)eq '~'){if(substr($dir,1,1)eq '/'){$dir=$ENV{'HOME'}.substr($dir,1);}else{my($uid,$rest)=($dir=~m#^~([^/]+)(/.*$)#);
$dir=(getpwnam($uid))[7].$rest;}}$dir=~s#([^/\\])[\\/]+$#$1#;
if(-d$dir){unless(Tk::tainting()){my$pwd=Cwd::getcwd();
if(chdir((defined($dir)?$dir:''))){my$new=Cwd::getcwd();
if($new){$dir=$new;}else{carp"Cannot getcwd in '$dir'";}chdir($pwd)||carp"Cannot chdir($pwd) : $!";
$cw->{Configure}{'-directory'}=$dir;}else{$cw->BackTrace("Cannot chdir($dir) :$!");}}$$var=$dir;
unless($cw->{'reread'}++){$cw->Busy;
$cw->afterIdle(['reread',$cw])}}}return$$var;}sub reread{my($w)=@_;
my$dir=$w->cget('-directory');
if(defined$dir){if(!defined$w->cget('-filter')or$w->cget('-filter')eq ''){$w->configure('-filter','*');}my$dl=$w->Subwidget('dir_list');
$dl->delete(0,'end');
my$fl=$w->Subwidget('file_list');
$fl->delete(0,'end');
local*DIR;
if(opendir(DIR,$dir)){my$file=$w->cget('-initialfile');
my$seen=0;
my$accept=$w->cget('-accept');
foreach my $f(sort(readdir(DIR))){next if($f eq '.');
my$path="$dir/$f";
if(-d$path){$dl->insert('end',$f);}else{if(&{$w->{match}}($f)){if(!defined($accept)||$accept->Call($path)){$seen=$fl->index('end')if($file&&$f eq$file);
$fl->insert('end',$f)}}}}closedir(DIR);
if($seen){$fl->selectionSet($seen);
$fl->see($seen);}else{$w->configure(-initialfile=>undef)unless$w->cget('-create');}}$w->{DirectoryString}=$dir.'/'.$w->cget('-filter');}$w->{'reread'}=0;
$w->Unbusy;}sub validateDir{my($cw,$name)=@_;
my($leaf,$base)=fileparse($name);
if($leaf=~/[*?]/){$cw->configure('-directory'=>$base,'-filter'=>$leaf);}else{$cw->configure('-directory'=>$name);}}sub validateFile{my($cw,$name)=@_;
my$i=0;
my$n=$cw->index('end');
for($i=0;$i<$n;$i++){my$f=$cw->get($i);
if($f eq$name){$cw->selection('set',$i);
$cw->Accept;}}if($cw->cget('-create')){my$path=$cw->cget('-directory');
if(-w$path){if(&{$cw->{match}}($name)){my$accept=$cw->cget('-accept');
my$full="$path/$name";
if(!defined($accept)||$accept->Call($full)){$cw->{Selected}=[$full];
$cw->Callback(-command=>@{$cw->{Selected}});}else{$cw->Error("$name is not 'acceptable'");}}else{$cw->Error("$name does not match '".$cw->cget('-filter').'\'');}}else{$cw->Error("Directory '$path' is not writable");
return;}}}sub Error{my$cw=shift;
my$msg=shift;
my$dlg=$cw->Subwidget('dialog');
$dlg->configure(-text=>$msg);
$dlg->Show;}sub Show{my($cw,@args)=@_;
if($cw->cget('-transient')){$cw->Popup(@args);
$cw->focus;
$cw->waitVariable(\$cw->{Selected});
$cw->withdraw;
return defined($cw->{Selected})?(wantarray)?@{$cw->{Selected}}:$cw->{Selected}[0]:undef;}else{$cw->Popup(@args);}}sub FDialog{my($cmd,%args)=@_;
if($cmd=~/Save/){$args{-create}=1;
$args{-verify}=[qw(!-d -w)];}delete$args{-filetypes};
delete$args{-force};
Tk::DialogWrapper('FileSelect',$cmd,%args);}1;
__END__

=cut

