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