view release on metacpan or  search on metacpan

PathEntry.pm  view on Meta::CPAN

# -*- perl -*-

#
# Author: Slaven Rezic
#
# Copyright (c) 2001,2002,2003,2007,2008,2009,2017,2018,2019 Slaven Rezic. All rights reserved.
# Copyright (c) 2007,2009 Klaus Wittrock. All rights reserved.
# This package is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: srezic@cpan.org
# WWW:  https://github.com/eserte/tk-pathentry
#

package Tk::PathEntry;

use strict;
use vars qw($VERSION);
$VERSION = '3.08';

use base qw(Tk::Derived Tk::Entry);

Construct Tk::Widget 'PathEntry';

sub ClassInit {
    my($class,$mw) = @_;
    $class->SUPER::ClassInit($mw);

    # <Down>  -  popup the choices window
    $mw->bind($class,"<Down>" => sub {
		  my $w = shift;
		  my $choices_t = $w->Subwidget("ChoicesToplevel");
		  # If the popup list is not displayed, display it if possible
		  $w->_popup_on_key($w->get()) if $choices_t->state eq 'withdrawn';
		  if ($choices_t && $choices_t->state ne 'withdrawn') {
		      my $choices_l = $w->Subwidget("ChoicesLabel");
		      $choices_l->focus();
		      my @sel = $choices_l->curselection;
		      if (!@sel) {
			  $choices_l->selectionSet(0);
		      }
		  }
	      });

    for ("Meta", "Alt") {
	$mw->bind($class,"<$_-BackSpace>" => '_delete_last_path_component');
	$mw->bind($class,"<$_-d>"         => '_delete_next_path_component');
	$mw->bind($class,"<$_-f>"         => '_forward_path_component');
	$mw->bind($class,"<$_-b>"         => '_backward_path_component');
	$mw->bind($class,"<$_-Delete>"    => '_delete_next_path_component');
	$mw->bind($class,"<$_-Right>"     => '_forward_path_component');
	$mw->bind($class,"<$_-Left>"      => '_backward_path_component');
    }

    # Withdraw the choices listbox when the PathEntry looses focus
    $mw->bind($class,"<FocusOut>" => \&_bind_focusout);

    # On <Return> in the Entry withdraw the choices listbox and invoke the selectcmd callback
    $mw->bind($class,"<Return>" => \&_bind_return);

    $class;
}

# Class binding for <FocusOut>

sub _bind_focusout {
    my $w = shift;
    # Note: A button 1 mouse click in the choices listbox will invoke the
    # FocusOut callback of the Entry widget before invoking the Button-1 callback
    # of the choices listbox, if the focus is in the Entry at that moment.
    # In this case $w->focusCurrent is undefined. The Button-1 callback will
    #  withdraw the choices listbox.
    # Also $w->focusCurrent is undefined if the focus is passed to a
    # different window.
    return unless defined $w->focusCurrent;

    # Don't withdraw the choices listbox if the focus just has been passed to it.
    return if $w->focusCurrent eq $w->Subwidget("ChoicesLabel");

    # Sometimes the focus is passed from the PathEntry to the PathEntry
    # (that means $w->focusCurrent eq $w).