Tk::DirSelect - Verzeichnisse plattformunabhängig auswählen

Tk::DirSelect ist für Tk-Versionen gedacht, die für ein Betriebssystem keine Verzeichnisauswahl über chooseDirectory zulassen. Wird ein aktuelles Tk eingesetzt (in diesem Fall neuer als Tk 804), dann sollte chooseDirectory verwendet werden.

#!perl

use strict;
use warnings;
use Tk;
use FindBin qw/$Bin/;
use Tk::DirSelect;

my $mw = Tk::MainWindow->new();

my $ds  = $mw->DirSelect();
my $dir = $ds->Show($Bin);
  
$mw->MainLoop();

Ersatz für chooseDirectory

Falls es für ein Betriebssystem aber mal keine Implementierung von chooseDirectory geben sollte, dann kann mit nachstehendem Quellcode ein Ersatz mit Tk::DirSelect angezeigt werden. Der Vorteil: der Quellcode muss nicht geändert werden, da der Ersatz-Dialog nur zur Anwendung kommt, wenn es kein chooseDirectory gibt.
Quelle: Perl-Community.de, 09.08.2005

chooseDirectory-Ersatz: chooseDirectory lite

#!perl

use strict;
use warnings;
use utf8;
use Tk;

=head2 $top->chooseDirectory(%args)

=for category Tk

A directory selector. Possible arguments:

    * -initialdir
    * -title

=cut

if(!Tk::Widget->can("chooseDirectory")) {
*Tk::Widget::chooseDirectory = sub {
    my($top, %args) = @_;

    my $curr_dir = $args{-initialdir};
    if (!defined $curr_dir) {
        require Cwd;
        $curr_dir = Cwd::cwd();
    }
    if (defined $args{-mustexist}) {
        die "-mustexist is not yet implemented";
    }

    my $title = $args{-title} || "Choose directory:";

    require Tk::DirTree;
    my $t = $top->Toplevel;
    $t->title($title);
    my $ok = 0; # flag: "1" means OK, "-1" means cancelled

    # Create Frame widget before the DirTree widget, so it's always visible
    # if the window gets resized.
    my $f = $t->Frame->pack(-fill => "x", -side => "bottom");

    my $d;
    $d = $t->Scrolled('DirTree',
        -scrollbars => 'osoe',
        -width => 35,
        -height => 20,
        -selectmode => 'browse',
        -exportselection => 1,
        -browsecmd => sub{
            $curr_dir = shift;
            if ($^O ne 'MSWin32') {
                $curr_dir =~ s|^//|/|; # bugfix   
            }
        },
        # With this version of -command a double-click will
        # select the directory
        -command   => sub { $ok = 1 },
        # With this version of -command a double-click will
        # open a directory. Selection is only possible with
        # the Ok button.
        #-command   => sub { $d->opencmd($_[0]) },
    )->pack(-fill => "both", -expand => 1);
    
    # Set the initial directory
    exists &Tk::DirTree::chdir ? $d->chdir($curr_dir) : $d->set_dir($curr_dir);

    $f->Button(
        -text => 'Ok',
        -command => sub { $ok =  1 },
    )->pack(-side => 'left');
    
    $f->Button(
        -text => 'Cancel',
        -command => sub { $ok = -1 },
    )->pack(-side => 'left');
    
    $t->OnDestroy(sub { $ok = -1 });
    $f->waitVariable(\$ok);
    
    if ($ok == -1) {
        undef $curr_dir;
    }
    $t->destroy if Tk::Exists($t);
    $curr_dir;
};
}

my $mw = tkinit();

$mw->chooseDirectory;

$mw->MainWindow;
exit(0);
Top