package Tk::FBox;
require Tk::Toplevel;
use strict;
use vars qw($VERSION $updirImage $folderImage $fileImage);
$VERSION = '3.019'; # $Id: //depot/Tk8/Tk/FBox.pm#19 $
use base qw(Tk::Toplevel);
Construct Tk::Widget 'FBox';
my$selectFilePath;
my$selectFile;
my$selectPath;
sub import{if(defined$_[1]and$_[1]eq 'as_default'){local$^W=0;
package Tk;
*FDialog=\&Tk::FBox::FDialog;
*MotifFDialog=\&Tk::FBox::FDialog;}}sub Populate{my($w,$args)=@_;
require Tk::IconList;
require File::Basename;
require Cwd;
$w->SUPER::Populate($args);
my$f1=$w->Frame;
my$lab=$f1->Label(-text=>'Directory:',-underline=>0);
$w->{'dirMenu'}=my$dirMenu=$f1->Optionmenu(-variable=>\$w->{'selectPath'},-command=>['SetPath',$w]);
my$upBtn=$f1->Button;
if(!defined$updirImage){$updirImage=$w->Bitmap(-data=>"#define updir_width 28\n"."#define updir_height 16\n". <<EOF);
static char updir_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
   0xf0, 0xff, 0xff, 0x01};
EOF
}$upBtn->configure(-image=>$updirImage);
$dirMenu->configure(-takefocus=>1,-highlightthickness=>2);
$upBtn->pack(-side=>'right',-padx=>4,-fill=>'both');
$lab->pack(-side=>'left',-padx=>4,-fill=>'both');
$dirMenu->pack(-expand=>'yes',-fill=>'both',-padx=>4);
$w->{'icons'}=my$icons=$w->IconList(-browsecmd=>['ListBrowse',$w],-command=>['ListInvoke',$w],);
my$f2=$w->Frame(-bd=>0);
my$f2_lab=$f2->Label(-text=>'File name:',-anchor=>'e',-width=>14,-underline=>5,-pady=>0);
$w->{'ent'}=my$ent=$f2->Entry;
$w->{'icons'}->configure(-font=>$ent->cget(-font));
my$f3=$w->Frame(-bd=>0);
$w->{'typeMenuLab'}=my$typeMenuLab=$f3->Button(-text=>'Files of type:',-anchor=>'e',-width=>14,-underline=>9,-bd=>$f2_lab->cget(-bd),-highlightthickness=>$f2_lab->cget(-highlightthickness),-relief=>$f2_lab->cget(-relief),-padx=>$f2_lab->cget(-padx),-pady=>$f2_lab->cget(-pady),);
$typeMenuLab->bindtags([$typeMenuLab,'Label',$typeMenuLab->toplevel,'all']);
$w->{'typeMenuBtn'}=my$typeMenuBtn=$f3->Menubutton(-indicatoron=>1,-tearoff=>0);
$typeMenuBtn->configure(-takefocus=>1,-highlightthickness=>2,-relief=>'raised',-bd=>2,-anchor=>'w',);
$w->{'okBtn'}=my$okBtn=$f2->Button(-text=>'OK',-underline=>0,-width=>6,-default=>'active',-pady=>3,);
my$cancelBtn=$f3->Button(-text=>'Cancel',-underline=>0,-width=>6,-default=>'normal',-pady=>3,);
$okBtn->pack(-side=>'right',-padx=>4,-anchor=>'e');
$f2_lab->pack(-side=>'left',-padx=>4);
$ent->pack(-expand=>'yes',-fill=>'x',-padx=>2,-pady=>0);
$cancelBtn->pack(-side=>'right',-padx=>4,-anchor=>'w');
$typeMenuLab->pack(-side=>'left',-padx=>4);
$typeMenuBtn->pack(-expand=>'yes',-fill=>'x',-side=>'right');
$f1->pack(-side=>'top',-fill=>'x',-pady=>4);
$f3->pack(-side=>'bottom',-fill=>'x');
$f2->pack(-side=>'bottom',-fill=>'x');
$icons->pack(-expand=>'yes',-fill=>'both',-padx=>4,-pady=>1);
$ent->bind('<Return>',[$w,'ActivateEnt']);
$upBtn->configure(-command=>['UpDirCmd',$w]);
$okBtn->configure(-command=>['OkCmd',$w]);
$cancelBtn->configure(-command,['CancelCmd',$w]);
$w->bind('<Alt-d>',[$dirMenu,'focus']);
$w->bind('<Alt-t>',sub{if($typeMenuBtn->cget(-state)eq 'normal'){$typeMenuBtn->focus;}});
$w->bind('<Alt-n>',[$ent,'focus']);
$w->bind('<KeyPress-Escape>',[$cancelBtn,'invoke']);
$w->bind('<Alt-c>',[$cancelBtn,'invoke']);
$w->bind('<Alt-o>',['InvokeBtn','Open']);
$w->bind('<Alt-s>',['InvokeBtn','Save']);
$w->protocol('WM_DELETE_WINDOW',['CancelCmd',$w]);
$w->OnDestroy(['CancelCmd',$w]);
$w->FG_Create;
$w->FG_BindIn($ent,['EntFocusIn',$w]);
$w->FG_BindOut($ent,['EntFocusOut',$w]);
$w->SetPath(_cwd());
$w->ConfigSpecs(-defaultextension=>['PASSIVE',undef,undef,undef],-filetypes=>['PASSIVE',undef,undef,undef],-initialdir=>['PASSIVE',undef,undef,undef],-initialfile=>['PASSIVE',undef,undef,undef],-title=>['PASSIVE',undef,undef,undef],-type=>['PASSIVE',undef,undef,'open'],-filter=>['PASSIVE',undef,undef,'*'],-force=>['PASSIVE',undef,undef,0],'DEFAULT'=>[$icons],);
$w->_OnDestroy(qw(dirMenu icons typeMenuLab typeMenuBtn okBtn ent updateId));
$w;}sub Show{my$w=shift;
$w->configure(@_);
$w->transient($w->Parent);
{my$initialdir=$w->cget(-initialdir);
if(defined$initialdir){if(-d$initialdir){$w->{'selectPath'}=$initialdir;}else{$w->Error("\"$initialdir\" is not a valid directory");}}$w->{'selectFile'}=$w->cget(-initialfile);}my$typeMenuBtn=$w->{'typeMenuBtn'};
my$typeMenuLab=$w->{'typeMenuLab'};
if(defined$w->cget('-filetypes')){my(@filetypes)=GetFileTypes($w->cget('-filetypes'));
my$typeMenu=$typeMenuBtn->cget(-menu);
$typeMenu->delete(0,'end');
foreach my $ft(@filetypes){my$title=$ft->[0];
my$filter=join(' ',@{$ft->[1]});
$typeMenuBtn->command(-label=>$title,-command=>['SetFilter',$w,$title,$filter],);}$w->SetFilter($filetypes[0]->[0],join(' ',@{$filetypes[0]->[1]}));
$typeMenuBtn->configure(-state=>'normal');
$typeMenuLab->configure(-state=>'normal');}else{$w->configure(-filter=>'*');
$typeMenuBtn->configure(-state=>'disabled',-takefocus=>0);
$typeMenuLab->configure(-state=>'disabled');}$w->UpdateWhenIdle;
$w->withdraw;
$w->idletasks;
my$x=int($w->screenwidth/2-$w->reqwidth/2-$w->parent->vrootx);
my$y=int($w->screenheight/2-$w->reqheight/2-$w->parent->vrooty);
$w->geometry("+$x+$y");
{my$title=$w->cget(-title);
if(!defined$title){$title=($w->cget(-type)eq 'open'?'Open':'Save As');}$w->title($title);}$w->deiconify;
my$oldFocus=$w->focusCurrent;
my$oldGrab=$w->grabCurrent;
my$grabStatus=$oldGrab->grabStatus if($oldGrab);
$w->grab;
my$ent=$w->{'ent'};
$ent->focus;
$ent->delete(0,'end');
$ent->insert(0,$w->{'selectFile'});
$ent->selectionFrom(0);
$ent->selectionTo('end');
$ent->icursor('end');
$w->waitVariable(\$selectFilePath);
eval{$oldFocus->focus if$oldFocus;};
if(Tk::Exists($w)){$w->grabRelease;
$w->withdraw;}if($oldGrab){if($grabStatus eq 'global'){$oldGrab->grabGlobal;}else{$oldGrab->grab;}}return$selectFilePath;}sub UpdateWhenIdle{my$w=shift;
if(exists$w->{'updateId'}){return;}else{$w->{'updateId'}=$w->after('idle',[$w,'Update']);}}sub Update{my$w=shift;
my$dataName=$w->name;
if(!Tk::Exists($w)||$w->class ne 'FBox'){return;}else{delete$w->{'updateId'};}unless(defined$folderImage){require Tk::Pixmap;
$folderImage=$w->Pixmap(-file=>Tk->findINC('folder.xpm'));
$fileImage=$w->Pixmap(-file=>Tk->findINC('file.xpm'));}my$folder=$folderImage;
my$file=$fileImage;
my$appPWD=_cwd();
if(!ext_chdir($w->{'selectPath'})){$w->messageBox(-type=>'OK',-message=>'Cannot change to the directory "'.$w->{'selectPath'}."\".\nPermission denied.",-icon=>'warning',);
ext_chdir($appPWD);
return;}my$ent=$w->{'ent'};
my$entCursor=$ent->cget(-cursor);
my$dlgCursor=$w->cget(-cursor);
$ent->configure(-cursor=>'watch');
$w->configure(-cursor=>'watch');
$w->idletasks;
my$icons=$w->{'icons'};
$icons->DeleteAll;
my$flt=join('|',split(' ',$w->cget(-filter)));
$flt=~s!([\.\+])!\\$1!g;
$flt=~s!\*!.*!g;
local*FDIR;
if(opendir(FDIR,_cwd())){my@files;
foreach my $f(sort{lc($a)cmp lc($b)}readdir FDIR){next if$f eq '.' or$f eq '..';
if(-d$f){$icons->Add($folder,$f);}elsif($f=~m!$flt$!){push(@files,$f);}}closedir(FDIR);
foreach my $f(@files){$icons->Add($file,$f);}}$icons->Arrange;
my@list;
my$dir='';
foreach my $subdir(TclFileSplit($w->{'selectPath'})){$dir=TclFileJoin($dir,$subdir);
push@list,$dir;}my$dirMenu=$w->{'dirMenu'};
$dirMenu->configure(-options=>\@list);
ext_chdir($appPWD);
if($w->cget(-type)eq 'save'){$w->{'okBtn'}->configure(-text=>'Save');}$ent->configure(-cursor=>$entCursor);
$w->configure(-cursor=>$dlgCursor);}sub SetPathSilently{my($w,$path)=@_;
$w->{'selectPath'}=$path;}sub SetPath{my$w=shift;
$w->{'selectPath'}=$_[0]if@_;
$w->UpdateWhenIdle;}sub SetFilter{my($w,$title,$filter)=@_;
$w->configure(-filter=>$filter);
$w->{'typeMenuBtn'}->configure(-text=>$title,-indicatoron=>1);
$w->{'icons'}->Subwidget('sbar')->set(0.0,0.0);
$w->UpdateWhenIdle;}sub ResolveFile{my($context,$text,$defaultext)=@_;
my$appPWD=_cwd();
my$path=JoinFile($context,$text);
$path="$path$defaultext" if($path!~/\..+$/)and defined$defaultext;
my($directory,$file,$flag);
if(-e$path){if(-d$path){if(!ext_chdir($path)){return('CHDIR',$path,'');}$directory=_cwd();
$file='';
$flag='OK';
ext_chdir($appPWD);}else{my$dirname=File::Basename::dirname($path);
if(!ext_chdir($dirname)){return('CHDIR',$dirname,'');}$directory=_cwd();
$file=File::Basename::basename($path);
$flag='OK';
ext_chdir($appPWD);}}else{my$dirname=File::Basename::dirname($path);
if(-e$dirname){if(!ext_chdir($dirname)){return('CHDIR',$dirname,'');}$directory=_cwd();
$file=File::Basename::basename($path);
if($file=~/[*?]/){$flag='PATTERN';}else{$flag='FILE';}ext_chdir($appPWD);}else{$directory=$dirname;
$file=File::Basename::basename($path);
$flag='PATH';}}return($flag,$directory,$file);}sub EntFocusIn{my$w=shift;
my$ent=$w->{'ent'};
if($ent->get ne ''){$ent->selectionFrom(0);
$ent->selectionTo('end');
$ent->icursor('end');}else{$ent->selectionClear;}$w->{'icons'}->Unselect;
my$okBtn=$w->{'okBtn'};
if($w->cget(-type)eq 'open'){$okBtn->configure(-text=>'Open');}else{$okBtn->configure(-text=>'Save');}}sub EntFocusOut{my$w=shift;
$w->{'ent'}->selectionClear;}sub ActivateEnt{my$w=shift;
my$ent=$w->{'ent'};
my$text=$ent->get;
$text=~s/^\s+//;
$text=~s/\s+$//;
my($flag,$path,$file)=ResolveFile($w->{'selectPath'},$text,$w->cget(-defaultextension));
if($flag eq 'OK'){if($file eq ''){$w->SetPath($path);
$ent->delete(0,'end');}else{$w->SetPathSilently($path);
$w->{'selectFile'}=$file;
$w->Done;}}elsif($flag eq 'PATTERN'){$w->SetPath($path);
$w->configure(-filter=>$file);}elsif($flag eq 'FILE'){if($w->cget(-type)eq 'open'){$w->messageBox(-icon=>'warning',-type=>'OK',-message=>'File "'.TclFileJoin($path,$file).'" does not exist.');
$ent->selection('from',0);
$ent->selection('to','end');
$ent->icursor('end');}else{$w->SetPathSilently($path);
$w->{'selectFile'}=$file;
$w->Done;}}elsif($flag eq 'PATH'){$w->messageBox(-icon=>'warning',-type=>'OK',-message=>"Directory \'$path\' does not exist.");
$ent->selection('from',0);
$ent->selection('to','end');
$ent->icursor('end');}elsif($flag eq 'CHDIR'){$w->messageBox(-type=>'OK',-message=>"Cannot change to the directory \"$path\".\nPermission denied.",-icon=>'warning');
$ent->selection('from',0);
$ent->selection('to','end');
$ent->icursor('end');}elsif($flag eq 'ERROR'){$w->messageBox(-type=>'OK',-message=>"Invalid file name \"$path\".",-icon=>'warning');
$ent->selection('from',0);
$ent->selection('to','end');
$ent->icursor('end');}}sub InvokeBtn{my($w,$key)=@_;
my$okBtn=$w->{'okBtn'};
$okBtn->invoke if($okBtn->cget(-text)eq$key);}sub UpDirCmd{my$w=shift;
$w->SetPath(File::Basename::dirname($w->{'selectPath'}))unless($w->{'selectPath'}eq '/');}sub JoinFile{my($path,$file)=@_;
if($file=~/^~/&&-e"$path/$file"){TclFileJoin($path,"./$file");}else{TclFileJoin($path,$file);}}sub TclFileJoin{my$path='';
foreach(@_){if(m|^/|){$path=$_;}elsif(m|^[a-z]:/|i){$path=$_;}elsif($_ eq '~'){$path=_get_homedir();}elsif(m|^~/(.*)|){$path=_get_homedir()."/".$1;}elsif(m|^~([^/]+)(.*)|){my($user,$p)=($1,$2);
my$dir=_get_homedir($user);
if(!defined$dir){$path="~$user$p";}else{$path=$dir.$p;}}elsif($path eq '/' or$path eq ''){$path.=$_;}else{$path.="/$_";}}$path;}sub TclFileSplit{my$path=shift;
my@comp;
$path=~s|/+|/|g;
if($path=~m|^/|){push@comp,'/';
$path=substr($path,1);}push@comp,split/\//,$path;
@comp;}sub OkCmd{my$w=shift;
my$text=$w->{'icons'}->Get;
if(defined$text and$text ne ''){my$file=JoinFile($w->{'selectPath'},$text);
if(-d$file){$w->ListInvoke($text);
return;}}$w->ActivateEnt;}sub CancelCmd{undef$selectFilePath;}sub ListBrowse{my($w,$text)=@_;
return if($text eq '');
my$file=JoinFile($w->{'selectPath'},$text);
my$ent=$w->{'ent'};
my$okBtn=$w->{'okBtn'};
unless(-d$file){$ent->delete(0,'end');
$ent->insert(0,$text);
if($w->cget(-type)eq 'open'){$okBtn->configure(-text=>'Open');}else{$okBtn->configure(-text=>'Save');}}else{$okBtn->configure(-text=>'Open');}}sub ListInvoke{my($w,$text)=@_;
return if($text eq '');
my$file=JoinFile($w->{'selectPath'},$text);
if(-d$file){my$appPWD=_cwd();
if(!ext_chdir($file)){$w->messageBox(-type=>'OK',-message=>"Cannot change to the directory \"$file\".\nPermission denied.",-icon=>'warning');}else{ext_chdir($appPWD);
$w->SetPath($file);}}else{$w->{'selectFile'}=$file;
$w->Done;}}sub Done{my$w=shift;
my$_selectFilePath=(@_)?shift:'';
if($_selectFilePath eq ''){$_selectFilePath=JoinFile($w->{'selectPath'},$w->{'selectFile'});
if(-e$_selectFilePath and$w->cget(-type)eq 'save' and!$w->cget(-force)){my$reply=$w->messageBox(-icon=>'warning',-type=>'YesNo',-message=>"File \"$_selectFilePath\" already exists.\nDo you want to overwrite it?");
return unless(lc($reply)eq 'yes');}}$selectFilePath=($_selectFilePath ne ''?$_selectFilePath:undef);}sub FDialog{my$cmd=shift;
if($cmd=~/Save/){push@_,-type=>'save';}Tk::DialogWrapper('FBox',$cmd,@_);}sub GetFileTypes{my$in=shift;
my%fileTypes;
foreach my $t(@$in){if(@$t<2||@$t>3){require Carp;
Carp::croak("bad file type \"$t\", should be \"typeName [extension ?extensions ...?] ?[macType ?macTypes ...?]?\"");}push@{$fileTypes{$t->[0]}},(ref$t->[1]eq 'ARRAY'?@{$t->[1]}:$t->[1]);}my@types;
my%hasDoneType;
my%hasGotExt;
foreach my $t(@$in){my$label=$t->[0];
my@exts;
next if(exists$hasDoneType{$label});
my$name="$label (";
my$sep='';
foreach my $ext(@{$fileTypes{$label}}){next if($ext eq '');
$ext=~s/^\./*./;
if(!exists$hasGotExt{$label}->{$ext}){$name.="$sep$ext";
push@exts,$ext;
$hasGotExt{$label}->{$ext}++;}$sep=',';}$name.=')';
push@types,[$name,\@exts];
$hasDoneType{$label}++;}return@types;}sub ext_chdir{my$dir=shift;
if($dir eq '~'){chdir _get_homedir();}elsif($dir=~m|^~/(.*)|){chdir _get_homedir()."/".$1;}elsif($dir=~m|^~([^/]+(.*))|){chdir _get_homedir($1).$2;}else{chdir$dir;}}sub _get_homedir{my($user)=@_;
if(!defined$user){eval{local$SIG{__DIE__};
(getpwuid($<))[7];}||$ENV{HOME}||undef;}else{eval{local$SIG{__DIE__};
(getpwnam($user))[7];};}}sub _cwd{Cwd::fastcwd();}sub _untaint{my$s=shift;
$s=~/^(.*)$/;
$1;}1;
