On Fri, 28 Apr 2000 [EMAIL PROTECTED] wrote:
> Subject: Re: How do I see the 'My Comuter' or all the NET in DirTree field ?
> I've wondered about this myself. Not having found an API call I've used
>
> sub drives {
> my @drives;
>
> for $i (C..Z) {
> $i="$i:";
> push (@drives, $i) if (-d "$i\\");
> }
> return @drives;
> }
>
> I haven't started from A since on NT this causes an error dialog to appear.
>
> I'm sure there's a better way than that.
I'm not sure about better, but...
I sent this out to the ptk mailing list about a month ago asking for
comments thinking I might submit it to CPAN. I got absolutely no interest.
I assumed it must be that my coding was not up to the standards expected by
the user community or some such, but you might find it useful.
It is a widget derived from dirtree that adds a BrowseEntry field with all
the drives on your machine including mapped network drives.
I have tried to write it so that it is portable between windows and unix,
but the unix part has not been tested.
Pod docs included.
Hope this helps.
package Tk::SelectDirTree;
use strict;
use vars qw($VERSION @ISA);
$VERSION = '0.01';
use base qw/Tk::Derived Tk::Toplevel/;
use Tk::widgets qw(Frame DirTree BrowseEntry);
use DirHandle;
use Cwd;
my $has_win32api;
BEGIN{
eval "use Win32API::File qw( :ALL )" if ( $^O eq "MSWin32" );
if ( $@ ) {
warn $@;
undef $has_win32api;
} else {
$has_win32api = 'yes';
}
}
Construct Tk::Widget 'SelectDirTree';
sub Populate {
my($dw, $args) = @_;
# Remove and save widget specific options and apply defaults.
my $state = delete $args->{'-state'};
$state = 'readonly' if ( ! $state );
my $listcmd = delete $args->{'-listcmd'};
my $choices = delete $args->{'-choices'};
my $arrowimage = delete $args->{'-arrowimage'};
my $scrollbars = delete $args->{'-scrollbars'};
$scrollbars = 'osow' if ( ! $scrollbars );
my $browsecmd = sub { $dw->choosedrive($dw->{'Configure'}{'-directory'}) };
$dw->SUPER::Populate($args);
$dw->protocol('WM_DELETE_WINDOW' => ['Cancel', $dw ]);
$dw->withdraw;
$dw->{'choice'} = "";
# Drop down menu
my $be = $dw->Component('BrowseEntry' => 'selectdrive',
'-browsecmd' => $browsecmd,
'-state' => $state,
'-variable' => \$dw->{'Configure'}{'-directory'},
);
$be->pack('-side' => 'top', '-expand' => 0, '-fill'=>'x','-anchor' => 'sw');
$be->bind('<Return>' => sub { $dw->checkdir($dw->{'Configure'}{'-directory'}) } );
# Did user supply choices for dropdown? If not use root dir or drives for Win32.
if ( $listcmd ) {
$be->configure('-listcmd'=> $listcmd)
} else {
if ( $choices ) {
$be->configure('-choices'=>$choices);
} else {
$dw->DriveChoices;
}
};
# User supplied arrow image for drop-down?
if ( $arrowimage ) { $be->configure('-arrowimage'=>$arrowimage);};
# Directory Tree
my $dt = $dw->Scrolled('DirTree',
'-dircmd' => \&mydircmd,
'-command' => ['Accept',$dw ],
'-browsecmd' => sub { $dw->{'Configure'}{'-directory'} = $_[0] },
'-scrollbars' => $scrollbars,
);
$dw->Advertise('yscrollbar'=>$dt->Subwidget('yscrollbar'));
$dw->Advertise('xscrollbar'=>$dt->Subwidget('xscrollbar'));
$dt->delete('all');
$dt->pack('-expand' => 1, '-fill' => 'both');
$dw->Advertise('dirtree' => $dt );
# Frame for the Accept and Cancel buttons.
my $f = $dw->Frame();
$f->pack(-side => 'top', -fill => 'none', -expand => 0,);
$dw->Advertise('buttonframe'=> $f);
my $b = $f->Button('-text' => 'Accept', -command => [ 'Accept', $dw ]);
$b->pack(-side => 'left','-padx'=>10);
$dw->Advertise('accept' => $b );
my $b2 = $f->Button('-text' => 'Cancel', -command => [ 'Cancel', $dw ]);
$b2->pack(-side => 'right','-padx'=>10);
$dw->Advertise('cancel' => $b2 );
$dw->ConfigSpecs(
'-fg'=> [['SELF','DESCENDANTS'],'foreground','Foreground',undef],
'-foreground'=> [['SELF','DESCENDANTS'],'foreground','Foreground',undef],
'-bg'=> [['SELF','DESCENDANTS'],'background','Background',undef],
'-background'=> [['SELF','DESCENDANTS'],'background','Background',undef],
'-directory' => ['SETMETHOD'],
'-state'=>[$be],
'-listcmd'=>[$be],
'-choices'=>[$be],
'-arrowimage'=>[$be],
'DEFAULT' => [$dt],
);
$dw->Delegates(
'DEFAULT' => $dt,
'insert'=>$be,
'delete'=>$be,
);
}
sub Show {
my ($cw,@args) = @_;
my $old_focus = $cw->focusSave;
my $old_grab = $cw->grabSave;
$cw->Popup(@args);
$cw->grab;
$cw->focus;
$cw->waitVariable(\$cw->{'choice'});
$cw->withdraw;
$cw->grabRelease;
&$old_focus;
&$old_grab;
return $cw->{'choice'};
}
sub Cancel {
my ($cw) = @_;
$cw->{'choice'} = undef;
}
sub Accept {
my ($cw) = @_;
$cw->{'choice'} = $cw->{'Configure'}{'-directory'};
}
sub directory {
my ($self, $ctype, $dir) = @_;
$self->{'Configure'}{'-directory'}=$dir;
my $dt = $self->Subwidget('dirtree');
$dt->directory($ctype,$dir);
}
sub chdir {
my ($self, $dir) = @_;
return if ( ! $dir );
$self->{'Configure'}{'-directory'}=$dir;
my $dt = $self->Subwidget('dirtree');
$dt->delete('all');
chdir($dir);
$dt->chdir($dir);
$dir =~ s%/$%% if ( length($dir) > 1 );
my $x=$self->Subwidget('dirtree')->selection('get');
$dt->selection('set',$dir);
}
sub checkdir {
my ($self, $dir) = @_;
$dir=fullpath($dir);
if ( -d $dir ) {
$self->chdir($dir);
} else {
my $dir=$self->Subwidget('dirtree')->selection('get');
$self->chdir($dir);
}
}
sub choosedrive {
my ($self, $dir) = @_;
$dir =~ s%\\%/%g;
$dir =~ s%\<.*\>$%%;
$self->checkdir($dir);
}
sub mydircmd {
my( $dir, $showhidden ) = @_;
$dir = $dir . '/';
my $h = DirHandle->new( $dir ) or return();
my @names = grep( $_ ne '.' && $_ ne '..', $h->read );
@names = grep( ! /^[.]/, @names ) unless $showhidden;
return( @names );
}
sub Win32GetDrives {
my ($self) = @_;
if ( $^O eq "MSWin32" && $has_win32api ) {
my %drivetypes = qw(
0 <Unknown> 1 <None> 2 <Removable> 3 <Fixed>
4 <Remote> 5 <CDRom> 6 <RamDisk>
);
my %drives;
my $dt;
my @roots= getLogicalDrives();
foreach my $drive ( @roots ) {
$drive =~ s%\\%/%;
$dt = GetDriveType( $drive );
$drives{$drive}=$drivetypes{$dt} if ( $dt != 1);
}
return %drives;
} else {
return ( '/' => '<root>' );
}
}
sub DriveList {
my ($self) = @_;
my @drives;
if ( $^O eq "MSWin32" && $has_win32api ) {
my %drives = Win32GetDrives();
foreach my $drive ( sort keys %drives ) {
push( @drives, $drive . $drives{$drive} );
}
} else {
@drives = qw(/);
}
return sort @drives;
}
sub DriveChoices {
my ( $self ) = @_;
my @choices = $self->DriveList();
$self->Subwidget('selectdrive')->configure('-choices'=>\@choices);
return @choices;
};
sub fullpath
{
my ($path) = @_;
my $cwd = getcwd();
if (CORE::chdir($path))
{
$path = getcwd();
CORE::chdir($cwd) || die "Cannot cd back to $cwd:$!";
}
else
{
warn "Cannot cd to $path:$!"
}
return $path;
}
1;
__END__
=head1 NAME
Tk::SelectDirTree - Perl extension to add drives to SelectDirTree.
=head1 SYNOPSIS
use Tk::SelectDirTree;
my $dt;
my $labmessage;
sub mylistcmd {
my ( $dt ) = @_;
$dt->configure( '-choices'=> [ 'C:/','D:/','E:/','F:/', 'Y:/' ] );
}
sub getdir {
$message = "Disable drop-down menu.";
$dt->configure('-state'=>'disabled');
$dt->chdir('C:/');
$result = $dt->Show();
# listcmd was set to user sub when widget was created via -listcmd.
$dt->configure('-title'=>"listcmd set to a user sub for dropdown");
$message = "Enable drop-down menu,\nbut don't allow user entry into box.";
$dt->configure('-state'=>'readonly');
$dt->chdir('C:/windows');
$result = $dt->Show();
$dt->chdir('C:/windows/system');
$dt->configure('-title'=>"Disable listcmd sub and set choices via configure");
$message = "Disable the execution of my listcmd\nwhen drop-down arrow is invoked.";
$dt->configure('-listcmd'=>undef);
$dt->configure('-state'=>'normal','-choices'=>['C:/windows<Main Windows
Dir>','C:/windows/system']);
$message = "Set user selected choices in drop-down list.";
$result = $dt->Show();
$dt->configure('-state'=>'readonly');
$dt->chdir('C:/windows');
$dt->configure('-title'=>"Set choices to drives available");
$message = "Sets the choices to be the\ndrives available on the system.\nThis is
the default\nif listcmd and choices are not set.";
$dt->DriveChoices;
$result = $dt->Show();
$message = "From script delete first entry\nand insert Z:/ at end\nin drop-down
list.";
$dt->delete('0');
$dt->insert('end','Z:/<This is just junk>');
$result = $dt->Show();
$message = "Select Exit to Quit";
}
sub getdrives {
my $drive;
$message = "";
my %drives = $dt->Win32GetDrives();
foreach $drive ( sort keys %drives ) {
# print $drive . $drives{$drive} . "\n";
$message = $message . $drive . "\n";
}
}
my($top) = MainWindow->new('-bg'=>'lightgreen');
$top->title("Test SelectDirTree");
my $getit = $top->Button(
'-command'=>\&getdir, '-text'=>'Select Dir',
'-width'=>10,
'-bg'=> 'lightblue',
'-activebackground'=> 'bisque',
);
$getit->pack;
my $getdrive = $top->Button(
'-command'=>\&getdrives, '-text'=>'Get Drives',
'-width'=>10,
'-bg'=> 'lightblue',
'-activebackground'=> 'bisque',
);
$getdrive->pack;
my $getout = $top->Button(
'-command'=>sub{exit;}, '-text'=>'Exit',
'-width'=>10,
'-bg'=> 'orange',
'-activebackground'=> 'bisque',
);
$getout->pack;
$labmessage = $top->Label(
'-textvariable'=>\$message,
'-bg'=> 'lightgreen',
'-width'=>40,
);
$labmessage->pack('-fill'=>'both','-expand'=>1,'anchor'=>'w');
$labresult = $top->Label(
'-textvariable'=>\$result,
'-bg'=> 'lightgreen',
);
$labresult->pack('-fill'=>'both','-expand'=>1,'anchor'=>'w');
$dt = $top->SelectDirTree(
'-title'=>"Select A Directory",
'-showhidden' => 1,
'-width' => 60,
'-height' => 40,
'-bg'=> 'lightgreen',
'-fg'=>'blue',
'-state'=>'readonly',
'-listcmd'=>\&mylistcmd,
# This is overridden by eht -listcmd option.
'-choices'=> [ 'C:/','D:/','E:/','F:/', 'X:/' ],
# Put the scrollbars where you want them default is 'osow'
# '-scrollbars'=>'sw',
);
my $bc = $dt->Subwidget('cancel');
$bc->configure(
'-bg'=>'lightblue',
'-activebackground'=> 'bisque',
);
my $ba = $dt->Subwidget('accept');
$ba->configure(
'-bg'=>'lightblue',
'-activebackground'=> 'bisque',
);
Tk::MainLoop;
=head1 DESCRIPTION
B<Tk::DirTree> assumes a Unix environment and does not let a user change to
a Windows drive. This adds that functionality via a BrowseEntry dropdown
type menu. I have also made the widget a toplevel window and added a
show method like fileselect has. I re-implemented dircmd (mydircmd) from
DirTree to put in a fix for problems on Windows when specifying the root
of a drive. I added an Accept and a Cancel Button to make it a more complete
selection dialog. I found that I was always needing scroll bars so I added
them. Since B<SelectDirTree> is derived from B<DirTree> it inherits it's
options and methods. It also inherits the -state and -listcmd options
from B<BrowseEntry>. The defualt is readonly for the -state.
This can be used to turn off ability to change drives (Win32).
The -listcmd is handled internally by defualt to give a list of drives on a
Win32 system and a '/' for others.
All sub-widgets are advertized and can be accessed via Subwidget. They are
'xscrollbar' and 'yscrollbar for the scrollbars of the DirTree widget
'dirtree' for the DirTree widget
'buttonframe' for the frame containing the "Accept" and "Cancel" buttons.
'accept' and 'cancel' for the accept and cancel buttons.
Most of the useful options of the subwidgets have been handled in the ConfigSpecs
but the Subwidget access can be useful for individual foreground and background
colors.
=over 8
=item -choices=> [ dir1, dir2, dir3, ... ]
This allows you to set the directory choices offered in the drop down menu.
This also turns off the ability to change drives (Win32). No check is made
if the dirs in the list passed in exist, but if you select them and they don't
exist, it is ignored. Each of the choices entered can have a comment appended
by preceeding the comment with a "<" and ending it with a ">";
=head1 METHODS
B<SelectDirTree> supports only two methods as of now:
=over 8
=item $retdir = B<Show(>I<options>B<)>
Display the selection dialog as a toplevel window and wait for a selection
( double-click on a directory or single-click on a directory and "Accept"
button) or "Cancel". Returns the full path of the selection or undef.
=item %rethash = B<Win32GetDrives()>
Return a hash of all the drives found on a system with the keys being the
drives and the values being the type of drive.
=back
=head1 AUTHOR
Eloy A. Gonzales, [EMAIL PROTECTED]
Copyright (c) 2000 Eloy Gonzales. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
perl(1), Tk::DirTree.
=cut
~=====================================================================~
~[ Eloy A. Gonzales Voice: (505) 844-1063 ]~
~[ Sandia National Laboratories Fax: (505) 844-7059 ]~
~[ Org 05743 MS 0965 email: [EMAIL PROTECTED] ]~
~[ Albuquerque, New Mexico 87185-0965 ]~
~=====================================================================~
---
You are currently subscribed to perl-win32-users as: [archive@jab.org]
To unsubscribe, forward this message to
[EMAIL PROTECTED]
For non-automated Mailing List support, send email to
[EMAIL PROTECTED]
