use Tk::FileSelect; use Data::Dumper; use strict; use warnings; my $mw = new MainWindow; my $fs = $mw->FileSelect( -directory => '.' ); $fs->configure(-verify => ['-d'] ); print "$_: ",$fs->Subwidget($_),"\n" for 'dir_entry', # LabEntry 'file_entry', # LabEntry 'dir_list', # ScrlListbox 'file_list', # ScrlListbox 'dialog' # Dialog ; my %ch; $ch{$_} = $_ for $fs->children; delete $ch{$_} for $fs->Subwidget; my( $fr ) = @ch{ grep /Frame/, keys %ch }; my $b = $fr->Button( -text => "New Dir", -command => \&new_dir, ); $b->pack( -side => 'top', -fill => 'x', -expand => 1, ); my $file = $fs->Show; die "> $file\n"; sub new_dir { $fs->Subwidget('dir_entry')->validate; # note that this is the current "accepted" directory name from the # dir entry. It may not be the name of an existing directory! # but it will NOT have a trailing /* even if displayed. # it's possible to wangle the direntry into a state where it # has two slashes before the * and/or letters between # the / and * for example: /x//* /x/y* /x//y* # In all cases, the slash (both slashes, if present) up # through the star are excluded from the value of -directory. my $dir = $fs->cget('-directory'); print "Make a new dir under $dir !\n"; my $new_dirname = Prompt("Enter new folder name:"); # wave hands my $new_dir = "$dir/$new_dirname"; mkdir $new_dir; $fs->Accept_dir($new_dir); }