File Coverage

blib/lib/Tk/DirSelect.pm

Criterion	Covered	Total	%
statement	8	10	80.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	12	14	85.7

#===============================================================================
# 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__