Tk-DirSelect-1.12000755000000000000 011337144021 14212 5ustar00unknownunknown000000000000Tk-DirSelect-1.12/Build.PL000444000000000000 102611336667354 15664 0ustar00unknownunknown000000000000use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Tk::DirSelect', license => 'perl', dist_author => 'Michael Carman ', dist_version_from => 'lib/Tk/DirSelect.pm', requires => { 'Tk' => 0, }, build_requires => { 'Test::More' => 0, }, add_to_cleanup => [ 'Tk-DirSelect-*' ], create_makefile_pl => 'traditional', ); $builder->create_build_script(); Tk-DirSelect-1.12/Changes000444000000000000 376711336671160 15667 0ustar00unknownunknown000000000000Revision history for Tk-DirSelect 1.12 (2010-02-17) * Dual-licensed under Artistic 2.0 and GPL. 1.11 (2005-08-19) * DirTree no longer resets to cwd after a rename. 1.10 (2005-08-17) * Under Tk v804+, make BrowseEntry not look disabled just because it's readonly. * Added context menu for creating, renaming and deleting directories. 1.09 (2004-10-22) * Pass additional arguments to Show() on to Popup(). * For Show() default the initial directory to cwd only when first argument is undef, not false. (Just in case someone actually has a directory named '0') 1.08 (2004-10-22) * On Win32, added a work-around for scrollbars sometimes appearing disabled. 1.07 (2004-05-21) * On Win32, added a work-around for inability to see other folders in the root directory of the drive containing the initial directory. Reselecting the drive from the drop menu now displays contents properly. (The root cause of the bug is in DirTree or one of its parent classes...) * Fixed $VERSION in DirSelect.pm (Oops.) 1.06 (2004-05-20) * Add Tk as dependancy in Makefile.PL. Should be beyond obvious to end users, but automated test sites aren't as smart. :) 1.05 (2004-05-20) * First CPAN release. * Added a patch for HList behavior changes around Tk 804.025. Corrects the problem where Show() returned an ARRAY ref instead of a string. 1.04 (2004-05-19) * Cleaned up guts (no longer recreates a DirTree for each drive change) * Generate drive list upon display, not creation. * Initial directory now an argument to Show() (not creation) * Better display of initial directory. * Changed title from default, allow user to set (at creation) 1.03 (2004-05-19) * Maintenance taken over by Michael Carman. * Use a BrowseEntry instead of buttons for Win32 drives * Restores cwd after finished. * Better passthrough of args to DirTree. * Lots of miscellaneous tweaks. Tk-DirSelect-1.12/Makefile.PL000444000000000000 71611337144021 16305 0ustar00unknownunknown000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.3603 use ExtUtils::MakeMaker; WriteMakefile ( 'PL_FILES' => {}, 'INSTALLDIRS' => 'site', 'NAME' => 'Tk::DirSelect', 'EXE_FILES' => [], 'VERSION_FROM' => 'lib/Tk/DirSelect.pm', 'PREREQ_PM' => { 'Test::More' => 0, 'Tk' => 0 } ) ; Tk-DirSelect-1.12/MANIFEST000444000000000000 20711337141622 15463 0ustar00unknownunknown000000000000Build.PL Changes MANIFEST README lib/Tk/DirSelect.pm Makefile.PL t/00-load.t t/manifest.t t/pod-coverage.t t/pod.t META.yml Tk-DirSelect-1.12/META.yml000444000000000000 102311337144021 15614 0ustar00unknownunknown000000000000--- abstract: 'Cross-platform directory selection widget.' author: - 'Michael Carman ' build_requires: Test::More: 0 configure_requires: Module::Build: 0.36 generated_by: 'Module::Build version 0.3603' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Tk-DirSelect provides: Tk::DirSelect: file: lib/Tk/DirSelect.pm version: 1.12 requires: Tk: 0 resources: license: http://dev.perl.org/licenses/ version: 1.12 Tk-DirSelect-1.12/README000444000000000000 275511336670760 15255 0ustar00unknownunknown000000000000Tk-DirSelect This module provides a cross-platform directory selection widget. For systems running Microsoft Windows, this includes selection of local and mapped network drives. DEPENDENCIES Perl 5.004 Tk 800 Win32API::File (under Microsoft Windows only) INSTALLATION To install this module, run the following commands: perl Build.PL ./Build ./Build test ./Build install Alternatively, you can use the following commands to install with ExtUtils::MakeMaker: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Tk::DirSelect You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Tk-DirSelect AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Tk-DirSelect CPAN Ratings http://cpanratings.perl.org/d/Tk-DirSelect Search CPAN http://search.cpan.org/dist/Tk-DirSelect/ LICENSE AND COPYRIGHT Copyright 2000-2001 Kristi Thompson Copyright 2002-2005,2010 Michael Carman This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. Tk-DirSelect-1.12/lib000755000000000000 011337144021 14760 5ustar00unknownunknown000000000000Tk-DirSelect-1.12/lib/Tk000755000000000000 011337144021 15336 5ustar00unknownunknown000000000000Tk-DirSelect-1.12/lib/Tk/DirSelect.pm000444000000000000 3350611337137065 17750 0ustar00unknownunknown000000000000#=============================================================================== # Tk/DirSelect.pm # Copyright (C) 2000-2001 Kristi Thompson # Copyright (C) 2002-2005,2010 Michael Carman # Last Modified: 2/16/2010 #=============================================================================== BEGIN { require 5.004 } package Tk::DirSelect; use Cwd; use File::Spec; use Tk 800; require Tk::Frame; require Tk::BrowseEntry; require Tk::Button; require Tk::Label; require Tk::DirTree; use strict; use base 'Tk::Toplevel'; Construct Tk::Widget 'DirSelect'; use vars qw'$VERSION'; $VERSION = '1.12'; my %colors; my $isWin32; #------------------------------------------------------------------------------- # Subroutine : ClassInit() # Purpose : Class initialzation. # Notes : #------------------------------------------------------------------------------- sub ClassInit { my ($class, $mw) = @_; $class->SUPER::ClassInit($mw); $isWin32 = $^O eq 'MSWin32'; # Get system colors from a Text widget for use in DirTree my $t = $mw->Text(); foreach my $x (qw'-background -selectbackground -selectforeground') { $colors{$x} = $t->cget($x); } $t->destroy(); } #------------------------------------------------------------------------------- # Subroutine : Populate() # Purpose : Create the DirSelect widget # Notes : #------------------------------------------------------------------------------- sub Populate { my ($w, $args) = @_; my $directory = delete $args->{-dir} || cwd(); my $title = delete $args->{-title} || 'Select Directory'; $w->withdraw; $w->SUPER::Populate($args); $w->ConfigSpecs(-title => ['METHOD', 'title', 'Title', $title]); $w->bind('', sub { $w->{dir} = undef }); my %f = ( drive => $w->Frame->pack(-anchor => 'n', -fill => 'x'), button => $w->Frame->pack(-side => 'bottom', -anchor => 's', -fill => 'x', -ipady => 6), tree => $w->Frame->pack(-fill => 'both', -expand => 1), ); $w->{tree} = $f{tree}->Scrolled('DirTree', -scrollbars => 'osoe', -selectmode => 'single', -ignoreinvoke => 0, -width => 50, -height => 15, %colors, %$args, )->pack(-fill => 'both', -expand => 1); $w->{tree}->configure(-command => sub { $w->{tree}->opencmd($_[0]) }); $w->{tree}->configure(-browsecmd => sub { $w->{tree}->anchorClear }); $f{button}->Button( -width => 7, -text => 'OK', -command => sub { $w->{dir} = $w->{tree}->selectionGet() }, )->pack(-side => 'left', -expand => 1); $f{button}->Button( -width => 7, -text => 'Cancel', -command => sub { $w->{dir} = undef }, )->pack(-side => 'left', -expand => 1); if ($isWin32) { $f{drive}->Label(-text => 'Drive:')->pack(-side => 'left'); $w->{drive} = $f{drive}->BrowseEntry( -variable => \$w->{selected_drive}, -browsecmd => [\&_browse, $w->{tree}], -state => 'readonly', )->pack(-side => 'left', -fill => 'x', -expand => 1); if ($Tk::VERSION >= 804) { # widget is readonly, but shouldn't appear disabled for my $e ($w->{drive}->Subwidget('entry')->Subwidget('entry')) { $e->configure(-disabledforeground => $colors{-foreground}); $e->configure(-disabledbackground => $colors{-background}); } } } else { $f{drive}->destroy; } # right-click context menu my $menu = $w->Menu( -tearoff => 0, -menuitems => [ [qw/command ~New/, -command => [\&_mkdir , $w]], [qw/command ~Rename/, -command => [\&_rename, $w]], [qw/command ~Delete/, -command => [\&_rmdir, $w]], ], ); $menu->bind('' => sub {$menu->unpost}); $w->{tree}->bind('' => [\&_context, $menu, Ev('X'), Ev('Y')]); # popup overlay for renaming directories $w->{renameval} = undef; $w->{popup} = $w->Toplevel(); $w->{rename} = $w->{popup}->Entry( -relief => 'groove', -borderwidth => 1, )->pack(-fill => 'x', -expand => 1); $w->{popup}->overrideredirect(1); $w->{popup}->withdraw; $w->{rename}->bind('', sub {$w->{renameval} = undef}); $w->{rename}->bind('', sub {$w->{renameval} = undef}); $w->{rename}->bind('', sub {$w->{renameval} = $w->{rename}->get}); return $w; } #------------------------------------------------------------------------------- # Subroutine : Show() # Purpose : Display the DirSelect widget. # Notes : #------------------------------------------------------------------------------- sub Show { my $w = shift; my $dir = shift; my $cwd = cwd(); my $focus = $w->focusSave; my $grab = $w->grabSave; $dir = $cwd unless defined $dir && -d $dir; chdir($dir); if ($isWin32) { # populate the drive list my @drives = _get_volume_info(); $w->{drive}->delete(0, 'end'); my $startdrive = _drive($dir); foreach my $d (@drives) { $w->{drive}->insert('end', $d); if ($startdrive eq _drive($d)) { $w->{selected_drive} = $d; } } } # show initial directory _showdir($w->{tree}, $dir); $w->Popup(@_); # show widget $w->focus; # seize focus $w->grab; # seize grab $w->waitVariable(\$w->{dir}); # wait for user selection (or cancel) $w->grabRelease; # release grab $w->withdraw; # run and hide $focus->(); # restore prior focus $grab->(); # restore prior grab chdir($cwd) # restore working directory or warn "Could not chdir() back to '$cwd' [$!]\n"; # HList SelectionGet() behavior changed around Tk 804.025 if (ref $w->{dir} eq 'ARRAY') { $w->{dir} = $w->{dir}[0]; } { local $^W; $w->{dir} .= '/' if ($isWin32 && $w->{dir} =~ /:$/); } return $w->{dir}; } #------------------------------------------------------------------------------- # Subroutine : _browse() # Purpose : Browse to a mounted filesystem (Win32) # Notes : #------------------------------------------------------------------------------- sub _browse { my ($w, undef, $d) = @_; $d = _drive($d) . '/'; chdir($d); _showdir($w, $d); # Workaround: Under Win* versions of Perl/Tk, scrollbars have a tendancy # to show up but be disabled. $w->yview(scroll => 1, 'units'); $w->update; $w->yview(scroll => -1, 'units'); } #------------------------------------------------------------------------------- # Subroutine : _showdir() # Purpose : Show the requested directory # Notes : #------------------------------------------------------------------------------- sub _showdir { my $w = shift; my $dir = shift; $w->delete('all'); $w->chdir($dir); } #------------------------------------------------------------------------------- # Subroutine : _get_volume_info() # Purpose : Get volume information (Win32) # Notes : #------------------------------------------------------------------------------- sub _get_volume_info { require Win32API::File; my @drivetype = ( 'Unknown', 'No root directory', 'Removable disk drive', 'Fixed disk drive', 'Network drive', 'CD-ROM drive', 'RAM Disk', ); my @drives; foreach my $ld (Win32API::File::getLogicalDrives()) { my $drive = _drive($ld); my $type = $drivetype[Win32API::File::GetDriveType($drive)]; my $label; Win32API::File::GetVolumeInformation( $drive, $label, [], [], [], [], [], []); push @drives, "$drive [$label] $type"; } return @drives; } #------------------------------------------------------------------------------- # Subroutine : _drive() # Purpose : Get the drive letter (Win32) # Notes : #------------------------------------------------------------------------------- sub _drive { shift =~ /^(\w:)/; return uc $1; } #------------------------------------------------------------------------------- # Method : _context # Purpose : Display the context menu # Notes : #------------------------------------------------------------------------------- sub _context { my ($w, $m, $x, $y) = @_; my $wy = $y - $w->rooty; $w->selectionClear(); $w->selectionSet($w->nearest($wy)); $m->post($x, $y); $m->focus; } #------------------------------------------------------------------------------- # Method : _mkdir # Purpose : Create a new directory under the current selection # Notes : #------------------------------------------------------------------------------- sub _mkdir { my $w = shift; my $dt = $w->{tree}; my ($sel) = $dt->selectionGet(); my $cwd = Cwd::cwd(); if (chdir($sel)) { my $base = 'NewDirectory'; my $name = $base; my $i = 1; while (-d $name && $i < 1000) { $name = $base . $i++; } unless (-d $name) { if (mkdir($name)) { _showdir($dt, $sel); $dt->selectionClear(); $dt->selectionSet($sel . '/' . $name); $w->_rename(); } else { $w->messageBox( -title => 'Unable to create directory', -message => "The directory '$name' could not be created.\n$!", -icon => 'error', -type => 'OK', ); } } chdir($cwd); } else { warn "Unable to chdir() for mkdir() [$!]\n"; } } #------------------------------------------------------------------------------- # Method : _rmdir # Purpose : Delete the selected directory # Notes : #------------------------------------------------------------------------------- sub _rmdir { my $w = shift; my $dt = $w->{tree}; my ($sel) = $dt->selectionGet(); my @path = File::Spec->splitdir($sel); my $dir = pop @path; my $pdir = File::Spec->catdir(@path); my $cwd = Cwd::cwd(); if (chdir($pdir)) { if (rmdir($dir)) { _showdir($dt, $pdir); } else { $w->messageBox( -title => 'Unable to delete directory', -message => "The directory '$dir' could not be deleted.\n$!", -icon => 'error', -type => 'OK', ); } chdir($cwd); } else { warn "Unable to chdir() for rmdir() [$!]\n"; } } #------------------------------------------------------------------------------- # Method : _rename # Purpose : Rename the selected directory # Notes : #------------------------------------------------------------------------------- sub _rename { my $w = shift; my $dt = $w->{tree}; my $popup = $w->{popup}; my $entry = $w->{rename}; my ($sel) = $dt->selectionGet(); my ($x, $y, $x1, $y1) = $dt->infoBbox($sel); my @path = File::Spec->splitdir($sel); my $dir = pop @path; my $pdir = File::Spec->catdir(@path); $entry->delete(0, 'end'); $entry->insert(0, $dir); $entry->selectionRange(0, 'end'); $entry->focus; my $font = ($entry->configure(-font))[4]; my $text = 'ABCDEFGHIGKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789 '; my $width = $entry->fontMeasure($font, $text) / length($text); $entry->configure(-width => ($x1 - $x) / $width); $popup->Post($dt->rootx + $x, $dt->rooty + $y); $popup->waitVariable(\$w->{renameval}); $popup->withdraw; if (defined $w->{renameval} && $w->{renameval} ne $dir) { my $cwd = Cwd::cwd(); if (chdir($pdir)) { unless (rename($dir, $w->{renameval})) { $w->messageBox( -title => 'Unable to rename directory', -message => "The directory '$dir' could not be renamed.\n$!", -icon => 'error', -type => 'OK', ); } chdir($cwd); _showdir($dt, $pdir); # rebrowse to update the display } else { warn "Unable to chdir() for rename() [$!]\n"; } } } 1; __END__ =pod =head1 NAME Tk::DirSelect - Cross-platform directory selection widget. =head1 SYNOPSIS use Tk::DirSelect; my $ds = $mw->DirSelect(); my $dir = $ds->Show(); =head1 DESCRIPTION This module provides a cross-platform directory selection widget. For systems running Microsoft Windows, this includes selection of local and mapped network drives. A context menu (right-click or EButton3E) allows the creation, renaming, and deletion of directories while browsing. Note: Perl/Tk 804 added the C method which uses native system dialogs where available. (i.e. Windows) If you want a native feel for your program, you probably want to use that method instead -- possibly using this module as a fallback for systems with older versions of Tk installed. =head1 METHODS =head2 C 'title'], [options])> Constructs a new DirSelect widget as a child of the invoking object (usually a MainWindow). The title for the widget can be set by specifying C<-title =E 'Title'>. Any other options provided will be passed through to the DirTree widget that displays directories, so be sure they're appropriate (e.g. C<-width>) =head2 C Displays the DirSelect widget and returns the user selected directory or C if the operation is canceled. All arguments are optional. The first argument (if defined) is the initial directory to display. The default is to display the current working directory. Any additional options are passed through to the Popup() method. This means that you can do something like $ds->Show(undef, -popover => $mw); to center the dialog over your application. =head1 DEPENDENCIES =over 4 =item * Perl 5.004 =item * Tk 800 =item * Win32API::File (under Microsoft Windows only) =back =head1 LICENSE AND COPYRIGHT Copyright 2000-2001 Kristi Thompson Copyright 2002-2005,2010 Michael Carman This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut Tk-DirSelect-1.12/t000755000000000000 011337144021 14455 5ustar00unknownunknown000000000000Tk-DirSelect-1.12/t/00-load.t000444000000000000 27011336667071 16130 0ustar00unknownunknown000000000000#!perl -T use Test::More tests => 1; BEGIN { use_ok( 'Tk::DirSelect' ) || print "Bail out! "; } diag( "Testing Tk::DirSelect $Tk::DirSelect::VERSION, Perl $], $^X" ); Tk-DirSelect-1.12/t/manifest.t000444000000000000 43511336667071 16605 0ustar00unknownunknown000000000000#!perl -T use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } eval "use Test::CheckManifest 0.9"; plan skip_all => "Test::CheckManifest 0.9 required" if $@; ok_manifest(); Tk-DirSelect-1.12/t/pod-coverage.t000444000000000000 107111336667071 17367 0ustar00unknownunknown000000000000use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); Tk-DirSelect-1.12/t/pod.t000444000000000000 36411336667071 15562 0ustar00unknownunknown000000000000#!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok();