The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# filebox.tcl --
#
# This demonstration script prompts the user to select a file.
#
# SCCS: @(#) filebox.tcl 1.3 97/03/02 16:22:36

use vars qw/$TOP/;

sub filebox {
    my $demo = shift;

    $TOP = $MW->WidgetDemo
      (
       -name     => $demo,
       -text     => "Enter a file name in the entry box or click on the \"Browse\" buttons to select a file name using the file selection dialog.",
       -title    => 'File box Demonstration',
       -iconname => 'filebox',
      );
    foreach my $i (qw(open save)) {
	my $f = $TOP->Frame;
	my $lab = $f->Label(-text => "Select a file to $i: ",
			    -anchor => 'e');
	my $ent = $f->Entry(-width => 20);
	my $but = $f->Button(-text => "Browse ...",
			     -command => sub { fileDialog($TOP, $ent, $i)});
	$lab->pack(-side => 'left');
	$ent->pack(-side => 'left',-expand => 'yes', -fill => 'x');
	$but->pack(-side => 'left');
	$f->pack(-fill => 'x', -padx => '1c', -pady => 3);
    }

    my $cbf = $TOP->Frame->pack(-fill => 'x', -padx => '1c', -pady => 3);
    my $fd;
    $cbf->Radiobutton
      (-text => 'FileSelect',
       -variable => \$fd,
       -value => 'FileSelect',
       -command => sub { local($^W) = 0;
			 require Tk::FileSelect;
			 Tk::FileSelect->import('as_default');
			 # XXX remove cached dialogs
			 my $mw = $TOP->MainWindow;
			 delete $mw->{'tk_getOpenFile'};
			 delete $mw->{'tk_getSaveFile'};
		     })->pack(-side => 'left');
    my $fdb = $cbf->Radiobutton
      (-text => 'FBox',
       -variable => \$fd,
       -value => 'FBox',
       -command => sub { local($^W) = 0;
			 require Tk::FBox;
			 Tk::FBox->import('as_default');
			 # XXX remove cached dialogs
			 my $mw = $TOP->MainWindow;
			 delete $mw->{'tk_getOpenFile'};
			 delete $mw->{'tk_getSaveFile'};
		     })->pack(-side => 'left');
    $fdb->invoke;

# XXX Motif style file box not implemented
#     unless (compare($tcl_platform{'platform'},'unix'))
#       {
# 	  $w->{'.strict'} = $w->Checkbutton('Name','strict','-text',"Use Motif Style Dialog",'-variable','tk_strictMotif','-onvalue',1,'-offvalue',0);
# 	  $w->{'.strict'}->pack('-anchor','c');
#       }
}

sub fileDialog {
    my $w = shift;
    my $ent = shift;
    my $operation = shift;
    my $types;
    my $file;
    #   Type names		Extension(s)	Mac File Type(s)
    #
    #---------------------------------------------------------
    @types =
      (["Text files",           [qw/.txt .doc/]],
       ["Text files",           '',             'TEXT'],
       ["Perl Scripts",         '.pl',		'TEXT'],
       ["C Source Files",	['.c', '.h']],
       ["All Source Files",     [qw/.tcl .c .h/]],
       ["Image Files",		'.gif'],
       ["Image Files",		['.jpeg', '.jpg']],
       ["Image Files",   	'',		[qw/GIFF JPEG/]],
       ["All files",		'*']
      );
    if ($operation eq 'open') {
	$file = $w->getOpenFile(-filetypes => \@types);
    } else {
	$file = $w->getSaveFile(-filetypes => \@types,
				-initialfile => 'Untitled',
				-defaultextension => '.txt');
    }
    if (defined $file and $file ne '') {
	$ent->delete(0, 'end');
	$ent->insert(0, $file);
	$ent->xview('end');
    }
}