view release on metacpan or  search on metacpan

lib/Tk/DirSelect.pm  view on Meta::CPAN

		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