r53392 - in /branches/upstream/libtk-dirselect-perl/current: Build.PL Changes DirSelect.pm MANIFEST META.yml Makefile.PL README lib/ lib/Tk/ lib/Tk/DirSelect.pm t/ t/00-load.t t/manifest.t t/pod-coverage.t t/pod.t test.pl
ddumont-guest at users.alioth.debian.org
ddumont-guest at users.alioth.debian.org
Sat Feb 27 16:28:57 UTC 2010
Author: ddumont-guest
Date: Sat Feb 27 16:28:49 2010
New Revision: 53392
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=53392
Log:
[svn-upgrade] Integrating new upstream version, libtk-dirselect-perl (1.12)
Added:
branches/upstream/libtk-dirselect-perl/current/Build.PL
branches/upstream/libtk-dirselect-perl/current/META.yml
branches/upstream/libtk-dirselect-perl/current/lib/
branches/upstream/libtk-dirselect-perl/current/lib/Tk/
branches/upstream/libtk-dirselect-perl/current/lib/Tk/DirSelect.pm
branches/upstream/libtk-dirselect-perl/current/t/
branches/upstream/libtk-dirselect-perl/current/t/00-load.t
branches/upstream/libtk-dirselect-perl/current/t/manifest.t
branches/upstream/libtk-dirselect-perl/current/t/pod-coverage.t
branches/upstream/libtk-dirselect-perl/current/t/pod.t
Removed:
branches/upstream/libtk-dirselect-perl/current/DirSelect.pm
branches/upstream/libtk-dirselect-perl/current/test.pl
Modified:
branches/upstream/libtk-dirselect-perl/current/Changes
branches/upstream/libtk-dirselect-perl/current/MANIFEST
branches/upstream/libtk-dirselect-perl/current/Makefile.PL
branches/upstream/libtk-dirselect-perl/current/README
Added: branches/upstream/libtk-dirselect-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/Build.PL?rev=53392&op=file
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/Build.PL (added)
+++ branches/upstream/libtk-dirselect-perl/current/Build.PL Sat Feb 27 16:28:49 2010
@@ -1,0 +1,20 @@
+use strict;
+use warnings;
+use Module::Build;
+
+my $builder = Module::Build->new(
+ module_name => 'Tk::DirSelect',
+ license => 'perl',
+ dist_author => 'Michael Carman <mjcarman at cpan.org>',
+ 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();
Modified: branches/upstream/libtk-dirselect-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/Changes?rev=53392&op=diff
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/Changes (original)
+++ branches/upstream/libtk-dirselect-perl/current/Changes Sat Feb 27 16:28:49 2010
@@ -1,48 +1,51 @@
-Revision history for Perl extension Tk::DirSelect.
-
-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.
+Revision 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.
Modified: branches/upstream/libtk-dirselect-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/MANIFEST?rev=53392&op=diff
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/MANIFEST (original)
+++ branches/upstream/libtk-dirselect-perl/current/MANIFEST Sat Feb 27 16:28:49 2010
@@ -1,6 +1,11 @@
-Changes
-DirSelect.pm
-Makefile.PL
-MANIFEST
-README
-test.pl
+Build.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
Added: branches/upstream/libtk-dirselect-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/META.yml?rev=53392&op=file
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/META.yml (added)
+++ branches/upstream/libtk-dirselect-perl/current/META.yml Sat Feb 27 16:28:49 2010
@@ -1,0 +1,23 @@
+---
+abstract: 'Cross-platform directory selection widget.'
+author:
+ - 'Michael Carman <mjcarman at cpan.org>'
+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
Modified: branches/upstream/libtk-dirselect-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/Makefile.PL?rev=53392&op=diff
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/Makefile.PL (original)
+++ branches/upstream/libtk-dirselect-perl/current/Makefile.PL Sat Feb 27 16:28:49 2010
@@ -1,11 +1,15 @@
-use 5.004;
-use ExtUtils::MakeMaker;
-
-WriteMakefile(
- 'NAME' => 'Tk::DirSelect',
- 'VERSION_FROM' => 'DirSelect.pm',
- 'PREREQ_PM' => {'Tk' => 800},
- ($] >= 5.005 ?
- (ABSTRACT_FROM => 'DirSelect.pm',
- AUTHOR => 'Michael J. Carman <mjcarman at mchsi.com>') : ()),
-);
+# 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
+ }
+ )
+;
Modified: branches/upstream/libtk-dirselect-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/README?rev=53392&op=diff
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/README (original)
+++ branches/upstream/libtk-dirselect-perl/current/README Sat Feb 27 16:28:49 2010
@@ -1,78 +1,60 @@
-Tk/DirSelect
-============
-
-This module provides a cross-platform directory selection widget. For
-systems running Microsoft Windows, this includes selection of local and
-mapped network drives.
-
-INSTALLATION
-
-To install this module type the following:
-
- perl Makefile.PL
- make
- make test
- make install
-
-CHANGES
-
-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.
-
-DEPENDENCIES
-
- Perl 5.004
- Tk 800
- Win32API::File (under Microsoft Windows only)
-
-COPYRIGHT AND LICENCE
-
-Copyright (C) 2000-2001 Kristi Thompson <kristi at kristi.ca>
-Copyright (C) 2002-2004 Michael J. Carman <mjcarman at mchsi.com>
-
-This library is free software under the terms of the Perl Artistic
-License.
+Tk-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 <kristi at kristi.ca>
+Copyright 2002-2005,2010 Michael Carman <mjcarman at cpan.org>
+
+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.
Added: branches/upstream/libtk-dirselect-perl/current/lib/Tk/DirSelect.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/lib/Tk/DirSelect.pm?rev=53392&op=file
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/lib/Tk/DirSelect.pm (added)
+++ branches/upstream/libtk-dirselect-perl/current/lib/Tk/DirSelect.pm Sat Feb 27 16:28:49 2010
@@ -1,0 +1,503 @@
+#===============================================================================
+# Tk/DirSelect.pm
+# Copyright (C) 2000-2001 Kristi Thompson <kristi at kristi.ca>
+# Copyright (C) 2002-2005,2010 Michael Carman <mjcarman at mchsi.com>
+# 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('<Escape>', 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('<FocusOut>' => sub {$menu->unpost});
+ $w->{tree}->bind('<Button-3>' => [\&_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('<Escape>', sub {$w->{renameval} = undef});
+ $w->{rename}->bind('<FocusOut>', sub {$w->{renameval} = undef});
+ $w->{rename}->bind('<KeyPress-Return>', 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 E<lt>Button3E<gt>)
+allows the creation, renaming, and deletion of directories while
+browsing.
+
+Note: Perl/Tk 804 added the C<chooseDirectory> 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<DirSelect([-title =E<gt> '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<gt>
+'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<Show([directory], [options])>
+
+Displays the DirSelect widget and returns the user selected directory or
+C<undef> 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 <kristi at kristi.ca>
+Copyright 2002-2005,2010 Michael Carman <mjcarman at cpan.org>
+
+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
Added: branches/upstream/libtk-dirselect-perl/current/t/00-load.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/t/00-load.t?rev=53392&op=file
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/t/00-load.t (added)
+++ branches/upstream/libtk-dirselect-perl/current/t/00-load.t Sat Feb 27 16:28:49 2010
@@ -1,0 +1,10 @@
+#!perl -T
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'Tk::DirSelect' ) || print "Bail out!
+";
+}
+
+diag( "Testing Tk::DirSelect $Tk::DirSelect::VERSION, Perl $], $^X" );
Added: branches/upstream/libtk-dirselect-perl/current/t/manifest.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/t/manifest.t?rev=53392&op=file
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/t/manifest.t (added)
+++ branches/upstream/libtk-dirselect-perl/current/t/manifest.t Sat Feb 27 16:28:49 2010
@@ -1,0 +1,13 @@
+#!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();
Added: branches/upstream/libtk-dirselect-perl/current/t/pod-coverage.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/t/pod-coverage.t?rev=53392&op=file
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/t/pod-coverage.t (added)
+++ branches/upstream/libtk-dirselect-perl/current/t/pod-coverage.t Sat Feb 27 16:28:49 2010
@@ -1,0 +1,18 @@
+use 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();
Added: branches/upstream/libtk-dirselect-perl/current/t/pod.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtk-dirselect-perl/current/t/pod.t?rev=53392&op=file
==============================================================================
--- branches/upstream/libtk-dirselect-perl/current/t/pod.t (added)
+++ branches/upstream/libtk-dirselect-perl/current/t/pod.t Sat Feb 27 16:28:49 2010
@@ -1,0 +1,12 @@
+#!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();
More information about the Pkg-perl-cvs-commits
mailing list