path: root/Master/tlpkg/tlperl/lib/Tk/DirSelect.pm

#===============================================================================
# Tk/DirSelect.pm
# Copyright (C) 2000-2001 Kristi Thompson <kristi@kristi.ca>
# Copyright (C) 2002-2005,2010 Michael Carman <mjcarman@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@kristi.ca>
Copyright 2002-2005,2010 Michael Carman <mjcarman@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