1# -*- perl -*-
2
3#
4# Author: Slaven Rezic
5#
6# Copyright � 1997, 2000, 2001, 2003, 2008, 2016, 2017 Slaven Rezic. All rights reserved.
7# This package is free software; you can redistribute it and/or
8# modify it under the same terms as Perl itself.
9#
10# Mail: slaven@rezic.de
11# WWW:  http://www.cs.tu-berlin.de/~eserte/
12#
13
14package Tk::HistEntry;
15require Tk;
16use strict;
17use vars qw($VERSION);
18
19$VERSION = '0.45';
20
21sub addBind {
22    my $w = shift;
23
24    $w->_entry->bind('<Up>'        => sub { $w->historyUp });
25    $w->_entry->bind('<Control-p>' => sub { $w->historyUp });
26    $w->_entry->bind('<Down>'      => sub { $w->historyDown });
27    $w->_entry->bind('<Control-n>' => sub { $w->historyDown });
28
29    $w->_entry->bind('<Meta-less>'    => sub { $w->historyBegin });
30    $w->_entry->bind('<Alt-less>'     => sub { $w->historyBegin });
31    $w->_entry->bind('<Meta-greater>' => sub { $w->historyEnd });
32    $w->_entry->bind('<Alt-greater>'  => sub { $w->historyEnd });
33
34    $w->_entry->bind('<Control-r>' => sub { $w->searchBack });
35    $w->_entry->bind('<Control-s>' => sub { $w->searchForw });
36
37    $w->_entry->bind('<Return>' => sub {
38		 if ($w->cget(-command) || $w->cget(-auto)) {
39		     $w->invoke;
40		 }
41	     });
42
43    $w->_entry->bind('<Any-KeyPress>', sub {
44			 my $e = $_[0]->XEvent;
45			 $w->KeyPress($e->K, $e->s);
46		     });
47}
48
49# XXX del:
50#  sub _isdup {
51#      my($w, $string) = @_;
52#      foreach (@{ $w->privateData->{'history'} }) {
53#  	return 1 if $_ eq $string;
54#      }
55#      0;
56#  }
57
58sub _update {
59    my($w, $string) = @_;
60    $w->_entry->delete(0, 'end');
61    $w->_entry->insert('end', $string);
62}
63
64sub _entry {
65    my $w = shift;
66    $w->Subwidget('entry') ? $w->Subwidget('entry') : $w;
67}
68
69sub _listbox {
70    my $w = shift;
71    $w->Subwidget('slistbox') ? $w->Subwidget('slistbox') : $w;
72}
73
74sub _listbox_method {
75    my $w = shift;
76    my $meth = shift;
77    if ($w->_has_listbox) {
78	$w->_listbox->$meth(@_);
79    }
80}
81
82sub _has_listbox { $_[0]->Subwidget('slistbox') }
83
84sub historyAdd {
85    my($w, $string, %args) = @_;
86
87    $string = $w->_entry->get unless defined $string;
88    return undef if !defined $string || $string eq '';
89
90    my $history = $w->privateData->{'history'};
91    if (!@$history or $string ne $history->[-1]) {
92	my $spliced = 0;
93	if (!$w->cget(-dup)) {
94	    for(my $i = 0; $i<=$#$history; $i++) {
95		if ($string eq $history->[$i]) {
96		    splice @$history, $i, 1;
97		    $spliced++;
98		    last;
99		}
100	    }
101	}
102
103	push @$history, $string;
104	if (defined $w->cget(-limit) &&
105	    @$history > $w->cget(-limit)) {
106	    shift @$history;
107	}
108	$w->privateData->{'historyindex'} = $#$history + 1;
109
110	my @ret = $string;
111	if ($args{-spliceinfo}) {
112	    push @ret, $spliced;
113	}
114	return @ret;
115    }
116    undef;
117}
118# compatibility with Term::ReadLine
119*addhistory = \&historyAdd;
120
121sub historyUpdate {
122    my $w = shift;
123    $w->_update($w->privateData->{'history'}->[$w->privateData->{'historyindex'}]);
124    $w->_entry->icursor('end'); # suggestion by Jason Smith <smithj4@rpi.edu>
125    $w->_entry->xview('insert');
126}
127
128sub historyUp {
129    my $w = shift;
130    if ($w->privateData->{'historyindex'} > 0) {
131        $w->privateData->{'historyindex'}--;
132	$w->historyUpdate;
133    } else {
134	$w->_bell;
135    }
136}
137
138sub historyDown {
139    my $w = shift;
140    if ($w->privateData->{'historyindex'} <= $#{$w->privateData->{'history'}}) {
141	$w->privateData->{'historyindex'}++;
142	$w->historyUpdate;
143    } else {
144	$w->_bell;
145    }
146}
147
148sub historyBegin {
149    my $w = shift;
150    $w->privateData->{'historyindex'} = 0;
151    $w->historyUpdate;
152}
153
154sub historyEnd {
155    my $w = shift;
156    $w->privateData->{'historyindex'} = $#{$w->privateData->{'history'}};
157    $w->historyUpdate;
158}
159
160sub historySet {
161    my($w, $index) = @_;
162    my $i;
163    my $history_ref = $w->privateData->{'history'};
164    for($i = $#{ $history_ref }; $i >= 0; $i--) {
165	if ($index eq $history_ref->[$i]) {
166	    $w->privateData->{'historyindex'} = $i;
167	    last;
168	}
169    }
170}
171
172sub historyReset {
173    my $w = shift;
174    $w->privateData->{'history'} = [];
175    $w->privateData->{'historyindex'} = 0;
176    $w->_listbox_method("delete", 0, "end");
177}
178
179sub historySave {
180    my($w, $file) = @_;
181    open(W, ">$file") or die "Can't save to file $file";
182    print W join("\n", $w->history) . "\n";
183    close W;
184}
185
186# XXX document
187sub historyMergeFromFile {
188    my($w, $file) = @_;
189    if (open(W, "<$file")) {
190	while(<W>) {
191	    chomp;
192	    $w->historyAdd($_);
193	}
194	close W;
195    }
196}
197
198sub history {
199    my($w, $history) = @_;
200    if (defined $history) {
201	$w->privateData->{'history'} = [ @$history ];
202	$w->privateData->{'historyindex'} =
203	  $#{$w->privateData->{'history'}} + 1;
204    }
205    @{ $w->privateData->{'history'} };
206}
207
208sub searchBack {
209    my $w = shift;
210    my $i = $w->privateData->{'historyindex'}-1;
211    while ($i >= 0) {
212	my $search = $w->_entry->get;
213        if ($search eq substr($w->privateData->{'history'}->[$i], 0,
214			      length($search))) {
215	    $w->privateData->{'historyindex'} = $i;
216	    $w->_update($w->privateData->{'history'}->[$w->privateData->{'historyindex'}]);
217            return;
218        }
219        $i--;
220    }
221    $w->_bell;
222}
223
224sub searchForw {
225    my $w = shift;
226    my $i = $w->privateData->{'historyindex'}+1;
227    while ($i <= $#{$w->privateData->{'history'}}) {
228	my $search = $w->_entry->get;
229        if ($search eq substr($w->privateData->{'history'}->[$i], 0,
230			      length($search))) {
231	    $w->privateData->{'historyindex'} = $i;
232	    $w->_update($w->privateData->{'history'}->[$w->privateData->{'historyindex'}]);
233            return;
234        }
235        $i++;
236    }
237    $w->_bell;
238}
239
240sub invoke {
241    my($w, $string) = @_;
242    $string = $w->_entry->get if !defined $string;
243    return unless defined $string;
244    my $added = defined $w->historyAdd($string);
245    $w->Callback(-command => $w, $string, $added);
246}
247
248sub _bell {
249    my $w = shift;
250    return unless $w->cget(-bell);
251    $w->bell;
252}
253
254sub KeyPress {
255    my($w, $key, $state) = @_;
256    my $e = $w->_entry;
257    my(@history) = reverse $w->history;
258    $w->{end} = $#history; # XXXXXXXX?
259    return if ($key =~ /^Shift|^Control|^Left|^Right|^Home|^End/);
260    return if ($state =~ /^Control-/);
261    if ($key eq 'Tab') {
262	# Tab doesn't trigger FocusOut event so clear selection
263	$e->selection('clear');
264	return;
265    }
266    return if (!$w->cget(-match));
267
268    $e->update;
269    my $cursor = $e->index('insert');
270
271    if ($key eq 'BackSpace' or $key eq 'Delete') {
272	$w->{start} = 0;
273	$w->{end} = $#history;
274	return;
275    }
276
277    my $text = $e->get;
278    ###Grab test from entry upto cursor
279    (my $typedtext = $text) =~ s/^(.{$cursor})(.*)/$1/;
280    if ($2 ne "") {
281	###text after cursor, do not use matching
282	return;
283    }
284
285    if ($cursor == 0 || $text eq '') {
286	###No text before cursor, reset list
287	$w->{start} = 0;
288	$w->{end} = $#history;
289	$e->delete(0, 'end');
290	$e->insert(0,'');
291    } else {
292	my $start = $w->{start};
293	my $end = $w->{end};
294	my ($newstart, $newend);
295
296	###Locate start of matching & end of matching
297	my $caseregex = ($w->cget(-case) ? "(?i)" : "");
298	for (; $start <= $end; $start++) {
299	    if ($history[$start] =~ /^$caseregex\Q$typedtext\E/) {
300		$newstart = $start if (!defined $newstart);
301		$newend = $start;
302	    } else {
303		last if (defined $newstart);
304	    }
305	}
306
307	if (defined $newstart) {
308	    $e->selection('clear');
309	    $e->delete(0, 'end');
310	    $e->insert(0, $history[$newstart]);
311	    $e->selection('range',$cursor,'end');
312	    $e->icursor($cursor);
313	    $w->{start} = $newstart;
314	    $w->{end} = $newend;
315	} else {
316	    $w->{end} = -1;
317	}
318    }
319}
320
321######################################################################
322
323package Tk::HistEntry::Simple;
324require Tk::Entry;
325use vars qw(@ISA);
326@ISA = qw(Tk::Derived Tk::Entry Tk::HistEntry);
327#use base qw(Tk::Derived Tk::Entry Tk::HistEntry);
328Construct Tk::Widget 'SimpleHistEntry';
329
330sub CreateArgs {
331    my($package, $parent, $args) = @_;
332    $args->{-class} = "SimpleHistEntry" unless exists $args->{-class};
333    $package->SUPER::CreateArgs($parent, $args);
334}
335
336sub Populate {
337    my($w, $args) = @_;
338
339    $w->historyReset;
340
341    $w->SUPER::Populate($args);
342
343    $w->Advertise(entry => $w);
344
345    $w->{start} = 0;
346    $w->{end} = 0;
347
348    $w->addBind;
349
350    $w->ConfigSpecs
351      (-command => ['CALLBACK', 'command', 'Command', undef],
352       -auto    => ['PASSIVE',  'auto',    'Auto',    0],
353       -dup     => ['PASSIVE',  'dup',     'Dup',     1],
354       -bell    => ['PASSIVE',  'bell',    'Bell',    1],
355       -limit   => ['PASSIVE',  'limit',   'Limit',   undef],
356       -match   => ['PASSIVE',  'match',   'Match',   0],
357       -case    => ['PASSIVE',  'case',    'Case',    1],
358       -history => ['METHOD'],
359      );
360
361    $w;
362}
363
364
365######################################################################
366package Tk::HistEntry::Browse;
367require Tk::BrowseEntry;
368use vars qw(@ISA);
369@ISA = qw(Tk::Derived Tk::BrowseEntry Tk::HistEntry);
370#use base qw(Tk::Derived Tk::BrowseEntry Tk::HistEntry);
371Construct Tk::Widget 'HistEntry';
372
373sub CreateArgs {
374    my($package, $parent, $args) = @_;
375    $args->{-class} = "HistEntry" unless exists $args->{-class};
376    $package->SUPER::CreateArgs($parent, $args);
377}
378
379sub Populate {
380    my($w, $args) = @_;
381
382    $w->historyReset;
383
384    if ($Tk::VERSION >= 800) {
385	$w->SUPER::Populate($args);
386    } else {
387	my $saveargs;
388	foreach (qw(-auto -command -dup -bell -limit -match -case)) {
389	    if (exists $args->{$_}) {
390		$saveargs->{$_} = delete $args->{$_};
391	    }
392	}
393	$w->SUPER::Populate($args);
394	foreach (keys %$saveargs) {
395	    $args->{$_} = $saveargs->{$_};
396	}
397    }
398
399    $w->addBind;
400
401    $w->{start} = 0;
402    $w->{end} = 0;
403
404    my $entry = $w->Subwidget('entry');
405
406    $w->ConfigSpecs
407      (-command => ['CALLBACK', 'command', 'Command', undef],
408       -auto    => ['PASSIVE',  'auto',    'Auto',    0],
409       -dup     => ['PASSIVE',  'dup',     'Dup',     1],
410       -bell    => ['PASSIVE',  'bell',    'Bell',    1],
411       -limit   => ['PASSIVE',  'limit',   'Limit',   undef],
412       -match   => ['PASSIVE',  'match',   'Match',   0],
413       -case    => ['PASSIVE',  'case',    'Case',    1],
414       -history => ['METHOD'],
415      );
416
417## Delegation does not work with the new BrowseEntry --- it seems to me
418## that delegation only works for composites, not for derivates
419#    $w->Delegates('delete' => $entry,
420#		  'get'    => $entry,
421#		  'insert' => $entry,
422#		 );
423
424    $w;
425}
426
427sub delete { shift->Subwidget('entry')->delete(@_) }
428sub get    { shift->Subwidget('entry')->get   (@_) }
429sub insert { shift->Subwidget('entry')->insert(@_) }
430
431sub historyAdd {
432    my($w, $string) = @_;
433    my($inserted, $spliced) = $w->SUPER::historyAdd($string, -spliceinfo => 1);
434    if (defined $inserted) {
435	if ($spliced) {
436	    $w->history([ $w->SUPER::history ]);
437	} else {
438	    $w->_listbox_method("insert", 'end', $inserted);
439	    # XXX Obeying -limit also for the array itself?
440	    if (defined $w->cget(-limit) &&
441		$w->_listbox_method("size") > $w->cget(-limit)) {
442		$w->_listbox_method("delete", 0);
443	    }
444	}
445	$w->_listbox_method("see", 'end');
446	return $inserted;
447    }
448    undef;
449}
450*addhistory = \&historyAdd;
451
452sub history {
453    my($w, $history) = @_;
454    if (defined $history) {
455	$w->_listbox_method("delete", 0, 'end');
456	$w->_listbox_method("insert", 'end', @$history);
457	$w->_listbox_method("see", 'end');
458    }
459    $w->SUPER::history($history);
460}
461
4621;
463
464=head1 NAME
465
466Tk::HistEntry - Entry widget with history capability
467
468=head1 SYNOPSIS
469
470    use Tk::HistEntry;
471
472    $hist1 = $top->HistEntry(-textvariable => \$var1);
473    $hist2 = $top->SimpleHistEntry(-textvariable => \$var2);
474
475=head1 DESCRIPTION
476
477C<Tk::HistEntry> defines entry widgets with history capabilities. The widgets
478come in two flavours:
479
480=over 4
481
482=item C<HistEntry> (in package C<Tk::HistEntry::Browse>) - with associated
483browse entry
484
485=item C<SimpleHistEntry> (in package C<Tk::HistEntry::Simple>) - plain widget
486without browse entry
487
488=back
489
490The user may browse with the B<Up> and B<Down> keys through the history list.
491New history entries may be added either manually by binding the
492B<Return> key to B<historyAdd()> or
493automatically by setting the B<-command> option.
494
495=head1 OPTIONS
496
497B<HistEntry> is an descendant of B<BrowseEntry> and thus supports all of its
498standard options.
499
500B<SimpleHistEntry> is an descendant of B<Entry> and supports all of the
501B<Entry> options.
502
503In addition, the widgets support following specific options:
504
505=over 4
506
507=item B<-textvariable> or B<-variable>
508
509Variable which is tied to the HistEntry widget. Either B<-textvariable> (like
510in Entry) or B<-variable> (like in BrowseEntry) may be used.
511
512=item B<-command>
513
514Specifies a callback, which is executed when the Return key was pressed or
515the B<invoke> method is called. The callback reveives three arguments:
516the reference to the HistEntry widget, the current textvariable value and
517a boolean value, which tells whether the string was added to the history
518list (e.g. duplicates and empty values are not added to the history list).
519
520=item B<-dup>
521
522Specifies whether duplicate entries are allowed in the history list. Defaults
523to true.
524
525=item B<-bell>
526
527If set to true, rings the bell if the user tries to move off of the history
528or if a search was not successful. Defaults to true.
529
530=item B<-limit>
531
532Limits the number of history entries. Defaults to unlimited.
533
534=item B<-match>
535
536Turns auto-completion on.
537
538=item B<-case>
539
540If set to true a true value, then be case sensitive on
541auto-completion. Defaults to 1.
542
543=back
544
545=head1 METHODS
546
547=over 4
548
549=item B<historyAdd(>[I<string>]B<)>
550
551Adds string (or the current textvariable value if not set) manually to the
552history list. B<addhistory> is an alias for B<historyAdd>. Returns the
553added string or undef if no addition was made.
554
555=item B<invoke(>[I<string>]B<)>
556
557Invokes the command specified with B<-command>.
558
559=item B<history(>[I<arrayref>]B<)>
560
561Without argument, returns the current history list. With argument (a
562reference to an array), replaces the history list.
563
564=item B<historySave(>I<file>B<)>
565
566Save the history list to the named file.
567
568=item B<historyMergeFromFile(>I<file>B<)>
569
570Merge the history list from the named file to the end of the current
571history list of the widget.
572
573=item B<historyReset>
574
575Remove all entries from the history list.
576
577=back
578
579=head1 KEY BINDINGS
580
581=over 4
582
583=item B<Up>, B<Control-p>
584
585Selects the previous history entry.
586
587=item B<Down>, B<Control-n>
588
589Selects the next history entry.
590
591=item B<Meta-E<lt>>, B<Alt-E<lt>>
592
593Selects first entry.
594
595=item B<Meta-E<gt>>, B<Alt-E<gt>>
596
597Selects last entry.
598
599=item B<Control-r>
600
601The current content of the widget is searched backward in the history.
602
603=item B<Control-s>
604
605The current content of the widget is searched forward in the history.
606
607=item B<Return>
608
609If B<-command> is set, adds current content to the history list and
610executes the associated callback.
611
612=back
613
614=head1 EXAMPLE
615
616This is an simple example for Tk::HistEntry. More examples can be
617found in the t and examples directories of the source distribution.
618
619    use Tk;
620    use Tk::HistEntry;
621
622    $top = new MainWindow;
623    $he = $top->HistEntry(-textvariable => \$foo,
624                          -command => sub {
625                              # automatically adds $foo to history
626                              print STDERR "Do something with $foo\n";
627                          })->pack;
628    $b = $top->Button(-text => 'Do it',
629                      -command => sub { $he->invoke })->pack;
630    MainLoop;
631
632If you like to not depend on the installation of Tk::HistEntry, you
633can write something like this:
634
635    $Entry = "Entry"; # default Entry widget
636    eval {
637        # try loading the module, otherwise $Entry is left to the value "Entry"
638	require Tk::HistEntry;
639	$Entry = "SimpleHistEntry";
640    };
641    $entry = $mw->$Entry(-textvariable => \$res)->pack;
642    $entry->bind("<Return>" => sub {
643                                   # check whether the historyAdd method is
644		                   # known to the widget
645		                   if ($entry->can('historyAdd')) {
646				       $entry->historyAdd;
647				   }
648                               });
649
650In this approach the history lives in an array variable. Here the
651entry widget does not need to be permanent, that is, it is possible to
652destroy the containing window and restore the history again:
653
654    $Entry = "Entry";
655    eval {
656	require Tk::HistEntry;
657        $Entry = "HistEntry";
658    };
659    $entry = $mw->$Entry(-textvariable => \$res)->pack;
660    if ($entry->can('history') && @history) {
661	$entry->history(\@history);
662    }
663
664    # Later, after clicking on a hypothetical "Ok" button:
665    if ($res ne "" && $entry->can('historyAdd')) {
666        $entry->historyAdd($res);
667	@history = $entry->history;
668    }
669
670
671=head1 BUGS/TODO
672
673 - C-s/C-r do not work as nice as in gnu readline
674 - use -browsecmd from Tk::BrowseEntry
675 - use Tie::Array if present
676
677=head1 AUTHOR
678
679Slaven Rezic <slaven@rezic.de>
680
681=head1 CREDITS
682
683Thanks for Jason Smith <smithj4@rpi.edu> and Benny Khoo
684<kkhoo1@penang.intel.com> for their suggestions. The auto-completion
685code is stolen from Tk::IntEntry by Dave Collins
686<Dave.Collins@tiuk.ti.com>.
687
688=head1 COPYRIGHT
689
690Copyright (c) 1997, 2000, 2001, 2003, 2008, 2016, 2017 Slaven Rezic. All rights reserved.
691This package is free software; you can redistribute it and/or
692modify it under the same terms as Perl itself.
693
694=cut
695