# DirSelect: A Tk directory selection widget.    
# 
# This widget allows navigating MS Windows local and mapped  network
# drives and directories and selecting a directory. 
# 
# Perl/Tk includes several widgets to perform the function of selectin
+g 
# a file or directory. However, widgets originally written for Unix 
# systems (such as FileSelect) don't allow browsing local and mapped 
# drives under Windows, and widgets adapted for Win32 systems that do 
# allow this (such as GetOpenFile) don't allow the user to select a 
# directory instead of a file. 
# 
# On non-MS systems, this is simply a dialog box with a Dirtree in it.
+ 
# 
# Usage: my $dir = $mainwindow->DirSelect->Show;  
# 
# Email comments, questions or bug reports to Kristi  Thompson,
# kristi@kristi.com 

package DirSelect; 
use vars qw($VERSION); 
$VERSION = '1.0'; 

@EXPORT_OK = qw(glob_to_re); 
use strict; 
use English; 
require Tk::Derived; 
use vars qw(@EXPORT_OK); 
use base qw(Tk::Toplevel); 
use Tk::widgets qw(Frame Button Radiobutton Label DirTree); 
use Cwd; 

Construct Tk::Widget 'DirSelect'; 

sub Populate { 
    my($cw, $args) = @ARG; 
    $cw->SUPER::Populate($args); 
 
    my $top = $cw->Frame( 
        -relief  => 'groove', 
        -bd      => 2, 
    )->pack( 
        -fill    => 'x', 
        -padx    => 2, 
        -pady    => 3, 
    ); 
    my $mid = $cw->Frame->pack( 
        -fill    => 'both', 
        -expand  => 1, 
    ); 
    my $bottom = $cw->Frame->pack( 
        -fill    => 'x', 
        -ipady   => 6, 
    ); 
 
    $bottom->Button( 
        -width   => 7, 
        -text    => 'OK', 
        -command => sub {$cw->{dir} = $mid->packSlaves- >selectionGet(
+)}, <br>
    )->pack( 
        -side    => 'left', 
        -expand  => 1, 
    ); 
    $bottom->Button (
        -width   => 7, 
        -text    => 'Cancel', 
        -command => sub {$cw->{dir} = undef}, 
    )->pack(  
        -side    => 'left', 
        -expand  => 1, 
    ); 

    if ($OSNAME !~ /mswin/i) { 
        $top->packForget; 
        _dirtree($mid, '/'); 
    } else { 
        require Win32API::File; 
        my @drives = Win32API::File::getLogicalDrives(); 
        my $startdrive = _drive(cwd); 
        my $selcolor   = $top->cget(-background); 
 
        foreach my $d (@drives) { 
            my $drive = _drive($d); 
            my $b = $top->Radiobutton( 
                -selectcolor => $selcolor, 
                -indicatoron => 0, 
                -text        => $drive, 
                -width       => 3, 
                -command     => [\&_browse, $mid, $d], 
                -value       => $d, 
            )->pack( 
                -side => 'left', 
                -padx => 4, 
                -pady => 6, 
            ); 
            $b->invoke if $startdrive eq $drive; 
        } 
    } 
} 

sub Show { 
    my($cw, $grab) = @ARG; 
    my $old_focus = $cw->focusSave; 
    my $old_grab  = $cw->grabSave; 
    $cw->Popup(); 
    Tk::catch { 
        if (defined($grab) and length($grab) and $grab  =~ /global/i) 
+{ <br>
            $cw->grabGlobal; 
        } else { 
            $cw->grab; 
        } 
    }; 
    $cw->focus; 
    $cw->_wait; 
    &$old_focus; 
    &$old_grab; 
    return($cw->{dir}); 
} 
 
sub _dirtree { 
    my($f, $d) = @ARG; 
    $f->Scrolled('DirTree', 
        -scrollbars => 'osoe', 
        -directory  => $d, 
        -bg         => 'white', 
    )->pack( 
        -fill   => 'both',  
        -expand => 1, 
        -pady   => 4, 
    ); 
} 

sub _drivelabel { 
    my($f, $msg) = @ARG; 
    $f->Label( 
        -text   => " $msg", 
        -relief => 'sunken', 
        -bd     => 1, 
        -anchor => 'w', 
    )->pack( 
        -padx   => 2, 
        -fill   => 'x', 
        -ipady  => 2, 
    ); 
} 

sub _drive { 
    shift =~ /^(.*:)/; 
    return($1); 
} 

sub _browse { 
    my($f, $d) = @ARG; 
 
    foreach ($f->packSlaves) {$_->packForget;} 
    my $drive = _drive($d); 
    if (chdir($d)) { 
        my $volumelabel; 
        Win32API::File::GetVolumeInformation($d,  $volumelabel,[],[],[
+],[],[],[]); <br>
        _drivelabel($f, "$volumelabel ($drive) " . 
                        {       0 => 'Unknown', 
                                1 => 'No root drive', 
                                2 => 'Removable disk drive', 
                                3 => 'Fixed disk drive', 
                                4 => 'Network drive', 
                                5 => 'CD-Rom drive', 
                                6 => 'RAM Disk', 
                        }->{Win32API::File::GetDriveType($d)} 
        ); 
        _dirtree($f, $d); 
    } else { 
        _drivelabel($f, "$drive is not available."); 
    } 
} 

sub _wait { 
    my($cw) = @ARG; 
    $cw->waitVariable(\$cw->{dir}); 
    $cw->grabRelease; 
    $cw->withdraw; 
    $cw->Callback(-command => $cw->{dir}); 
}

1;
[download]