CompleteEntry.pm 52.6 KB
Newer Older
1
2
3
4
#-----------------------------------------------------------------------
# Fault InJection Instrumenter (FIJI)
# https://embsys.technikum-wien.at/projects/vecs/fiji
#
5
6
7
8
# The creation of this file has been supported by the publicly funded
# R&D project Josef Ressel Center for Verification of Embedded Computing
# Systems (VECS) managed by the Christian Doppler Gesellschaft (CDG).
#
9
10
11
# Authors:
# Christian Fibich <fibich@technikum-wien.at>
# Stefan Tauner <tauner@technikum-wien.at>
12
13
14
15
16
17
18
19
20
21
#
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# See the LICENSE file for more details.
#-----------------------------------------------------------------------
22
23
#
# Based on MatchEntry.pm which is Copyright (c) 2003 - 2005 Wolfgang Hommel
24
# Bugs introduced in changes between MatchEntry and CompleteEntry by Stefan Tauner
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
#

# Set package name
package Tk::CompleteEntry;

# Set version information
use vars qw($VERSION);
$VERSION = '0.0';

# Define dependencies
use strict;
use warnings;

use Tk qw(Ev);
use Carp;
require Tk::Frame;
require Tk::Entry;

# Construct widget
use base qw(Tk::Frame);
Construct Tk::Widget 'CompleteEntry';

# Compositing the widget
sub Populate {
Christian Fibich's avatar
Christian Fibich committed
49
    my ($self, $args) = @_;
50

51
    $self->SUPER::Populate($args);    # let ancestors populate first
52
53
54

    # Create the entry subwidget
    my $content;
Christian Fibich's avatar
Christian Fibich committed
55
56
    my $entry = $self->Entry(-textvariable => \$content,);
    $self->Advertise('entry' => $entry);    # make it available to outside
57
58
59
60
    $entry->pack(
        -side   => 'right',
        -fill   => 'x',
        -expand => 1
Christian Fibich's avatar
Christian Fibich committed
61
    );                                      # place the entry widget in our frame
62
63

    # Create the popup-listbox
Christian Fibich's avatar
Christian Fibich committed
64
65
66
67
68
69
70
71
72
    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
73

74
    # Other initializations
Christian Fibich's avatar
Christian Fibich committed
75
76
    $self->set_bindings;                                       # Set up keyboard and mouse bindings
    $self->{'popped'} = 0;                                     # Start with hidden listbox
77
78
79
80
81
82
83
    $self->Delegates(
        'insert' => $scrolled_listbox,
        'delete' => $scrolled_listbox,
        'get'    => $scrolled_listbox,
        DEFAULT  => $entry
    );

84
    $self->ConfigSpecs(
Christian Fibich's avatar
Christian Fibich committed
85
86
87
88
89
90
91
92
93
94
95
        -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],
96
97
98
99
100

        -command    => '-browsecmd',
        -ignorecase => '-case',
        -options    => '-choices',

101
102
        # -variable    => '-textvariable',

Christian Fibich's avatar
Christian Fibich committed
103
        -choices => [qw/METHOD   choices     Choices/, undef],
104
105
        -state   => [qw/METHOD   state       State        normal/],

106
107
108
109
        -autopopup   => [qw/PASSIVE  autoPopup   AutoPopup    1/],
        -autoshrink  => [qw/PASSIVE  autoShrink  AutoShrink   1/],
        -autosort    => [qw/PASSIVE  autoSort    AutoSort     1/],
        -case        => [qw/PASSIVE  case        Case         0/],
Christian Fibich's avatar
Christian Fibich committed
110
        -colorstate  => [qw/PASSIVE  colorState  ColorState/, undef],
111
112
        -complete    => [qw/PASSIVE  complete    Complete     1/],
        -fixedwidth  => [qw/PASSIVE  fixedWidth  FixedWidth   1/],
Christian Fibich's avatar
Christian Fibich committed
113
114
        -listwidth   => [qw/PASSIVE  listWidth   ListWidth/, undef],
        -matchprefix => [qw/PASSIVE  matchPrefix MatchPrefix/, undef],
115
116
        -maxheight   => [qw/PASSIVE  maxHeight   MaxHeight    5/],
        -multimatch  => [qw/PASSIVE  multiMatch  MultiMatch   0/],
Christian Fibich's avatar
Christian Fibich committed
117
        -sorttrigger => [qw/PASSIVE  sortTrigger SortTrigger/, undef],
118
119
        -wraparound  => [qw/PASSIVE  wrapAround  WrapAround   0/],

Christian Fibich's avatar
Christian Fibich committed
120
        DEFAULT => [[$entry, $scrolled_listbox]]
121
    );
122
123
124
125
126
127
128
129
}

# Set up the keyboard and mouse event bindings
sub set_bindings {
    my ($self) = @_;
    my $entry = $self->Subwidget('entry');

    # Set the bind tags
Christian Fibich's avatar
Christian Fibich committed
130
    $self->bindtags([$self, 'Tk::CompleteEntry', $self->toplevel, 'all']);
131
132
133

    #    $entry->bindtags([$entry, $entry->toplevel, 'all']); # original and kaputt
    #    $entry->bindtags([$entry, 'Tk::Entry', $entry->toplevel, 'all']); # correct but not what we want!?
134
135
136

    # Bindings for the entry widget
    #$entry->bind('<Down>', [$self, 'open_and_focus_listbox']);
Christian Fibich's avatar
Christian Fibich committed
137
138
139
140
141
142
    $entry->bind('<Down>',     [$self, 'entry_cursor_down']);
    $entry->bind('<Up>',       [$self, 'entry_cursor_up']);
    $entry->bind('<Escape>',   [$self, 'entry_escape']);
    $entry->bind('<Tab>',      [$self, 'entry_tabulator']);
    $entry->bind('<Return>',   [$self, 'entry_return']);
    $entry->bind('<FocusOut>', [$self, 'entry_leave']);
143
144
145
    $entry->bind(
        '<Any-KeyPress>',
        sub {
146
            my $event = $_[0]->XEvent;
Christian Fibich's avatar
Christian Fibich committed
147
            $self->entry_anykey($event->K, $event->s);    # Key, State
148
149
150
        }
    );

151
152
    # Bindings for the listbox
    my $scrolled_list = $self->Subwidget('slistbox');
153
    my $listbox       = $scrolled_list->Subwidget('listbox');
Christian Fibich's avatar
Christian Fibich committed
154
155
156
157
    $listbox->bind('<ButtonRelease-1>', [$self, 'release_listbox', Ev('x'), Ev('y')]);
    $listbox->bind('<Escape>' => [$self, 'close_listbox',  $listbox]);
    $listbox->bind('<Return>' => [$self, 'return_listbox', $listbox]);
    $listbox->bind('<Tab>'    => [$self, 'listbox_tab',    $listbox]);
158

159
    # Close listbox if clicked outside
Christian Fibich's avatar
Christian Fibich committed
160
    $self->bind('<1>', 'open_listbox');
161
162
163
164
165
}

# Called when the entry widget loses focus to make sure any text is deselected
sub entry_leave {
    my $self = shift;
166

167
168
169
170
171
172
    $self->entry_prepare_leave;
}

# Called when the user hits <Return> within the entry widget
sub entry_return {
    my $self = shift;
173

174
    # Execute given callback
Christian Fibich's avatar
Christian Fibich committed
175
    $self->Callback(-entercmd => $self);
176

177
178
179
180
181
182
183
184
    # 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 <Tab> within the entry widget
sub entry_tabulator {
    my $self = shift;
185

186
    # Execute given callback
Christian Fibich's avatar
Christian Fibich committed
187
    $self->Callback(-tabcmd => $self);
188

189
190
191
192
193
194
195
196
    # 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 {
197
    my $self  = shift;
198
199
200
    my $entry = $self->Subwidget('entry');

    # close the listbox if popped up
Christian Fibich's avatar
Christian Fibich committed
201
    if ($self->{'popped'}) {
202
203
        $self->hide_listbox;
    }
204

205
206
207
208
    # clear the selection
    $entry->selection('clear');

    # place the input cursor at end of entry widget
Christian Fibich's avatar
Christian Fibich committed
209
    $entry->icursor($entry->index('end'));
210
211
212
213
214
215
216
217
218
219

    # 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 {
220
    my $self  = shift;
221
222
    my $entry = $self->Subwidget('entry');

Christian Fibich's avatar
Christian Fibich committed
223
    return unless ($self->cget(-case));    # abort if case sensitive matching
224

Christian Fibich's avatar
Christian Fibich committed
225
    my $text = $entry->get;                # text in entry widget
226
227

    my $all_choices_r = $self->{Configure}{all_choices_r};
228
229
    my @all_choices   = @$all_choices_r;

Christian Fibich's avatar
Christian Fibich committed
230
231
232
233
    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)) {
234
235

            # if so, replace the text in the entry widget with the choice
Christian Fibich's avatar
Christian Fibich committed
236
237
238
            $entry->delete(0, 'end');
            $entry->insert(0, $choice);
            $entry->icursor($entry->index('end'));
239
        }
240
    }
241
242
243
244
}

# called when the user presses <Escape> in the entry widget
sub entry_escape {
245
    my $self  = shift;
246
247
248
    my $entry = $self->Subwidget('entry');

    # Close listbox if popped up
Christian Fibich's avatar
Christian Fibich committed
249
    if ($self->{'popped'}) {
250
        $self->hide_listbox;
Christian Fibich's avatar
Christian Fibich committed
251
        $entry->selectionRange($entry->index('insert'), $entry->index('end'));
252

253
254
        # assume that another <Escape> follows
        $self->{Configure}{double_escape_possible} = 1;
255
256
    } else {

257
        # undo auto-completion otherwise
Christian Fibich's avatar
Christian Fibich committed
258
259
260
        if ($entry->selectionPresent()) {
            $entry->delete($entry->index("sel.first"), $entry->index("sel.last"));
        } elsif ($self->{Configure}{double_escape_possible}) {
261

262
            # no text selected -> cut from current insert position to end
Christian Fibich's avatar
Christian Fibich committed
263
            $entry->delete($entry->index("insert"), $entry->index("end"));
264

265
266
267
            # turn off double-<Escape> assumption
            $self->{Configure}{double_escape_possible} = 0;
        }
268
    }
269
270
271
272
}

# Called whenever the user presses any key within the entry widget
sub entry_anykey {
Christian Fibich's avatar
Christian Fibich committed
273
    my ($self, $key, $state) = @_;
274
275
276
277
278
279
280
    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;
Christian Fibich's avatar
Christian Fibich committed
281
282
283
284
    if ($entry_length == 0) {
        $self->Callback(-zerocmd => $self);
    } elsif ($entry_length == 1) {
        $self->Callback(-onecmd => $self);
285
    }
286

Christian Fibich's avatar
Christian Fibich committed
287
288
    if ($self->cget(-multimatch)) {
        if ($key =~ m/^Left|^Right|^Home|^End/) {
289
            $self->hide_listbox;
290
        }
291
292
293
    }

    # print ">>>$key<<<\n";
Christian Fibich's avatar
Christian Fibich committed
294
295
296
    my $trigger = $self->cget(-sorttrigger);
    if (defined $trigger) {
        $self->resort if ($key =~ m/$trigger/);
297
298
299
    }

    $self->{Configure}{was_real_input} = 0;
300

Christian Fibich's avatar
Christian Fibich committed
301
302
    return if ($key =~ m/^Super|^Shift|^Alt|^Control|^Left|^Right|^Home|^End/);
    return if ($state =~ m/^Control-/);
303
304
305
306

    $self->{Configure}{was_real_input} = 1;

    # check whether we are in multimatch mode
Christian Fibich's avatar
Christian Fibich committed
307
308
    if ($self->cget(-multimatch)) {
        return $self->entry_anykey_multimatch($key, $state, $entry);
309
    }
310

311
312
    # automatically pop the listbox up if requested by programmer
    # and the user has already entered at least 1 character
Christian Fibich's avatar
Christian Fibich committed
313
314
    if ($self->cget(-autopopup) && length $entry->get) {
        if ($self->{popped}) {    # already popped up, just filter entries
315
            my $last_num    = $self->{Configure}{last_number_of_entries};
316
            my $num_entries = $self->listbox_filter;
317

Christian Fibich's avatar
Christian Fibich committed
318
            $num_entries = 0 unless (defined $num_entries);
319

320
            # number of choices has changed, redraw the listbox
Christian Fibich's avatar
Christian Fibich committed
321
            unless ($last_num == $num_entries) {
322
323
324
                $self->hide_listbox;
                $self->show_listbox;
            }
Christian Fibich's avatar
Christian Fibich committed
325
        } else {                  # pop the listbox up, automatically calls the filter
326
327
            $self->show_listbox;
        }
328
    } else {    # check length of input, close listbox if too short
Christian Fibich's avatar
Christian Fibich committed
329
        unless (length $entry->get) {
330
331
332
333
334
            $self->hide_listbox;
        }
    }

    # Skip the rest if user pressed Backspace or Delete
Christian Fibich's avatar
Christian Fibich committed
335
    return if ($key eq "BackSpace" or $key eq "Delete");
336
337

    $self->entry_autocomplete;
338
339
340
341
}

# Handle any keypress in multimatch mode
sub entry_anykey_multimatch {
Christian Fibich's avatar
Christian Fibich committed
342
    my ($self, $key, $state, $entry) = @_;
343
344
345
346

    # automatically pop the listbox up if requested by programmer
    # and the user has already entered at least 1 character in the
    # current word
347
348

    my $text   = $entry->get;
349
    my $cursor = $entry->index('insert');
Christian Fibich's avatar
Christian Fibich committed
350
    (my $typed_text = $text) =~ s/^(.{$cursor})(.*)/$1/;
351
    my $text_after_cursor = $2;
352

Christian Fibich's avatar
Christian Fibich committed
353
    (my $current_word = $typed_text) =~ s/.*\s(.*)/$1/;
354

355
    my $word_length = length $current_word;
Christian Fibich's avatar
Christian Fibich committed
356
357
358
359
    if ($word_length == 0) {
        $self->Callback(-mm_zerocmd => $self);
    } elsif ($word_length == 1) {
        $self->Callback(-mm_onecmd => $self);
360
    }
361

362
    # print "current word: $current_word\n";
363

Christian Fibich's avatar
Christian Fibich committed
364
365
    if ($self->cget(-autopopup) && length $current_word) {
        if ($self->{popped}) {    # already popped up, just filter entries
366
            my $last_num    = $self->{Configure}{last_number_of_entries};
367
            my $num_entries = $self->listbox_filter($current_word);
368

Christian Fibich's avatar
Christian Fibich committed
369
            $num_entries = 0 unless (defined $num_entries);
370

371
            # number of choices has changed, redraw the listbox
Christian Fibich's avatar
Christian Fibich committed
372
            unless ($last_num == $num_entries) {
373
374
375
                $self->hide_listbox;
                $self->show_listbox($current_word);
            }
Christian Fibich's avatar
Christian Fibich committed
376
        } else {                  # pop the listbox up, automatically calls the filter
377
378
            $self->show_listbox($current_word);
        }
379
    } else {    # check length of input, close listbox if too short
Christian Fibich's avatar
Christian Fibich committed
380
        unless (length $current_word) {
381
382
383
384
385
            $self->hide_listbox;
        }
    }

    # Skip the rest if user pressed Backspace or Delete
Christian Fibich's avatar
Christian Fibich committed
386
    return if ($key eq "BackSpace" or $key eq "Delete");
387

388
389
390
391
392
    $self->entry_autocomplete_multimatch;
}

# attempt to auto-complete the entry
sub entry_autocomplete {
393
    my $self  = shift;
394
    my $entry = $self->Subwidget('entry');
395

396
    # check whether we are in multimatch mode
Christian Fibich's avatar
Christian Fibich committed
397
    if ($self->cget(-multimatch)) {
398
399
        return $self->entry_autocomplete_multimatch;
    }
400

Christian Fibich's avatar
Christian Fibich committed
401
    if ($self->cget(-complete)) {    # do we want auto-completion at all?
402
        my $text   = $entry->get;
403
        my $cursor = $entry->index('insert');
Christian Fibich's avatar
Christian Fibich committed
404
        (my $typed_text = $text) =~ s/^(.{$cursor})(.*)/$1/;
405
406
407
408
        my $text_after_cursor = $2;

        # check whether any text after insert cursor is from auto-completion
        my $non_auto_text;
Christian Fibich's avatar
Christian Fibich committed
409
410
        $non_auto_text = 1 if ($text_after_cursor ne "");
        if ($non_auto_text && $entry->selectionPresent) {
411
            $non_auto_text = 0
Christian Fibich's avatar
Christian Fibich committed
412
413
              if ( ($entry->index('end') == $entry->index('sel.last'))
                && ($entry->index('insert') == $entry->index('sel.first')));
414
        }
415

416
        # skip if position = 0 or there's text after the insert cursor
Christian Fibich's avatar
Christian Fibich committed
417
        unless ($cursor == 0 || $text eq "" || $non_auto_text) {
418

419
            # search for the first matching entry
Christian Fibich's avatar
Christian Fibich committed
420
            my $ignore_case   = ($self->cget(-case) ? "(?i)" : "");
421
            my $all_choices_r = $self->{Configure}{all_choices_r};
422
423
            my @all_choices   = @$all_choices_r;

Christian Fibich's avatar
Christian Fibich committed
424
            my $prefix = $self->cget(-matchprefix) || "";
425
426

            my $index = 0;
427
            foreach my $choice (@all_choices) {    # @all_choices is sorted
Christian Fibich's avatar
Christian Fibich committed
428
                if ($choice =~ m/^${ignore_case}$prefix\Q$typed_text\E(.*)/) {
429
                    my $choice_tail = $1;          # auto-completed part of entry
430
431

                    #print "..$choice_tail..\n";
432

433
                    $entry->selection('clear');
Christian Fibich's avatar
Christian Fibich committed
434
435
436
                    $entry->delete($cursor, 'end');
                    $entry->insert($cursor, $choice_tail);
                    $entry->selection('range', $cursor, 'end');
437
438
                    $entry->icursor($cursor);

439
                    last;                          # break out of foreach $choice
440
                }
441
            }
442
443
444
445
446
447
        }
    }
}

# attempt to auto-complete the current word in multimatch mode
sub entry_autocomplete_multimatch {
448
    my $self  = shift;
449
450
    my $entry = $self->Subwidget('entry');

Christian Fibich's avatar
Christian Fibich committed
451
    if ($self->cget(-complete)) {                  # do we want auto-completion at all?
452
        my $text   = $entry->get;
453
        my $cursor = $entry->index('insert');
Christian Fibich's avatar
Christian Fibich committed
454
        (my $typed_text = $text) =~ s/^(.{$cursor})(.*)/$1/;
455
        my $text_after_cursor = $2;
456

457
        my $rest_of_line = '';
458

459
460
        # check whether the user is editing a word which is not the
        # last on the line
Christian Fibich's avatar
Christian Fibich committed
461
462
        if ($text_after_cursor =~ m/\s/) {
            ($rest_of_line = $text_after_cursor) =~ s/(.*?)\s(.*)/$2/;
463
464
465
466
            $text_after_cursor = $1;
        }

        # extract last word on line
Christian Fibich's avatar
Christian Fibich committed
467
        if ($typed_text =~ m/\s/) {
468
469
            $typed_text =~ s/.*\s(.*)/$1/;
        }
470

471
472
        # check whether any text after insert cursor is from auto-completion
        my $non_auto_text;
Christian Fibich's avatar
Christian Fibich committed
473
474
        $non_auto_text = 1 if ($text_after_cursor ne "");
        if ($non_auto_text && $entry->selectionPresent) {
475
            $non_auto_text = 0
Christian Fibich's avatar
Christian Fibich committed
476
477
              if ( ($entry->index('end') == $entry->index('sel.last'))
                && ($entry->index('insert') == $entry->index('sel.first')));
478
        }
479

480
        # skip if position = 0 or there's text after the insert cursor
Christian Fibich's avatar
Christian Fibich committed
481
        unless ($typed_text eq "" || $non_auto_text) {
482

483
            # search for the first matching entry
Christian Fibich's avatar
Christian Fibich committed
484
            my $ignore_case   = ($self->cget(-case) ? "(?i)" : "");
485
            my $all_choices_r = $self->{Configure}{all_choices_r};
486
487
            my @all_choices   = @$all_choices_r;

Christian Fibich's avatar
Christian Fibich committed
488
            my $prefix = $self->cget(-matchprefix) || "";
489
490

            my $index = 0;
491
            foreach my $choice (@all_choices) {    # @all_choices is sorted
Christian Fibich's avatar
Christian Fibich committed
492
                if ($choice =~ m/^${ignore_case}$prefix\Q$typed_text\E(.*)/) {
493
                    my $choice_tail = $1;          # auto-completed part of entry
494
                    $entry->selection('clear');
Christian Fibich's avatar
Christian Fibich committed
495
496
497
498
499
                    $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);
500
501
502
                    }
                    $entry->icursor($cursor);

503
                    last;                          # break out of foreach $choice
504
                }
505
            }
506
        }
507
    }
508
509
510
511
}

# called when the <Down> key is pressed within the entry
sub entry_cursor_down {
512
    my $self    = shift;
513
    my $listbox = $self->Subwidget('slistbox')->Subwidget('listbox');
514
515
    my $entry   = $self->Subwidget('entry');

516
    $self->{Configure}{was_real_input} = 0;
517

518
    # print "entry_cursor_down\n";
519

520
    my $index;
521

522
    # unless it's already there, open the listbox and focus first entry
Christian Fibich's avatar
Christian Fibich committed
523
524
    unless ($self->{popped}) {
        if ($self->cget(-multimatch)) {
525
            my $text   = $entry->get;
526
            my $cursor = $entry->index('insert');
Christian Fibich's avatar
Christian Fibich committed
527
528
            (my $typed_text   = $text) =~ s/^(.{$cursor})(.*)/$1/;
            (my $current_word = $typed_text) =~ s/.*\s(.*)/$1/;
529
            $self->open_listbox($current_word);
530
        } else {
531
            $self->open_listbox;
532
        }
533

Christian Fibich's avatar
Christian Fibich committed
534
        $listbox->selection('clear', 0, 'end');
535
        $listbox->selectionSet(0);
536
        $listbox->activate(0);
537
        $index = 0;
538
539
    } else {    # otherwise move selection one down, unless already at bottom
                # print "one down\n";
Christian Fibich's avatar
Christian Fibich committed
540
        if ($self->cget(-multimatch)) {
541
            my $text   = $entry->get;
542
            my $cursor = $entry->index('insert');
Christian Fibich's avatar
Christian Fibich committed
543
544
            (my $typed_text   = $text) =~ s/^(.{$cursor})(.*)/$1/;
            (my $current_word = $typed_text) =~ s/.*\s(.*)/$1/;
545
            $self->listbox_filter($current_word);
546
        } else {
547
            $self->listbox_filter;
548
549
        }

550
        $index = $self->listbox_index;
Christian Fibich's avatar
Christian Fibich committed
551
        if ($index < $self->{Configure}{last_number_of_entries} - 1) {
552
553
554
            $index++;

            # check whether no element was selected before
Christian Fibich's avatar
Christian Fibich committed
555
            $index = 0 if ($index == 1 && !$listbox->selectionIncludes(0));
556

Christian Fibich's avatar
Christian Fibich committed
557
            $listbox->selection('clear', 0, 'end');
558
559
            $listbox->selectionSet($index);
            $listbox->activate($index);
560
        } else {
Christian Fibich's avatar
Christian Fibich committed
561
562
            $self->Callback(-bottomcmd => $self);
            if ($self->cget(-wraparound)) {
563
                $index = 0;
Christian Fibich's avatar
Christian Fibich committed
564
                $listbox->selection('clear', 0, 'end');
565
                $listbox->selectionSet($index);
566
                $listbox->activate($index);
567
568
569
570
571
572
573
574
575
576
            }
        }
    }

    $listbox->see($index);
    $self->listbox_copy_to_entry;
    $self->entry_select_from_cursor_to_end;
}

sub entry_cursor_up {
577
    my $self    = shift;
578
    my $listbox = $self->Subwidget('slistbox')->Subwidget('listbox');
579
580
    my $entry   = $self->Subwidget('entry');

581
    my $index;
582

583
    $self->{Configure}{was_real_input} = 0;
584

585
    # unless it's already there, open the listbox and focus first entry
Christian Fibich's avatar
Christian Fibich committed
586
    unless ($self->{popped}) {
587

Christian Fibich's avatar
Christian Fibich committed
588
        if ($self->cget(-multimatch)) {
589
            my $text   = $entry->get;
590
            my $cursor = $entry->index('insert');
Christian Fibich's avatar
Christian Fibich committed
591
592
            (my $typed_text   = $text) =~ s/^(.{$cursor})(.*)/$1/;
            (my $current_word = $typed_text) =~ s/.*\s(.*)/$1/;
593
            $self->open_listbox($current_word);
594
        } else {
595
            $self->open_listbox;
596
597
        }

Christian Fibich's avatar
Christian Fibich committed
598
        $listbox->selection('clear', 0, 'end');
599
        $listbox->selectionSet(0);
600
        $listbox->activate(0);
601
        $index = 0;
602
    } else {    # otherwise move selection one up, unless already at top
Christian Fibich's avatar
Christian Fibich committed
603
        if ($self->cget(-multimatch)) {
604
            my $text   = $entry->get;
605
            my $cursor = $entry->index('insert');
Christian Fibich's avatar
Christian Fibich committed
606
607
            (my $typed_text   = $text) =~ s/^(.{$cursor})(.*)/$1/;
            (my $current_word = $typed_text) =~ s/.*\s(.*)/$1/;
608
            $self->listbox_filter($current_word);
609
        } else {
610
            $self->listbox_filter;
611
        }
612
        $index = $self->listbox_index;
Christian Fibich's avatar
Christian Fibich committed
613
        if ($index > 0) {
614
            $index--;
615
        } else {
Christian Fibich's avatar
Christian Fibich committed
616
617
            $self->Callback(-topcmd => $self);
            if ($self->cget(-wraparound)) {
618
                $index = $self->{Configure}{last_number_of_entries} - 1;
Christian Fibich's avatar
Christian Fibich committed
619
                $listbox->selection('clear', 0, 'end');
620
                $listbox->selectionSet($index);
621
                $listbox->activate($index);
622
623
            }
        }
624

Christian Fibich's avatar
Christian Fibich committed
625
        $listbox->selection('clear', 0, 'end');
626
627
628
629
        $listbox->selectionSet($index);
        $listbox->activate($index);
    }

630
    $listbox->see($index);
631
    $self->listbox_copy_to_entry;
632
633
    $self->entry_select_from_cursor_to_end;
}
634
635
636

# Select text in the entry widget, from current cursor position to end
sub entry_select_from_cursor_to_end {
637
    my $self  = shift;
638
639
640
641
642
643
    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)

Christian Fibich's avatar
Christian Fibich committed
644
645
    if ($self->{Configure}{last_filter_matched_by_prefix_only}) {
        if ($self->cget(-multimatch)) {
646
            my $pos = $entry->index('insert');
Christian Fibich's avatar
Christian Fibich committed
647
            (my $text = $entry->get) =~ s/^(.{$pos})/$1/;
648
            $text =~ s/(.*)\s.*/$1/;
649

650
651
            # print $text."\n";
            # print "..." . length $text , "\n(of $pos)\n";
Christian Fibich's avatar
Christian Fibich committed
652
653
            if (length $text > $pos) {
                if ($text =~ m/(.{$pos})/) {
654
655
                    my $t = $1;
                    $t =~ s/(.*)\s.*/$1/;
656

657
                    # print "...$t\n";
Christian Fibich's avatar
Christian Fibich committed
658
                    $entry->icursor(1 + length $t);
659
                } else {
660
661
                    $entry->icursor($pos);
                }
662
            } else {
Christian Fibich's avatar
Christian Fibich committed
663
                $entry->icursor(1 + length $text);
664
            }
665
        } else {
666
667
668
            $entry->icursor(0);
        }
    }
669

Christian Fibich's avatar
Christian Fibich committed
670
    if ($self->cget(-multimatch)) {
671
        my $pos = $entry->index('insert');
Christian Fibich's avatar
Christian Fibich committed
672
673
        (my $text = $entry->get) =~ s/^.{$pos}(.*)/$1/;
        if ($text =~ m/\s/g) {
674
            $pos += pos($text) - 1;
675

676
            # print "spacematch: $text\n";
677
        } else {
678
679
            $pos = $entry->index('end');
        }
680

681
        # print "pps: $pos\n";
Christian Fibich's avatar
Christian Fibich committed
682
        $entry->selectionRange($entry->index('insert'), $pos);
683
    } else {
Christian Fibich's avatar
Christian Fibich committed
684
        $entry->selectionRange($entry->index('insert'), $entry->index('end'));
685
686
    }
}
687

688
689
# called when mouse button 1 is released within the listbox
sub release_listbox {
Christian Fibich's avatar
Christian Fibich committed
690
691
    my ($self, $x, $y) = @_;
    $self->choose_listbox($x, $y);
692
693
694
695
}

# allows the programmer to popup the listbox if auto-popup is disabled
sub popup {
696
697
    my $self         = shift;
    my $current_word = shift;    # optional, introduced with multi-matching
698
699
700
701
702
    $self->open_listbox($current_word);
}

# hide/unhide the popup listbox
sub open_listbox {
703
704
    my $self         = shift;
    my $current_word = shift;    # optional, introduced with multi-matching
705
706

    # check whether we are in state "disabled"
Christian Fibich's avatar
Christian Fibich committed
707
    return if ($self->cget('-state') eq 'disabled');
708

Christian Fibich's avatar
Christian Fibich committed
709
    if ($self->{'popped'}) {
710
        $self->close_listbox;
711
    } else {
712
713
714
715
716
717
718
        $self->show_listbox($current_word);
    }
}

# Remove all entries from the choices listbox which can't match the user's
# input anymore.
sub listbox_filter {
719
720
721
    my $self          = shift;
    my $text_to_match = shift;    # optional, introduced with multimatching

722
    my $listbox = $self->Subwidget('slistbox')->Subwidget('listbox');
723
    my $entry   = $self->Subwidget('entry');
724
725
726
727
728

    $entry->update;
    my $cursor_pos = $entry->index('insert');

    my $old_index = $self->listbox_index;
Christian Fibich's avatar
Christian Fibich committed
729
730
    my ($old_value, $new_index);
    if (defined $old_index) {
731
732
        $old_value = $listbox->get($old_index);
    }
Christian Fibich's avatar
Christian Fibich committed
733
734
    $listbox->delete(0, 'end');
    my $ignore_case   = ($self->cget(-case) ? "(?i)" : "");
735
    my $all_choices_r = $self->{Configure}{all_choices_r};
736
737
    my @all_choices   = @$all_choices_r;

738
    my $text = $entry->get;
Christian Fibich's avatar
Christian Fibich committed
739
    (my $typed_text = $text) =~ s/^(.{$cursor_pos})(.*)/$1/;
740
741
    my $rest_of_line = $2;

Christian Fibich's avatar
Christian Fibich committed
742
    my $prefix = $self->cget(-matchprefix) || "";
743
744

    my $force_match = '';
Christian Fibich's avatar
Christian Fibich committed
745
    if (length $self->{Configure}{last_user_input}) {
746
747
        $force_match = $self->{Configure}{last_user_input};
    }
748

Christian Fibich's avatar
Christian Fibich committed
749
750
751
    unless (defined $text_to_match) {
        if ($rest_of_line ne "") {    # text after cursor
                                      # only use matching if whole text matches one of the choices
752
753
754
            my $text_is_choice = 0;

            foreach my $choice (@all_choices) {
Christian Fibich's avatar
Christian Fibich committed
755
                if ($text =~ m/^${ignore_case}\Q$choice\E$/) {
756
757
758
759
760
761
                    $text_is_choice++;
                }
            }

            # give it a try for sure if we have a match-prefix
            $self->{Configure}{last_filter_matched_by_prefix_only} = 0;
Christian Fibich's avatar
Christian Fibich committed
762
763
            if ($text_is_choice == 0) {
                if (length $prefix) {
764
765
766
767
768
769
770
                    $self->{Configure}{last_filter_matched_by_prefix_only} = 1;
                    $text_is_choice++;
                }
            }

            return unless ($text_is_choice);
        }
771
772
    } else {    # multimatch mode or $text_to_match otherwise specified
                # print "text to match: $text_to_match\n";
773
774
        $typed_text = $text_to_match;

Christian Fibich's avatar
Christian Fibich committed
775
        if (length $typed_text) {
776

777
778
779
780
781
782
            # 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) {
Christian Fibich's avatar
Christian Fibich committed
783
                if ($choice =~ m/^${ignore_case}\Q$typed_text\E/) {
784
785
786
                    $text_is_choice++;
                }
            }
787

788
789
            # give it a try for sure if we have a match-prefix
            $self->{Configure}{last_filter_matched_by_prefix_only} = 0;
Christian Fibich's avatar
Christian Fibich committed
790
791
            if ($text_is_choice == 0) {
                if (length $prefix) {
792
793
794
795
796
797
798
                    $self->{Configure}{last_filter_matched_by_prefix_only} = 1;
                    $text_is_choice++;
                }
            }
        }
    }

Christian Fibich's avatar
Christian Fibich committed
799
    if ($self->{Configure}{last_filter_matched_by_prefix_only}) {
800
        $self->{Configure}{last_user_input} = $typed_text;
801
    } else {
802
803
        $self->{Configure}{last_user_input} = '';
    }
804

805
    # print "real input: . " . $self->{Configure}{was_real_input} . "\n";
806

Christian Fibich's avatar
Christian Fibich committed
807
    if (length $force_match) {
808
        $typed_text = $force_match
Christian Fibich's avatar
Christian Fibich committed
809
          unless ($self->{Configure}{was_real_input});
810
        $self->{Configure}{last_user_input} = $typed_text
Christian Fibich's avatar
Christian Fibich committed
811
          unless ($self->{Configure}{was_real_input});
812
    }
813

814
    my $index = 0;
815
    foreach my $choice (@all_choices) {    # @all_choices is sorted
Christian Fibich's avatar
Christian Fibich committed
816
817
818
        if ($choice =~ m/^${ignore_case}$prefix\Q$typed_text\E/) {
            $listbox->insert('end', $choice);
            if (defined $old_value && ($old_value eq $choice)) {
819
820
821
822
823
824
                $new_index = $index;
            }
            $index++;
        }
    }

Christian Fibich's avatar
Christian Fibich committed
825
    if (defined $new_index) {
826

827
828
829
830
        # $listbox->see($new_index);
        $listbox->selectionSet($new_index);
        $listbox->activate($new_index);
    }
831

832
    $self->{Configure}{last_number_of_entries} = $index;
833
    return $index;    # equals number of visible elements
834
835
836
837
}

# Display the listbox
sub show_listbox {
838
839
    my $self         = shift;
    my $current_word = shift;    # optional
840
841

    # Don't do that stuff if we're already popped up
Christian Fibich's avatar
Christian Fibich committed
842
    unless ($self->{'popped'}) {
843

844
        # Allow the programmer to change his choices
Christian Fibich's avatar
Christian Fibich committed
845
        $self->Callback(-listcmd => $self);
846
847
848

        # Display only listbox entries which could match
        my $number_of_visible_elements = $self->listbox_filter($current_word);
849

850
851
        # abort if listbox would be empty or contain less entries
        # than required for auto-completion (usually 1)
Christian Fibich's avatar
Christian Fibich committed
852
853
        return unless (defined $number_of_visible_elements
            && ($number_of_visible_elements > $self->cget(-complete)));
854

855
        # Fetch our subwidgets
856
857
        my $entry            = $self->Subwidget('entry');
        my $choices          = $self->Subwidget('choices');
858
859
860
861
        my $scrolled_listbox = $self->Subwidget('slistbox');

        # Calculate height and width for the popup listbox
        my $y1 = $entry->rooty + $entry->height + 3;
Christian Fibich's avatar
Christian Fibich committed
862
        my $bd = $choices->cget(-bd) + $choices->cget(-highlightthickness);
863

864
865
866
        #my $ht = ($scrolled_listbox->reqheight / 2) + 2 * $bd + 2;

        # Calculate height for listbox. Default reqheight = 10 elements.
Christian Fibich's avatar
Christian Fibich committed
867
        my $maxheight = $self