# # MatchEntry.pm # # Revision : $Revision: 1.12 $ # Last changed on: $Date: 2005/06/30 05:29:28 $ # # # MatchEntry is an entry widget with auto-completion capabilities. It attempts # to fill the gap in functionality between Tk::BrowseEntry and Tk::HistEntry # with focus on user-friendliness concerning the auto-completion. # # Set package name package Tk::MatchEntry; # Set version information use vars qw($VERSION); $VERSION = '0.4'; # Define dependencies use strict; # use warnings; # use warnings for debugging purposes use Tk qw(Ev); use Carp; # use Data::Dumper; # for debugging require Tk::Frame; require Tk::LabEntry; # Construct widget use base qw(Tk::Frame); Construct Tk::Widget 'MatchEntry'; # Compositing the widget sub Populate { my ($self, $args) = @_; $self->SUPER::Populate($args); # let ancestors populate first # Create the entry subwidget my $labelpack = delete $args->{-labelPack}; unless (defined $labelpack) { $labelpack = [-side => 'left', -anchor => 'e']; # set defaults } my $content = ""; # initialize entry text my $entry = $self->LabEntry(-labelPack => $labelpack, -label => delete $args->{-label}, -textvariable => \$content, -exportselection => 0); $self->Advertise('entry' => $entry); # make it available to outside $entry->pack(-side => 'right', -fill => 'x', -expand => 1); # place the entry widget in our frame # Create the popup-listbox my $popup_frame = $self->Toplevel(-bd => 2, -relief => 'raised'); $popup_frame->overrideredirect(1); # turn off window decorations $popup_frame->withdraw; # start hidden # set exportselection to 0 in the listbox widget so we can have # selections in both the entry and the listbox widget at the same time my $scrolled_listbox = $popup_frame->Scrolled( qw/Listbox -selectmode browse -scrollbars oe -exportselection 0/ ); $self->Advertise('choices' => $popup_frame); $self->Advertise('slistbox' => $scrolled_listbox); $scrolled_listbox->pack(-expand => 1, -fill => 'both'); # place it # Other initializations $self->set_bindings; # Set up keyboard and mouse bindings $self->{'popped'} = 0; # Start with hidden listbox $self->Delegates('insert' => $scrolled_listbox, 'delete' => $scrolled_listbox, 'get' => $scrolled_listbox, DEFAULT => $entry); $self->ConfigSpecs( -bottomcmd => [qw/CALLBACK bottomCmd BottomCmd/, undef], -browsecmd => [qw/CALLBACK browseCmd BrowseCmd/, undef], -entercmd => [qw/CALLBACK enterCmd EnterCmd/, undef], -listcmd => [qw/CALLBACK listCmd ListCmd/, undef], -mm_onecmd => [qw/CALLBACK mm_oneCmd mm_OneCmd/, undef], -mm_zerocmd => [qw/CALLBACK mm_zeroCmd mm_ZeroCmd/, undef], -onecmd => [qw/CALLBACK oneCmd OneCmd/, undef], -sortcmd => [qw/CALLBACK sortCmd SortCmd/, undef], -tabcmd => [qw/CALLBACK tabCmd TabCmd/, undef], -topcmd => [qw/CALLBACK topCmd TopCmd/, undef], -zerocmd => [qw/CALLBACK zeroCmd ZeroCmd/, undef], -command => '-browsecmd', -ignorecase => '-case', -options => '-choices', -variable => '-textvariable', -choices => [qw/METHOD choices Choices/, undef], -state => [qw/METHOD state State normal/], -popup => [qw/METHOD popup Popup/, undef], -autopopup => [qw/PASSIVE autoPopup AutoPopup 1/], -autoshrink => [qw/PASSIVE autoShrink AutoShrink 1/], -autosort => [qw/PASSIVE autoSort AutoSort 1/], -case => [qw/PASSIVE case Case 0/], -colorstate => [qw/PASSIVE colorState ColorState/, undef], -complete => [qw/PASSIVE complete Complete 1/], -fixedwidth => [qw/PASSIVE fixedWidth FixedWidth 1/], -listwidth => [qw/PASSIVE listWidth ListWidth/, undef], -matchprefix => [qw/PASSIVE matchPrefix MatchPrefix/,undef], -maxheight => [qw/PASSIVE maxHeight MaxHeight 5/], -multimatch => [qw/PASSIVE multiMatch MultiMatch 0/], -sorttrigger => [qw/PASSIVE sortTrigger SortTrigger/,undef], -wraparound => [qw/PASSIVE wrapAround WrapAround 0/], DEFAULT => [[$entry, $scrolled_listbox]] ); } # Set up the keyboard and mouse event bindings sub set_bindings { my ($self) = @_; my $entry = $self->Subwidget('entry'); # Set the bind tags $self->bindtags([$self, 'Tk::MatchEntry', $self->toplevel, 'all']); $entry->bindtags([$entry, $entry->toplevel, 'all']); # Bindings for the entry widget #$entry->bind('', [$self, 'open_and_focus_listbox']); $entry->bind('', [$self, 'entry_cursor_down']); $entry->bind('', [$self, 'entry_cursor_up']); $entry->bind('', [$self, 'entry_escape']); $entry->bind('', [$self, 'entry_tabulator']); $entry->bind('', [$self, 'entry_return']); $entry->bind('', [$self, 'entry_leave']); $entry->bind('', sub { my $event = $_[0]->XEvent; $self->entry_anykey($event->K, $event->s); # Key, State }); # Bindings for the listbox my $scrolled_list = $self->Subwidget('slistbox'); my $listbox = $scrolled_list->Subwidget('listbox'); $listbox->bind('', [$self, 'release_listbox', Ev('x'), Ev('y')]); $listbox->bind('' => [$self, 'close_listbox', $listbox]); $listbox->bind('' => [$self, 'return_listbox', $listbox]); $listbox->bind('' => [$self, 'listbox_tab', $listbox]); # Close listbox if clicked outside $self->bind('<1>', 'open_listbox'); } # Called when the entry widget loses focus to make sure any text is deselected sub entry_leave { my $self = shift; $self->entry_prepare_leave; } # Called when the user hits within the entry widget sub entry_return { my $self = shift; # Execute given callback $self->Callback(-entercmd => $self); # Hide the listbox, if popped up, deselect all entry text, place cursor # at end of entry widget $self->entry_prepare_leave; } # Called when the user hits within the entry widget sub entry_tabulator { my $self = shift; # Execute given callback $self->Callback(-tabcmd => $self); # Hide the listbox, if popped up, deselect all entry text, place cursor # at end of entry widget $self->entry_prepare_leave; } # Hide the listbox, if popped up, deselect all entry text, place cursor # at end of entry widget sub entry_prepare_leave { my $self = shift; my $entry = $self->Subwidget('entry'); # close the listbox if popped up if ($self->{'popped'}) { $self->hide_listbox; } # clear the selection $entry->selection('clear'); # place the input cursor at end of entry widget $entry->icursor($entry->index('end')); # finalize the auto-completion $self->check_choice_case; } # If we have case-insensitive auto-completion, check whether the text in the # entry widget matches one of the choices (case-insensitively). If so, replace # it with the choice. This allows the user to enter "john doe", but makes sure # the result is "John Doe" when the MatchEntry widget is left. sub check_choice_case { my $self = shift; my $entry = $self->Subwidget('entry'); return unless ($self->cget(-case)); # abort if case sensitive matching my $text = $entry->get; # text in entry widget my $all_choices_r = $self->{Configure}{all_choices_r}; my @all_choices = @$all_choices_r; foreach my $choice (@all_choices) { # loop over all choices # check whether choice matches text case-insensitively but not # case-sensitively if ($text =~ m/^\Q$choice\E$/i && ($text ne $choice)) { # if so, replace the text in the entry widget with the choice $entry->delete(0, 'end'); $entry->insert(0, $choice); $entry->icursor($entry->index('end')); } } } # called when the user presses in the entry widget sub entry_escape { my $self = shift; my $entry = $self->Subwidget('entry'); # Close listbox if popped up if ($self->{'popped'}) { $self->hide_listbox; $entry->selectionRange($entry->index('insert'), $entry->index('end')); # assume that another follows $self->{Configure}{double_escape_possible} = 1; } else { # undo auto-completion otherwise if ($entry->selectionPresent()) { $entry->delete($entry->index("sel.first"), $entry->index("sel.last")); } elsif ($self->{Configure}{double_escape_possible}) { # no text selected -> cut from current insert position to end $entry->delete($entry->index("insert"), $entry->index("end")); # turn off double- assumption $self->{Configure}{double_escape_possible} = 0; } } } # Called whenever the user presses any key within the entry widget sub entry_anykey { my ($self, $key, $state) = @_; my $entry = $self->Subwidget('entry'); # turn off double-escape mode for turning off auto-completion $self->{Configure}{double_escape_possible} = 0; # Check entry length, call appropriate callbacks my $entry_length = length $entry->get; if ($entry_length == 0) { $self->Callback(-zerocmd => $self); } elsif ($entry_length == 1) { $self->Callback(-onecmd => $self); } if ($self->cget(-multimatch)) { if ($key =~ m/^Left|^Right|^Home|^End/) { $self->hide_listbox; } } # print ">>>$key<<<\n"; my $trigger = $self->cget(-sorttrigger); if (defined $trigger) { $self->resort if ($key =~ m/$trigger/); } $self->{Configure}{was_real_input} = 0; return if ($key =~ m/^Shift|^Control|^Left|^Right|^Home|^End/); return if ($state =~ m/^Control-/); $self->{Configure}{was_real_input} = 1; # check whether we are in multimatch mode if ($self->cget(-multimatch)) { return $self->entry_anykey_multimatch($key, $state, $entry); } # automatically pop the listbox up if requested by programmer # and the user has already entered at least 1 character if ($self->cget(-autopopup) && length $entry->get) { if ($self->{popped}) { # already popped up, just filter entries my $last_num = $self->{Configure}{last_number_of_entries}; my $num_entries = $self->listbox_filter; $num_entries = 0 unless (defined $num_entries); # number of choices has changed, redraw the listbox unless ($last_num == $num_entries) { $self->hide_listbox; $self->show_listbox; } } else { # pop the listbox up, automatically calls the filter $self->show_listbox; } } else { # check length of input, close listbox if too short unless (length $entry->get) { $self->hide_listbox; } } # Skip the rest if user pressed Backspace or Delete return if ($key eq "BackSpace" or $key eq "Delete"); $self->entry_autocomplete; } # Handle any keypress in multimatch mode sub entry_anykey_multimatch { my ($self, $key, $state, $entry) = @_; # automatically pop the listbox up if requested by programmer # and the user has already entered at least 1 character in the # current word my $text = $entry->get; my $cursor = $entry->index('insert'); (my $typed_text = $text) =~ s/^(.{$cursor})(.*)/$1/; my $text_after_cursor = $2; (my $current_word = $typed_text) =~ s/.*\s(.*)/$1/; my $word_length = length $current_word; if ($word_length == 0) { $self->Callback(-mm_zerocmd => $self); } elsif ($word_length == 1) { $self->Callback(-mm_onecmd => $self); } # print "current word: $current_word\n"; if ($self->cget(-autopopup) && length $current_word) { if ($self->{popped}) { # already popped up, just filter entries my $last_num = $self->{Configure}{last_number_of_entries}; my $num_entries = $self->listbox_filter($current_word); $num_entries = 0 unless (defined $num_entries); # number of choices has changed, redraw the listbox unless ($last_num == $num_entries) { $self->hide_listbox; $self->show_listbox($current_word); } } else { # pop the listbox up, automatically calls the filter $self->show_listbox($current_word); } } else { # check length of input, close listbox if too short unless (length $current_word) { $self->hide_listbox; } } # Skip the rest if user pressed Backspace or Delete return if ($key eq "BackSpace" or $key eq "Delete"); $self->entry_autocomplete_multimatch; } # attempt to auto-complete the entry sub entry_autocomplete { my $self = shift; my $entry = $self->Subwidget('entry'); # check whether we are in multimatch mode if ($self->cget(-multimatch)) { return $self->entry_autocomplete_multimatch; } if ($self->cget(-complete)) { # do we want auto-completion at all? my $text = $entry->get; my $cursor = $entry->index('insert'); (my $typed_text = $text) =~ s/^(.{$cursor})(.*)/$1/; my $text_after_cursor = $2; # check whether any text after insert cursor is from auto-completion my $non_auto_text; $non_auto_text = 1 if ($text_after_cursor ne ""); if ($non_auto_text && $entry->selectionPresent) { $non_auto_text = 0 if (($entry->index('end') == $entry->index('sel.last')) && ($entry->index('insert') == $entry->index('sel.first'))); } # skip if position = 0 or there's text after the insert cursor unless($cursor == 0 || $text eq "" || $non_auto_text) { # search for the first matching entry my $ignore_case = ($self->cget(-case) ? "(?i)" : ""); my $all_choices_r = $self->{Configure}{all_choices_r}; my @all_choices = @$all_choices_r; my $prefix = $self->cget(-matchprefix) || ""; my $index = 0; foreach my $choice (@all_choices) { # @all_choices is sorted if ($choice =~ m/^${ignore_case}$prefix\Q$typed_text\E(.*)/) { my $choice_tail = $1; # auto-completed part of entry #print "..$choice_tail..\n"; $entry->selection('clear'); $entry->delete($cursor, 'end'); $entry->insert($cursor, $choice_tail); $entry->selection('range', $cursor, 'end'); $entry->icursor($cursor); last; # break out of foreach $choice } } } } } # attempt to auto-complete the current word in multimatch mode sub entry_autocomplete_multimatch { my $self = shift; my $entry = $self->Subwidget('entry'); if ($self->cget(-complete)) { # do we want auto-completion at all? my $text = $entry->get; my $cursor = $entry->index('insert'); (my $typed_text = $text) =~ s/^(.{$cursor})(.*)/$1/; my $text_after_cursor = $2; my $rest_of_line = ''; # check whether the user is editing a word which is not the # last on the line if ($text_after_cursor =~ m/\s/) { ($rest_of_line = $text_after_cursor) =~ s/(.*?)\s(.*)/$2/; $text_after_cursor = $1; } # extract last word on line if ($typed_text =~ m/\s/) { $typed_text =~ s/.*\s(.*)/$1/; } # check whether any text after insert cursor is from auto-completion my $non_auto_text; $non_auto_text = 1 if ($text_after_cursor ne ""); if ($non_auto_text && $entry->selectionPresent) { $non_auto_text = 0 if (($entry->index('end') == $entry->index('sel.last')) && ($entry->index('insert') == $entry->index('sel.first'))); } # skip if position = 0 or there's text after the insert cursor unless($typed_text eq "" || $non_auto_text) { # search for the first matching entry my $ignore_case = ($self->cget(-case) ? "(?i)" : ""); my $all_choices_r = $self->{Configure}{all_choices_r}; my @all_choices = @$all_choices_r; my $prefix = $self->cget(-matchprefix) || ""; my $index = 0; foreach my $choice (@all_choices) { # @all_choices is sorted if ($choice =~ m/^${ignore_case}$prefix\Q$typed_text\E(.*)/) { my $choice_tail = $1; # auto-completed part of entry $entry->selection('clear'); $entry->delete($cursor, 'end'); $entry->insert($cursor, $choice_tail); $entry->selection('range', $cursor, 'end'); if (length $rest_of_line) { $entry->insert('end', " " . $rest_of_line); } $entry->icursor($cursor); last; # break out of foreach $choice } } } } } # called when the key is pressed within the entry sub entry_cursor_down { my $self = shift; my $listbox = $self->Subwidget('slistbox')->Subwidget('listbox'); my $entry = $self->Subwidget('entry'); $self->{Configure}{was_real_input} = 0; # print "entry_cursor_down\n"; my $index; # unless it's already there, open the listbox and focus first entry unless($self->{popped}) { if ($self->cget(-multimatch)) { my $text = $entry->get; my $cursor = $entry->index('insert'); (my $typed_text = $text) =~ s/^(.{$cursor})(.*)/$1/; (my $current_word = $typed_text) =~ s/.*\s(.*)/$1/; $self->open_listbox($current_word); } else { $self->open_listbox; } $listbox->selection('clear', 0, 'end'); $listbox->selectionSet(0); $listbox->activate(0); $index = 0; } else { # otherwise move selection one down, unless already at bottom # print "one down\n"; if ($self->cget(-multimatch)) { my $text = $entry->get; my $cursor = $entry->index('insert'); (my $typed_text = $text) =~ s/^(.{$cursor})(.*)/$1/; (my $current_word = $typed_text) =~ s/.*\s(.*)/$1/; $self->listbox_filter($current_word); } else { $self->listbox_filter; } $index = $self->listbox_index; if ($index < $self->{Configure}{last_number_of_entries} - 1) { $index++; # check whether no element was selected before $index = 0 if ($index == 1 && !$listbox->selectionIncludes(0)); $listbox->selection('clear', 0, 'end'); $listbox->selectionSet($index); $listbox->activate($index); } else { $self->Callback(-bottomcmd => $self); if ($self->cget(-wraparound)) { $index = 0; $listbox->selection('clear', 0, 'end'); $listbox->selectionSet($index); $listbox->activate($index); } } } $listbox->see($index); $self->listbox_copy_to_entry; $self->entry_select_from_cursor_to_end; } sub entry_cursor_up { my $self = shift; my $listbox = $self->Subwidget('slistbox')->Subwidget('listbox'); my $entry = $self->Subwidget('entry'); my $index; $self->{Configure}{was_real_input} = 0; # unless it's already there, open the listbox and focus first entry unless($self->{popped}) { if ($self->cget(-multimatch)) { my $text = $entry->get; my $cursor = $entry->index('insert'); (my $typed_text = $text) =~ s/^(.{$cursor})(.*)/$1/; (my $current_word = $typed_text) =~ s/.*\s(.*)/$1/; $self->open_listbox($current_word); } else { $self->open_listbox; } $listbox->selection('clear', 0, 'end'); $listbox->selectionSet(0); $listbox->activate(0); $index = 0; } else { # otherwise move selection one up, unless already at top if ($self->cget(-multimatch)) { my $text = $entry->get; my $cursor = $entry->index('insert'); (my $typed_text = $text) =~ s/^(.{$cursor})(.*)/$1/; (my $current_word = $typed_text) =~ s/.*\s(.*)/$1/; $self->listbox_filter($current_word); } else { $self->listbox_filter; } $index = $self->listbox_index; if ($index > 0) { $index--; } else { $self->Callback(-topcmd => $self); if ($self->cget(-wraparound)) { $index = $self->{Configure}{last_number_of_entries} - 1; $listbox->selection('clear', 0, 'end'); $listbox->selectionSet($index); $listbox->activate($index); } } $listbox->selection('clear', 0, 'end'); $listbox->selectionSet($index); $listbox->activate($index); } $listbox->see($index); $self->listbox_copy_to_entry; $self->entry_select_from_cursor_to_end; } # Select text in the entry widget, from current cursor position to end sub entry_select_from_cursor_to_end { my $self = shift; my $entry = $self->Subwidget('entry'); # set insertion cursor to begin of line if the last listbox # filtering process was successful only because of -matchprefix # (beginning of current word in multi-match mode) if ($self->{Configure}{last_filter_matched_by_prefix_only}) { if ($self->cget(-multimatch)) { my $pos = $entry->index('insert'); (my $text = $entry->get) =~ s/^(.{$pos})/$1/; $text =~ s/(.*)\s.*/$1/; # print $text."\n"; # print "..." . length $text , "\n(of $pos)\n"; if (length $text > $pos) { if ($text =~ m/(.{$pos})/) { my $t = $1; $t =~ s/(.*)\s.*/$1/; # print "...$t\n"; $entry->icursor(1 + length $t); } else { $entry->icursor($pos); } } else { $entry->icursor(1 + length $text); } } else { $entry->icursor(0); } } if ($self->cget(-multimatch)) { my $pos = $entry->index('insert'); (my $text = $entry->get) =~ s/^.{$pos}(.*)/$1/; if ($text =~ m/\s/g) { $pos += pos($text) - 1; # print "spacematch: $text\n"; } else { $pos = $entry->index('end'); } # print "pps: $pos\n"; $entry->selectionRange($entry->index('insert'), $pos); } else { $entry->selectionRange($entry->index('insert'), $entry->index('end')); } } # called when mouse button 1 is released within the listbox sub release_listbox { my ($self, $x, $y) = @_; $self->choose_listbox($x, $y); } # allows the programmer to popup the listbox if auto-popup is disabled sub popup { my $self = shift; my $current_word = shift; # optional, introduced with multi-matching $self->open_listbox($current_word); } # hide/unhide the popup listbox sub open_listbox { my $self = shift; my $current_word = shift; # optional, introduced with multi-matching # check whether we are in state "disabled" return if ($self->cget('-state') eq 'disabled'); if ($self->{'popped'}) { $self->close_listbox; } else { $self->show_listbox($current_word); } } # Remove all entries from the choices listbox which can't match the user's # input anymore. sub listbox_filter { my $self = shift; my $text_to_match = shift; # optional, introduced with multimatching my $listbox = $self->Subwidget('slistbox')->Subwidget('listbox'); my $entry = $self->Subwidget('entry'); $entry->update; my $cursor_pos = $entry->index('insert'); my $old_index = $self->listbox_index; my ($old_value, $new_index); if (defined $old_index) { $old_value = $listbox->get($old_index); } $listbox->delete(0, 'end'); my $ignore_case = ($self->cget(-case) ? "(?i)" : ""); my $all_choices_r = $self->{Configure}{all_choices_r}; my @all_choices = @$all_choices_r; my $text = $entry->get; (my $typed_text = $text) =~ s/^(.{$cursor_pos})(.*)/$1/; my $rest_of_line = $2; my $prefix = $self->cget(-matchprefix) || ""; my $force_match = ''; if (length $self->{Configure}{last_user_input}) { $force_match = $self->{Configure}{last_user_input}; } unless (defined $text_to_match) { if ($rest_of_line ne "") { # text after cursor # only use matching if whole text matches one of the choices my $text_is_choice = 0; foreach my $choice (@all_choices) { if ($text =~ m/^${ignore_case}\Q$choice\E$/) { $text_is_choice++; } } # give it a try for sure if we have a match-prefix $self->{Configure}{last_filter_matched_by_prefix_only} = 0; if ($text_is_choice == 0) { if (length $prefix) { $self->{Configure}{last_filter_matched_by_prefix_only} = 1; $text_is_choice++; } } return unless ($text_is_choice); } } else { # multimatch mode or $text_to_match otherwise specified # print "text to match: $text_to_match\n"; $typed_text = $text_to_match; if (length $typed_text) { # check whether the text typed by the user can match # any of the choices, # a) as it is # b) at least with the match-prefix my $text_is_choice = 0; foreach my $choice (@all_choices) { if ($choice =~ m/^${ignore_case}\Q$typed_text\E/) { $text_is_choice++; } } # give it a try for sure if we have a match-prefix $self->{Configure}{last_filter_matched_by_prefix_only} = 0; if ($text_is_choice == 0) { if (length $prefix) { $self->{Configure}{last_filter_matched_by_prefix_only} = 1; $text_is_choice++; } } } } if ($self->{Configure}{last_filter_matched_by_prefix_only}) { $self->{Configure}{last_user_input} = $typed_text; } else { $self->{Configure}{last_user_input} = ''; } # print "real input: . " . $self->{Configure}{was_real_input} . "\n"; if (length $force_match) { $typed_text = $force_match unless($self->{Configure}{was_real_input}); $self->{Configure}{last_user_input} = $typed_text unless($self->{Configure}{was_real_input}); } my $index = 0; foreach my $choice (@all_choices) { # @all_choices is sorted if ($choice =~ m/^${ignore_case}$prefix\Q$typed_text\E/) { $listbox->insert('end', $choice); if (defined $old_value && ($old_value eq $choice)) { $new_index = $index; } $index++; } } if (defined $new_index) { # $listbox->see($new_index); $listbox->selectionSet($new_index); $listbox->activate($new_index); } $self->{Configure}{last_number_of_entries} = $index; return $index; # equals number of visible elements } # Display the listbox sub show_listbox { my $self = shift; my $current_word = shift; # optional # Don't do that stuff if we're already popped up unless ($self->{'popped'}) { # Allow the programmer to change his choices $self->Callback(-listcmd => $self); # Display only listbox entries which could match my $number_of_visible_elements = $self->listbox_filter($current_word); # abort if listbox would be empty or contain less entries # than required for auto-completion (usually 1) return unless (defined $number_of_visible_elements && ($number_of_visible_elements > $self->cget(-complete))); # Fetch our subwidgets my $entry = $self->Subwidget('entry'); my $choices = $self->Subwidget('choices'); my $scrolled_listbox = $self->Subwidget('slistbox'); # Calculate height and width for the popup listbox my $y1 = $entry->rooty + $entry->height + 3; my $bd = $choices->cget(-bd) + $choices->cget(-highlightthickness); #my $ht = ($scrolled_listbox->reqheight / 2) + 2 * $bd + 2; # Calculate height for listbox. Default reqheight = 10 elements. my $maxheight = $self->cget(-maxheight); my $elements_per_page = $number_of_visible_elements < $maxheight ? $number_of_visible_elements : $maxheight; my $ht = (($scrolled_listbox->reqheight * $elements_per_page) / 10) + 2 * $bd + 2; my $x1 = $entry->rootx + $bd + 3; # Check whether the scrollbar should be hidden if ($number_of_visible_elements <= $maxheight) { # hide it $scrolled_listbox->configure(-scrollbars => ''); } else { # show the scrollbar $scrolled_listbox->configure(-scrollbars => 'oe'); } my ($width, $x2); # Check whether programmer has specified a width $width = $self->cget(-listwidth); if (defined $width) { $x2 = $x1 + $width; } # else take the entry widget's width else { $x2 = $entry->rootx + $entry->width; $width = $x2 - $x1; } # check requested and maximum width unless programmer forbid my $rw = $choices->reqwidth; unless ($self->cget(-fixedwidth)) { if ($rw < $width) { $rw = $width; } else { if ($rw > $width * 3) { $rw = $width * 3; } if ($rw > $self->vrootwidth) { $rw = $self->vrootwidth; } } $width = $rw; } else { # force fixed width $rw = $width; } # check whether listbox is too far right if ($x2 > $self->vrootwidth) { $x1 = $self->vrootwidth - $width; } # check whetherlistbox is too far left if ($x1 < 0) { $x1 = 0; } # check whether listbox is below bottom of screen my $y2 = $y1 + $ht; if ($y2 > $self->vrootheight) { $y1 = $y1 - $ht - ($entry->height - 5); } # Set the listbox's geometry and show it $choices->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1)); $choices->deiconify; $choices->raise; $entry->focus; $self->{'popped'} = 1; $choices->configure(-cursor => 'arrow'); $self->grabGlobal; } } # close the popup listbox sub close_listbox { my ($self) = @_; # clearing the selection is Tk::BrowseEntry's behavior when pressing # . However, it seems to be more useful here to leave the # selection as it is. #my $listbox = $self->Subwidget('slistbox')->Subwidget('listbox'); #$listbox->selection('clear', 0, 'end'); $self->hide_listbox; } # called to select a listbox entry sub choose_listbox { my ($self, $x, $y) = @_; return unless($self->{'popped'}); my $listbox = $self->Subwidget('slistbox')->Subwidget('listbox'); # check whether the user clicked outside if ( ($x < 0) || ($y < 0) || ($x > $listbox->Width) || ($y > $listbox->Height) ) { $self->close_listbox; } else { # some entry was clicked on $self->copy_selection_listbox; $self->Callback(-browsecmd => $self, $self->Subwidget('entry')->get); } } # Copy the selection to the entry widget and close the listbox sub copy_selection_listbox { my ($self) = @_; $self->listbox_copy_to_entry; $self->hide_listbox; } # Copy the currently selected listbox item to the entry widget sub listbox_copy_to_entry { my ($self) = @_; return unless ($self->{'popped'}); my $index = $self->listbox_index; if (defined $index) { $self->{'curIndex'} = $index; my $listbox = $self->Subwidget('slistbox')->Subwidget('listbox'); my $var_ref = $self->cget('-textvariable'); if ($self->cget(-multimatch)) { my $entry = $self->Subwidget('entry'); my $pos = $entry->index('insert'); my $text = $entry->get; if ($text =~ m/^(.{$pos})(.*)/) { my $text_before = $1; my $text_behind = $2; if ($text_before =~ m/\s/) { $text_before =~ s/(.*)\s.*/$1/; } else { $text_before = ""; } if ($text_behind =~ m/\s/) { $text_behind =~ s/.*?\s(.*)/$1/; } else { $text_behind = ""; } my $newvalue; $newvalue .= $text_before . " " if (length $text_before); $newvalue .= $listbox->get($index); $newvalue .= " " . $text_behind if (length $text_behind); $$var_ref = $newvalue; $entry->icursor($pos); # ? } } else { $$var_ref = $listbox->get($index); } } } # Return the index of the currently selected listbox item sub listbox_index { my ($self, $flag) = @_; my @sel = $self->Subwidget('slistbox')->Subwidget('listbox')->curselection; my $sel; if (defined($sel[0])) { $sel = $sel[0]; } else { # undef $sel; } if (defined $sel) { return int($sel); } else { if (defined $flag && ($flag eq 'emptyOK')) { return undef; } else { return 0; } } } # hide the popup listbox sub hide_listbox { my ($self) = @_; if ($self->{'savefocus'} && Tk::Exists($self->{'savefocus'})) { $self->{'savefocus'}->focus; delete $self->{'savefocus'}; } if ($self->{'popped'}) { my $choices = $self->Subwidget('choices'); $choices->withdraw; $self->grabRelease; $self->{'popped'} = 0; } } # User pressed in the listbox sub return_listbox { my ($self, $listbox) = @_; my @sel = $self->Subwidget('slistbox')->Subwidget('listbox')->curselection; my $sel; $sel = $sel[0] if (defined($sel[0])); return unless (defined($sel)); my ($x, $y) = $listbox->bbox($sel); $self->choose_listbox($x, $y); # place insert cursor at end of entry widget $self->Subwidget('entry')->icursor('end'); } # User pressed in the listbox sub listbox_tab { my ($self, $listbox) = @_; $self->return_listbox($listbox); } # Lets the programmer get/set the choices array sub choices { my ($self, $choices) = @_; if (@_ > 1) { # set them # remember all the possible choices given by the programmer if ($self->cget(-autosort)) { my @c = @$choices; my @all_choices = $self->Callback(-sortcmd => \@c) || sort @c; $self->{Configure}{all_choices_r} = \@all_choices; } else { my @unsorted_choices = @$choices; $self->{Configure}{all_choices_r} = \@unsorted_choices; } } else { # get them return ($self->get(qw/0 end/)); } } sub resort { my $self = shift; my $all_choices_r = $self->{Configure}{all_choices_r}; my @choices = @$all_choices_r; my $nocallback = 0; $self->{Configure}{all_choices_r} = $self->Callback(-sortcmd => \@choices) or $nocallback = 1; if ($nocallback) { my @sorted_choices = sort @choices; $self->{Configure}{all_choices_r} = \@sorted_choices; } } # Lets the programmer get/set the widget's state sub state { my $self = shift; unless (@_) { return ($self->{Configure}{-state}); } else { my $state = shift; $self->{Configure}{-state} = $state; $self->_set_edit_state($state); } } # Set the edit state internally sub _set_edit_state { my ($self, $state) = @_; my $entry = $self->Subwidget('entry'); if ($self->cget('-colorstate')) { my $color; if ($state eq 'normal') { # editable $color = 'gray95'; } else { # not editable $color = $self->cget(-background) || 'lightgray'; } $entry->Subwidget('entry')->configure(-background => $color); } if ($state eq 'readonly') { $entry->configure(-state => 'disabled'); } else { $entry->configure(-state => $state); } } # return success 1; __END__ =pod =head1 NAME Tk::MatchEntry - Entry widget with advanced auto-completion capability =head1 SYNOPSIS use Tk::MatchEntry; $match_entry = $top->MatchEntry(-textvariable => \$var1, -choices => @choices); =head1 DESCRIPTION C is an Entry widget with focus on user-friendly auto-completion. Its usage is similar to C and C. With each character the user types in the widget, automatic completion can be attempted based on a list of B you as programmer specify. If there's more than one of the B matching the text which the user has entered so far, she can optionally select the desired auto-completion choice from an up-popping listbox, either by using the mouse or by browsing them with the B and B cursor keys. This listbox with auto-completion choices pops up automatically by default and only shows these B which still can match the manually entered text, i.e. the number of displayed items usually decreases with the length of text entered by the user. The auto-completed part of the text in the Entry widget always gets selected so the next manually entered character overwrites it. Thus, the auto-completion feature never prevents the user from typing what she really wants to. Starting with version 0.2, C has a multi-match mode in which each word the user types can be auto-completed. For example, if you've got the four B I, I, I and I, the user can write I for example by hitting J, Return, A, Return, P, Return, H, Return. =head1 OPTIONS Besides the options which can be applied to the C and C subwidgets, C provides the following specific options: =over 4 =item B<-textvariable> or B<-variable> The variable which is tied to the MatchEntry widget. B<-variable>, as used in BrowseEntry, is just an alias for B<-textvariable>. This variable will contain the entry widget's text. =item B<-choices> Array of strings which the auto-completion feature attempts to match. Used the same way as in C. =item B<-complete> If set to a true value, auto-completion is attempted whenever the user enters another character in the widget. This is what C is all about, so it defaults to 1. Auto-completion is hopefully smart enough to know what the user wants to do and doesn't mess up the text she's entering. =item B<-ignorecase> If not false, auto-completion works case-insensitive. Thus, if you have a choice C and the user starts with a C, auto-completion will be C. However, if auto-completion is set to case-insensitivity AND the text in the entry widget matches one of the B when the MatchEntry widget is left, the text will be replaced by the B, i.e. in our example, C would turn into C. Defaults to 0. =item B<-autopopup> If set to a true value, the listbox with auto-completion choices will automatically pop up if the user has entered at least one character in the widget yet AND there's at least two possible choices. Defaults to 1. =item B<-maxheight> Sets the maximum number of entries per page in the (scrolled) popup listbox with auto-completion choices. Defaults to 5. =item B<-autoshrink> If set to a true value, the popup listbox's height will decrease if there's less than B<-maxheight> items to display. For example, if B<-maxheight> is set to 5, but there's only 3 choices, and B<-autoshrink> is set to 1, then the listbox will show only those 3 choices instead of the 3 choices plus two empty rows. =item B<-fixedwidth> If set to a true value, the popup listbox will always have the same width as the entry widget. Otherwise, the width of the listbox is calculated the same way as in C. Defaults to 1. =item B<-listwidth> If B<-fixedwidth> is set to 0, B<-listwidth> can be used to specify the popup listbox's width. =item B<-multimatch> When set to a true value, the multi-match mode is activated. In regular mode, C attempts to match and auto-complete the whole text in the entry widget. In multi-match mode, it does the same for each word the user enters. Don't use this unless you're sure that's what you want. When using multi-match mode, the B should be single words (as opposed to phrases, i.e. multiple blank-separated words). Defaults to 0. =item B<-autosort> When set to a true value, the B are automatically sorted, either when set through -choices in the B method or through the B method. Sorting is done with Perl's built-in B function unless you've specified a B<-sortcmd> callback. Defaults to 1. =item B<-sorttrigger> Useful in multi-match mode when using a custom B<-sortcmd> callback which sorts the B based on what the user has entered so far. B<-sorttrigger> is a regular expression; if it matches against the user's latest pressed key, then the B method is called. The B<-sortcmd> callback can then be used to add words entered by the user to the list of choices, sort them by usage frequency, etc. The value of this option defaults to B and you should only change it if you know what you're doing: both matching this regular expression against each key pressed by the user and unnecessarily often calling B can decrease performance. Example usage: ... -sorttrigger => '^Left|^Right|^space|^Home|^End', ... (The lower case s in I<^space> is actually not a typo) =item B<-matchprefix> Using a match prefix allows lazy typing on your user's side. It's best explained by comparing it to the field where you enter a URL in modern web browsers. Let's say you have a choice http://www.cpan.org and you would like to allow the user typing either of these: http://www.cpan.org www.cpan.org cpan.org while still getting the benefits of auto-completion and the up-popping choices listbox, then you should set B<-matchprefix> to '(?:http:\/\/)?(?:www\.)?' In fact, B<-matchprefix> is a regular expression which B fulfill the following criteria: 1) You B use non-capturing brackets if you're using grouping. That's why we use (?:http:\/\/)? in the above example and B (http:\/\/)? 2) Prefix matches B be optional, i.e. you always should use the ? quantifier (using * would work, too, but might be bad for performance). Here's another example for matching HTTP and FTP URLs like in the above example, i.e. both the I and I parts are optional. ... -matchprefix => '(?:(?:ftp|http):\/\/)?(?:(?:ftp|www)\.)?', ... =item B<-wraparound> If set to a true value, then the selection in the popup listbox will wrap around to the first entry if the user presses the down cursor key at the very bottom of the listbox. Also, the last entry in the listbox will be selected after pressing cursor-up while having the first listbox entry selected. Defaults to 0. =back The following options specify callbacks: =over 4 =item B<-listcmd> Executed when the listbox is about to be popped up. This is a good place for changes to the B<-choices>. =item B<-entercmd> Executed when the user hits the B key. =item B<-tabcmd> Executed when the user hits the B key. =item B<-zerocmd> Executed when the insert cursor moves back to position 0 in the entry widget (see B<-onecmd>). =item B<-onecmd> Executed when the insert cursor moves to position 1 in the entry widget (i.e. after the first character). B<-zerocmd> and B<-onecmd> are supposed to be used together in applications where you want totally different B depending on whether the user has already entered any text yet. For example, if a MatchEntry widget is used for the recipient's name in an email client, the choices a) when the user has not entered anything yet could be the names of the 10 last persons he had sent an email to. b) after entering the first character could be appropriate names from his address book. =item B<-command> or B<-browsecmd> Executed when the user has selected an entry from the auto-completion popup-listbox. Provided for compatibility with C. =item B<-mm_zerocmd> and B<-mm_onecmd> Same as B<-zerocmd> and B<-onecmd>, additionally called in B mode if the current word's length is 0, or 1 respectively. =item B<-sortcmd> Callback used to sort the array of B. If you don't specify this callback, Perl's internal B function will be used to sort the B alphabetically unless B is turned off. A reference to the array of choices is passed to the custom sorting function and it must return a reference to the sorted array. Trivial example: sub mysort { my $ref = shift; my @choices = @$ref; my @sorted_choices = sort @choices; return \@sorted_choices; } You can abuse this callback to insert or delete choices while sorting them. Normally, the standard B method is used to update the choices array, of course. =item B<-bottomcmd> Called when the user presses the cursor-down key if the bottom entry in the popup listbox was already selected. Can be used for accoustic signals etc. Called even if B<-wraparound> is true. =item B<-topcmd> Same as B<-bottomcmd> but called when the user presses the cursor-up key if already at the first entry of the popup listbox. =back =head1 METHODS =over 4 =item B Pops the auto-completion listbox up if there are enough possible choices. This should only be used if B<-autopopup> is set to 0. As C does, compared to C and C, I provide an arrow button for popping up the listbox, you might want to use a button of your own for this purpose. If the listbox is already open, calling this method closes it. =item B If called with no parameter, this returns an array containing the current B. If given an array as parameter, it will set the B. Unless B is turned off, the choices will be sorted automatically, either using Perl's built-in B function or the B<-sortcmd> callback you've specified. =item B Enforces re-sorting the array of choices, either using Perl's built-in B function or the B<-sortcmd> callback if you've specified one. Useful if B is turned off or your custom B<-sortcmd> wants to take into account what the user has entered so far, for instance to sort the choices by their usage frequency in multi-match mode. =back =head1 KEY BINDINGS =over 4 =item B, B Navigates through the auto-completion listbox. Forces the listbox to pop up when used at entry widget cursor position 0 if there are any choices to display. =item B, B Accepts the currently suggested or selected auto-completion. The insert cursor will be placed at the end of the entry widget. The callback B<-tabcmd> or B<-entercmd> will be executed. =item B Pressed once it closes the auto-completion listbox if it's open. On pressing it twice the currently auto-completed text will be erased. For example, if you have a choice C, but the user just wants to enter C, she actually has to press B (or B) to remove the auto-completed C< Doe> part. =back =head1 NOTES If you need to configure the subwidgets, for example to set different background colors for the entry and the listbox widget, you can access them like this: my $entry_subwidget = $matchentry->Subwidget('entry'); my $listbox_subwidget = $matchentry->Subwidget('slistbox')->Subwidget('listbox'); C is the C listbox. =head1 BUGS =over 4 =item Execution of the -browsecmd callback needs improvement. =back =head1 EXAMPLES This is a primitive example for Tk::MatchEntry which you can use to get to know the look and feel. use Tk; use Tk::MatchEntry; my $mw = MainWindow->new(-title => "MatchEntry Test"); my @choices = [ qw/one one.green one.blue one.yellow two.blue two.green two.cyan three.red three.white three.yellow/ ]; $mw->Button->pack(-side => 'left'); my $me = $mw->MatchEntry( -choices => @choices, -fixedwidth => 1, -ignorecase => 1, -maxheight => 5, -entercmd => sub { print "callback: -entercmd\n"; }, -onecmd => sub { print "callback: -onecmd \n"; }, -tabcmd => sub { print "callback: -tabcmd \n"; }, -zerocmd => sub { print "callback: -zerocmd \n"; }, )->pack(-side => 'left', -padx => 50); $mw->Button(-text => 'popup', -command => sub{$me->popup} )->pack(-side => 'left'); MainLoop; =head1 AUTHOR Wolfgang Hommel =head1 SEE ALSO The following widgets are similar to I to a certain extent: =over 4 =item I =item I =item I =item I =back =head1 CREDITS Thanks to =over 4 =item Slaven Rezic for I. Some of the auto-completion ideas are based on it. =item Jesse Farinacci for suggesting, specifying and testing the multimatch mode. =item Ingo Herschmann for bug reports and patches. =back =head1 COPYRIGHT Copyright (c) 2003 - 2005 Wolfgang Hommel. All rights reserved. This package is free software; you can redistribute it and/or modifiy it under the same terms as Perl itself. =cut # # CVS Changelog: # $Log: MatchEntry.pm,v $ # Revision 1.12 2005/06/30 05:29:28 admin # Applied a patch by Ingo Herschmann # # Revision 1.11 2005/03/14 21:20:17 admin # Minor metadata updates # # Revision 1.10 2005/03/14 21:17:36 admin # fixed to work with more recent perl/tk # # Revision 1.9 2003/04/08 07:57:13 admin # added -wraparound and -bottomcmd/-topcmd callbacks # # Revision 1.8 2003/04/08 07:35:46 admin # Added -matchprefix option and behavior # # Revision 1.7 2003/04/06 20:08:16 admin # Added -sorttrigger, updated POD # # Revision 1.6 2003/04/06 12:20:11 admin # Added multimatch mode, -sortcmd callback # # Revision 1.5 2003/01/30 15:08:01 admin # Added POD, added bind # # Revision 1.4 2003/01/29 16:56:20 admin # Improved support for case-insensitive matching, added 0/1-length callbacks # # Revision 1.3 2003/01/28 01:17:49 admin # added auto-completion and auto-popup functionality, # added callbacks for enter and tab, # basic keyboard event bindings done # # Revision 1.2 2003/01/25 20:00:21 admin # basic entry + listbox functionality added, based on Tk::BrowseEntry source # # Revision 1.1 2003/01/25 10:42:19 admin # initial commit