Tk-HistEntry-0.43000751 001750 001750 00000000000 10560706160 014503 5ustar00eserteeserte000000 000000 Tk-HistEntry-0.43/t000751 001750 001750 00000000000 10560706160 014746 5ustar00eserteeserte000000 000000 Tk-HistEntry-0.43/Changes000444 001750 001750 00000002652 10560704221 016060 0ustar00eserteeserte000000 000000 Revision history for Perl extension Tk::HistEntry. 0.43 - no code changes, just fixed a possibly failing test (depending on setting of window focus) 0.42 - fixed a failing test (it was a delegation problem) 0.41 - just a Pod example fix 0.40 - ->class() now returns more meaningful names: SimpleHistEntry and HistEntry - do not do auto-completion if typing _before_ the cursor - new -history option (like history method, with tests) 0.37 - fixed bug in historyAdd of Browse version of HistEntry 0.36 - new -case option - fixed Control- handling when -match is on 0.35 - insert, delete and get is now delegated to the Entry subwidget 0.34 - fixed test scripts - another example in the pod 0.33 - bug fix: Home, End and Delete did not work in -match mode 0.32 - new methods historySave and historyMergeFromFile 0.31 - bugfix solving disappearing leading characters 0.30 - using auto-completion (code stolen from Dave Collins), if option -match is set 0.22 - bug fix in t/newclass.t 0.21 - bug fixes for Tk::HistEntry::Browse - new bindings M-< and M-> 0.20 - split Tk::HistEntry into Tk::HistEntry::Simple and Tk::HistEntry::Browse - new options: -dup, -limit, -bell, -command - new methods: invoke, history - some fixes - POD 0.10 Mon Dec 8 03:07:00 1997 - using Tk::BrowseEntry as base class instead of Tk::Entry 0.01 Sat Dec 6 17:43:45 1997 - original version Tk-HistEntry-0.43/HistEntry.pm000444 001750 001750 00000041555 10560477537 017102 0ustar00eserteeserte000000 000000 # -*- perl -*- # # $Id: HistEntry.pm,v 1.30 2007/02/02 00:01:35 eserte Exp $ # Author: Slaven Rezic # # Copyright © 1997, 2000, 2001, 2003 Slaven Rezic. All rights reserved. # This package is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: slaven@rezic.de # WWW: http://www.cs.tu-berlin.de/~eserte/ # package Tk::HistEntry; require Tk; use strict; use vars qw($VERSION); $VERSION = '0.43'; sub addBind { my $w = shift; $w->_entry->bind('' => sub { $w->historyUp }); $w->_entry->bind('' => sub { $w->historyUp }); $w->_entry->bind('' => sub { $w->historyDown }); $w->_entry->bind('' => sub { $w->historyDown }); $w->_entry->bind('' => sub { $w->historyBegin }); $w->_entry->bind('' => sub { $w->historyBegin }); $w->_entry->bind('' => sub { $w->historyEnd }); $w->_entry->bind('' => sub { $w->historyEnd }); $w->_entry->bind('' => sub { $w->searchBack }); $w->_entry->bind('' => sub { $w->searchForw }); $w->_entry->bind('' => sub { if ($w->cget(-command) || $w->cget(-auto)) { $w->invoke; } }); $w->_entry->bind('', sub { my $e = $_[0]->XEvent; $w->KeyPress($e->K, $e->s); }); } # XXX del: # sub _isdup { # my($w, $string) = @_; # foreach (@{ $w->privateData->{'history'} }) { # return 1 if $_ eq $string; # } # 0; # } sub _update { my($w, $string) = @_; $w->_entry->delete(0, 'end'); $w->_entry->insert('end', $string); } sub _entry { my $w = shift; $w->Subwidget('entry') ? $w->Subwidget('entry') : $w; } sub _listbox { my $w = shift; $w->Subwidget('slistbox') ? $w->Subwidget('slistbox') : $w; } sub _listbox_method { my $w = shift; my $meth = shift; if ($w->_has_listbox) { $w->_listbox->$meth(@_); } } sub _has_listbox { $_[0]->Subwidget('slistbox') } sub historyAdd { my($w, $string, %args) = @_; $string = $w->_entry->get unless defined $string; return undef if !defined $string || $string eq ''; my $history = $w->privateData->{'history'}; if (!@$history or $string ne $history->[-1]) { my $spliced = 0; if (!$w->cget(-dup)) { for(my $i = 0; $i<=$#$history; $i++) { if ($string eq $history->[$i]) { splice @$history, $i, 1; $spliced++; last; } } } push @$history, $string; if (defined $w->cget(-limit) && @$history > $w->cget(-limit)) { shift @$history; } $w->privateData->{'historyindex'} = $#$history + 1; my @ret = $string; if ($args{-spliceinfo}) { push @ret, $spliced; } return @ret; } undef; } # compatibility with Term::ReadLine *addhistory = \&historyAdd; sub historyUpdate { my $w = shift; $w->_update($w->privateData->{'history'}->[$w->privateData->{'historyindex'}]); $w->_entry->icursor('end'); # suggestion by Jason Smith $w->_entry->xview('insert'); } sub historyUp { my $w = shift; if ($w->privateData->{'historyindex'} > 0) { $w->privateData->{'historyindex'}--; $w->historyUpdate; } else { $w->_bell; } } sub historyDown { my $w = shift; if ($w->privateData->{'historyindex'} <= $#{$w->privateData->{'history'}}) { $w->privateData->{'historyindex'}++; $w->historyUpdate; } else { $w->_bell; } } sub historyBegin { my $w = shift; $w->privateData->{'historyindex'} = 0; $w->historyUpdate; } sub historyEnd { my $w = shift; $w->privateData->{'historyindex'} = $#{$w->privateData->{'history'}}; $w->historyUpdate; } sub historySet { my($w, $index) = @_; my $i; my $history_ref = $w->privateData->{'history'}; for($i = $#{ $history_ref }; $i >= 0; $i--) { if ($index eq $history_ref->[$i]) { $w->privateData->{'historyindex'} = $i; last; } } } sub historyReset { my $w = shift; $w->privateData->{'history'} = []; $w->privateData->{'historyindex'} = 0; $w->_listbox_method("delete", 0, "end"); } sub historySave { my($w, $file) = @_; open(W, ">$file") or die "Can't save to file $file"; print W join("\n", $w->history) . "\n"; close W; } # XXX document sub historyMergeFromFile { my($w, $file) = @_; if (open(W, "<$file")) { while() { chomp; $w->historyAdd($_); } close W; } } sub history { my($w, $history) = @_; if (defined $history) { $w->privateData->{'history'} = [ @$history ]; $w->privateData->{'historyindex'} = $#{$w->privateData->{'history'}} + 1; } @{ $w->privateData->{'history'} }; } sub searchBack { my $w = shift; my $i = $w->privateData->{'historyindex'}-1; while ($i >= 0) { my $search = $w->_entry->get; if ($search eq substr($w->privateData->{'history'}->[$i], 0, length($search))) { $w->privateData->{'historyindex'} = $i; $w->_update($w->privateData->{'history'}->[$w->privateData->{'historyindex'}]); return; } $i--; } $w->_bell; } sub searchForw { my $w = shift; my $i = $w->privateData->{'historyindex'}+1; while ($i <= $#{$w->privateData->{'history'}}) { my $search = $w->_entry->get; if ($search eq substr($w->privateData->{'history'}->[$i], 0, length($search))) { $w->privateData->{'historyindex'} = $i; $w->_update($w->privateData->{'history'}->[$w->privateData->{'historyindex'}]); return; } $i++; } $w->_bell; } sub invoke { my($w, $string) = @_; $string = $w->_entry->get if !defined $string; return unless defined $string; my $added = defined $w->historyAdd($string); $w->Callback(-command => $w, $string, $added); } sub _bell { my $w = shift; return unless $w->cget(-bell); $w->bell; } sub KeyPress { my($w, $key, $state) = @_; my $e = $w->_entry; my(@history) = reverse $w->history; $w->{end} = $#history; # XXXXXXXX? return if ($key =~ /^Shift|^Control|^Left|^Right|^Home|^End/); return if ($state =~ /^Control-/); if ($key eq 'Tab') { # Tab doesn't trigger FocusOut event so clear selection $e->selection('clear'); return; } return if (!$w->cget(-match)); $e->update; my $cursor = $e->index('insert'); if ($key eq 'BackSpace' or $key eq 'Delete') { $w->{start} = 0; $w->{end} = $#history; return; } my $text = $e->get; ###Grab test from entry upto cursor (my $typedtext = $text) =~ s/^(.{$cursor})(.*)/$1/; if ($2 ne "") { ###text after cursor, do not use matching return; } if ($cursor == 0 || $text eq '') { ###No text before cursor, reset list $w->{start} = 0; $w->{end} = $#history; $e->delete(0, 'end'); $e->insert(0,''); } else { my $start = $w->{start}; my $end = $w->{end}; my ($newstart, $newend); ###Locate start of matching & end of matching my $caseregex = ($w->cget(-case) ? "(?i)" : ""); for (; $start <= $end; $start++) { if ($history[$start] =~ /^$caseregex\Q$typedtext\E/) { $newstart = $start if (!defined $newstart); $newend = $start; } else { last if (defined $newstart); } } if (defined $newstart) { $e->selection('clear'); $e->delete(0, 'end'); $e->insert(0, $history[$newstart]); $e->selection('range',$cursor,'end'); $e->icursor($cursor); $w->{start} = $newstart; $w->{end} = $newend; } else { $w->{end} = -1; } } } ###################################################################### package Tk::HistEntry::Simple; require Tk::Entry; use vars qw(@ISA); @ISA = qw(Tk::Derived Tk::Entry Tk::HistEntry); #use base qw(Tk::Derived Tk::Entry Tk::HistEntry); Construct Tk::Widget 'SimpleHistEntry'; sub CreateArgs { my($package, $parent, $args) = @_; $args->{-class} = "SimpleHistEntry" unless exists $args->{-class}; $package->SUPER::CreateArgs($parent, $args); } sub Populate { my($w, $args) = @_; $w->historyReset; $w->SUPER::Populate($args); $w->Advertise(entry => $w); $w->{start} = 0; $w->{end} = 0; $w->addBind; $w->ConfigSpecs (-command => ['CALLBACK', 'command', 'Command', undef], -auto => ['PASSIVE', 'auto', 'Auto', 0], -dup => ['PASSIVE', 'dup', 'Dup', 1], -bell => ['PASSIVE', 'bell', 'Bell', 1], -limit => ['PASSIVE', 'limit', 'Limit', undef], -match => ['PASSIVE', 'match', 'Match', 0], -case => ['PASSIVE', 'case', 'Case', 1], -history => ['METHOD'], ); $w; } ###################################################################### package Tk::HistEntry::Browse; require Tk::BrowseEntry; use vars qw(@ISA); @ISA = qw(Tk::Derived Tk::BrowseEntry Tk::HistEntry); #use base qw(Tk::Derived Tk::BrowseEntry Tk::HistEntry); Construct Tk::Widget 'HistEntry'; sub CreateArgs { my($package, $parent, $args) = @_; $args->{-class} = "HistEntry" unless exists $args->{-class}; $package->SUPER::CreateArgs($parent, $args); } sub Populate { my($w, $args) = @_; $w->historyReset; if ($Tk::VERSION >= 800) { $w->SUPER::Populate($args); } else { my $saveargs; foreach (qw(-auto -command -dup -bell -limit -match -case)) { if (exists $args->{$_}) { $saveargs->{$_} = delete $args->{$_}; } } $w->SUPER::Populate($args); foreach (keys %$saveargs) { $args->{$_} = $saveargs->{$_}; } } $w->addBind; $w->{start} = 0; $w->{end} = 0; my $entry = $w->Subwidget('entry'); $w->ConfigSpecs (-command => ['CALLBACK', 'command', 'Command', undef], -auto => ['PASSIVE', 'auto', 'Auto', 0], -dup => ['PASSIVE', 'dup', 'Dup', 1], -bell => ['PASSIVE', 'bell', 'Bell', 1], -limit => ['PASSIVE', 'limit', 'Limit', undef], -match => ['PASSIVE', 'match', 'Match', 0], -case => ['PASSIVE', 'case', 'Case', 1], -history => ['METHOD'], ); ## Delegation does not work with the new BrowseEntry --- it seems to me ## that delegation only works for composites, not for derivates # $w->Delegates('delete' => $entry, # 'get' => $entry, # 'insert' => $entry, # ); $w; } sub delete { shift->Subwidget('entry')->delete(@_) } sub get { shift->Subwidget('entry')->get (@_) } sub insert { shift->Subwidget('entry')->insert(@_) } sub historyAdd { my($w, $string) = @_; my($inserted, $spliced) = $w->SUPER::historyAdd($string, -spliceinfo => 1); if (defined $inserted) { if ($spliced) { $w->history([ $w->SUPER::history ]); } else { $w->_listbox_method("insert", 'end', $inserted); # XXX Obeying -limit also for the array itself? if (defined $w->cget(-limit) && $w->_listbox_method("size") > $w->cget(-limit)) { $w->_listbox_method("delete", 0); } } $w->_listbox_method("see", 'end'); return $inserted; } undef; } *addhistory = \&historyAdd; sub history { my($w, $history) = @_; if (defined $history) { $w->_listbox_method("delete", 0, 'end'); $w->_listbox_method("insert", 'end', @$history); $w->_listbox_method("see", 'end'); } $w->SUPER::history($history); } 1; =head1 NAME Tk::HistEntry - Entry widget with history capability =head1 SYNOPSIS use Tk::HistEntry; $hist1 = $top->HistEntry(-textvariable => \$var1); $hist2 = $top->SimpleHistEntry(-textvariable => \$var2); =head1 DESCRIPTION C defines entry widgets with history capabilities. The widgets come in two flavours: =over 4 =item C (in package C) - with associated browse entry =item C (in package C) - plain widget without browse entry =back The user may browse with the B and B keys through the history list. New history entries may be added either manually by binding the B key to B or automatically by setting the B<-command> option. =head1 OPTIONS B is an descendant of B and thus supports all of its standard options. B is an descendant of B and supports all of the B options. In addition, the widgets support following specific options: =over 4 =item B<-textvariable> or B<-variable> Variable which is tied to the HistEntry widget. Either B<-textvariable> (like in Entry) or B<-variable> (like in BrowseEntry) may be used. =item B<-command> Specifies a callback, which is executed when the Return key was pressed or the B method is called. The callback reveives three arguments: the reference to the HistEntry widget, the current textvariable value and a boolean value, which tells whether the string was added to the history list (e.g. duplicates and empty values are not added to the history list). =item B<-dup> Specifies whether duplicate entries are allowed in the history list. Defaults to true. =item B<-bell> If set to true, rings the bell if the user tries to move off of the history or if a search was not successful. Defaults to true. =item B<-limit> Limits the number of history entries. Defaults to unlimited. =item B<-match> Turns auto-completion on. =item B<-case> If set to true a true value, then be case sensitive on auto-completion. Defaults to 1. =back =head1 METHODS =over 4 =item B[I]B<)> Adds string (or the current textvariable value if not set) manually to the history list. B is an alias for B. Returns the added string or undef if no addition was made. =item B[I]B<)> Invokes the command specified with B<-command>. =item B[I]B<)> Without argument, returns the current history list. With argument (a reference to an array), replaces the history list. =item BIB<)> Save the history list to the named file. =item BIB<)> Merge the history list from the named file to the end of the current history list of the widget. =item B Remove all entries from the history list. =back =head1 KEY BINDINGS =over 4 =item B, B Selects the previous history entry. =item B, B Selects the next history entry. =item B>, B> Selects first entry. =item B>, B> Selects last entry. =item B The current content of the widget is searched backward in the history. =item B The current content of the widget is searched forward in the history. =item B If B<-command> is set, adds current content to the history list and executes the associated callback. =back =head1 EXAMPLE This is an simple example for Tk::HistEntry. More examples can be found in the t and examples directories of the source distribution. use Tk; use Tk::HistEntry; $top = new MainWindow; $he = $top->HistEntry(-textvariable => \$foo, -command => sub { # automatically adds $foo to history print STDERR "Do something with $foo\n"; })->pack; $b = $top->Button(-text => 'Do it', -command => sub { $he->invoke })->pack; MainLoop; If you like to not depend on the installation of Tk::HistEntry, you can write something like this: $Entry = "Entry"; # default Entry widget eval { # try loading the module, otherwise $Entry is left to the value "Entry" require Tk::HistEntry; $Entry = "SimpleHistEntry"; }; $entry = $mw->$Entry(-textvariable => \$res)->pack; $entry->bind("" => sub { # check whether the historyAdd method is # known to the widget if ($entry->can('historyAdd')) { $entry->historyAdd; } }); In this approach the history lives in an array variable. Here the entry widget does not need to be permanent, that is, it is possible to destroy the containing window and restore the history again: $Entry = "Entry"; eval { require Tk::HistEntry; $Entry = "HistEntry"; }; $entry = $mw->$Entry(-textvariable => \$res)->pack; if ($entry->can('history') && @history) { $entry->history(\@history); } # Later, after clicking on a hypothetical "Ok" button: if ($res ne "" && $entry->can('historyAdd')) { $entry->historyAdd($res); @history = $entry->history; } =head1 BUGS/TODO - C-s/C-r do not work as nice as in gnu readline - use -browsecmd from Tk::BrowseEntry - use Tie::Array if present =head1 AUTHOR Slaven Rezic =head1 CREDITS Thanks for Jason Smith and Benny Khoo for their suggestions. The auto-completion code is stolen from Tk::IntEntry by Dave Collins . =head1 COPYRIGHT Copyright (c) 1997, 2000, 2001, 2003 Slaven Rezic. All rights reserved. This package is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Tk-HistEntry-0.43/MANIFEST000644 001750 001750 00000000317 10560706160 015720 0ustar00eserteeserte000000 000000 Changes HistEntry.pm MANIFEST Makefile.PL README examples/1.pl examples/newclass.pl t/basic.t t/newclass.t t/match.t t/invoke.t META.yml Module meta-data (added by MakeMaker) Tk-HistEntry-0.43/examples000751 001750 001750 00000000000 10560706160 016321 5ustar00eserteeserte000000 000000 Tk-HistEntry-0.43/Makefile.PL000555 001750 001750 00000001450 07756263172 016557 0ustar00eserteeserte000000 000000 # -*- perl -*- use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Tk::HistEntry', 'VERSION_FROM' => 'HistEntry.pm', # finds $VERSION 'dist' => {'POSTOP'=>'-$(CHMOD) 644 $(DISTVNAME).tar$(SUFFIX)'}, 'PREREQ_PM' => {'Tk' => 0}, ); sub MY::postamble { my $postamble = <<'EOF'; demo :: pure_all $(FULLPERL) -w -I$(SITELIBEXP)/Tk/demos/widget_lib -Mblib examples/1.pl $(FULLPERL) -w -I$(SITELIBEXP)/Tk/demos/widget_lib -Mblib examples/newclass.pl EOF if (defined $ENV{USER} && $ENV{USER} eq 'eserte' && $^O =~ /bsd/i && -f "../../perl.release.mk") { $postamble .= <<'EOF'; .include "../../perl.release.mk" .include "../../perl.cvs.mk" EOF } $postamble; } Tk-HistEntry-0.43/README000444 001750 001750 00000001530 07712517221 015446 0ustar00eserteeserte000000 000000 Tk::HistEntry Module Tk::HistEntry implements an entry widget with history. You may use the up and down keys to select older entries (or use the associated listbox). Usage: $top->HistEntry(-textvariable => \$foo, -command => sub { # automatically adds $foo to history print STDERR "Do something with $foo\n"; })->pack; The widget comes in two flavors: the "HistEntry" widget is an inherited BrowseEntry widget where you see history in the associated listbox, too. The "SimpleHistEntry" widget is a plain Entry widget. To install, type $ perl Makefile.PL $ make $ make install Testing is done with $ make test There's also a demo which can be started with $ make demo Send bug reports, comments and suggestions to Slaven Rezic . Tk-HistEntry-0.43/META.yml000660 001750 001750 00000000537 10560706160 016042 0ustar00eserteeserte000000 000000 --- #YAML:1.0 name: Tk-HistEntry version: 0.43 abstract: ~ license: ~ generated_by: ExtUtils::MakeMaker version 6.31 distribution_type: module requires: Tk: 0 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 Tk-HistEntry-0.43/examples/newclass.pl000555 001750 001750 00000004777 06530513164 020602 0ustar00eserteeserte000000 000000 #!/usr/local/bin/perl -w # -*- perl -*- # # $Id: newclass.pl,v 1.2 1998/05/20 08:38:12 eserte Exp $ # Author: Slaven Rezic # # Copyright (C) 1997,1998 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: eserte@cs.tu-berlin.de # WWW: http://user.cs.tu-berlin.de/~eserte/ # use Tk; use Tk::HistEntry; use Tk::FireButton; use strict; package MyHistEntry; @MyHistEntry::ISA = qw(Tk::Frame); Construct Tk::Widget 'MyHistEntry'; { my $foo = $Tk::FireButton::INCBITMAP; $foo = $Tk::FireButton::DECBITMAP; } sub Populate { my($f, $args) = @_; my $e = $f->Component(SimpleHistEntry => 'entry'); my $binc = $f->Component( FireButton => 'inc', -bitmap => $Tk::FireButton::INCBITMAP, -command => sub { $e->historyUp }, ); my $bdec = $f->Component( FireButton => 'dec', -bitmap => $Tk::FireButton::DECBITMAP, -command => sub { $e->historyDown }, ); $f->gridColumnconfigure(0, -weight => 1); $f->gridColumnconfigure(1, -weight => 0); $f->gridRowconfigure(0, -weight => 1); $f->gridRowconfigure(1, -weight => 1); $binc->grid(-row => 0, -column => 1, -sticky => 'news'); $bdec->grid(-row => 1, -column => 1, -sticky => 'news'); $e->grid(-row => 0, -column => 0, -rowspan => 2, -sticky => 'news'); $f->ConfigSpecs (-repeatinterval => ['CHILDREN', "repeatInterval", "RepeatInterval", 100 ], -repeatdelay => ['CHILDREN', "repeatDelay", "RepeatDeleay", 300 ], DEFAULT => [$e], ); $f->Delegates(DEFAULT => $e); $f; } package main; my $top = new MainWindow; my($bla); my($b2, $lb2); $b2 = $top->MyHistEntry(-textvariable => \$bla, -repeatinterval => 30, -bell => 1, -dup => 1, -command => sub { my($w, $s, $added) = @_; if ($added) { $lb2->insert('end', $s); $lb2->see('end'); } $bla = ''; })->pack; $lb2 = $top->Scrolled('Listbox', -scrollbars => 'osoe' )->pack; # # Autodestroy # my $seconds = 60; # my $autodestroy_text = "Autodestroy in " . $seconds . "s\n"; # $top->Label(-textvariable => \$autodestroy_text, # )->pack; # $top->repeat(1000, sub { if ($seconds <= 0) { $top->destroy } # $seconds--; # $autodestroy_text = "Autodestroy in " . $seconds # . "s\n"; # }); $top->Button(-text => 'Exit', -command => sub { $top->destroy }, )->pack; MainLoop; Tk-HistEntry-0.43/examples/1.pl000555 001750 001750 00000005645 06674250444 017126 0ustar00eserteeserte000000 000000 #!/usr/local/bin/perl -w # -*- perl -*- # # $Id: 1.pl,v 1.8 1998/08/28 00:41:44 eserte Exp $ # Author: Slaven Rezic # # Copyright (C) 1997,1998 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: eserte@cs.tu-berlin.de # WWW: http://user.cs.tu-berlin.de/~eserte/ # use Tk; use Tk::HistEntry; use strict; my $top = new MainWindow; my($foo, $bla, $blubber); my $f = $top->Frame->grid(-row => 0, -column => 0, -sticky => 'n'); my $lb = $top->Scrolled('Listbox', -scrollbars => 'osoe' )->grid(-row => 0, -column => 1); $f->Label(-text => 'HistEntry')->pack; my $b = $f->HistEntry(-textvariable => \$foo)->pack; my $bb = $f->Button(-text => 'Add current', -command => sub { return unless $foo; $b->historyAdd($foo); $lb->delete(0, 'end'); foreach ($b->history) { $lb->insert('end', $_); } $lb->see('end'); $foo = ''; })->pack; $f->Button(-text => 'Replace history', -command => sub { $b->history([keys %ENV]); } )->pack; $b->bind('' => sub { $bb->invoke }); my $f2 = $top->Frame->grid(-row => 1, -column => 0, -sticky => 'n'); my $lb2 = $top->Scrolled('Listbox', -scrollbars => 'osoe' )->grid(-row => 1, -column => 1); $f2->Label(-text => 'HistEntry with invoke, limit ...')->pack; my $b2; $b2 = $f2->HistEntry(-textvariable => \$bla, -match => 1, -label => 'Test label', -labelPack => [-side => 'left'], -width => 10, -bell => 0, -dup => 0, -limit => 6, -command => sub { my $w = shift; # automatic historyAdd $lb2->delete(0, 'end'); foreach ($b2->history) { $lb2->insert('end', $_); } $lb2->see('end'); })->pack; #XXX$b2->configure(-match => 1);#XXX $f2->Button(-text => 'Add current', -command => sub { $b2->invoke })->pack; my $f3 = $top->Frame->grid(-row => 2, -column => 0, -sticky => 'n'); my $lb3 = $top->Scrolled('Listbox', -scrollbars => 'osoe' )->grid(-row => 2, -column => 1); $f3->Label(-text => 'SimpleHistEntry')->pack; my $b3 = $f3->SimpleHistEntry(-textvariable => \$blubber, -command => sub { my($w, $line, $added) = @_; if ($added) { $lb3->insert('end', $line); $lb3->see('end'); } $blubber = ''; })->pack; $f3->Button(-text => 'Add current', -command => sub { $b3->invoke })->pack; # # Autodestroy # my $seconds = 60; # my $autodestroy_text = "Autodestroy in " . $seconds . "s\n"; # $top->Label(-textvariable => \$autodestroy_text, # )->grid(-row => 99, -column => 0, -columnspan => 2); # $top->repeat(1000, sub { if ($seconds <= 0) { $top->destroy } # $seconds--; # $autodestroy_text = "Autodestroy in " . $seconds # . "s\n"; # }); $top->Button(-text => 'Exit', -command => sub { $top->destroy }, )->grid(-row => 99, -column => 0, -columnspan => 2); MainLoop; Tk-HistEntry-0.43/t/match.t000555 001750 001750 00000002731 10560703677 016330 0ustar00eserteeserte000000 000000 # -*- perl -*- # # $Id: match.t,v 1.4 2007/02/02 18:49:35 eserte Exp $ # Author: Slaven Rezic # # Copyright (C) 1997,1998,2007 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: eserte@cs.tu-berlin.de # WWW: http://user.cs.tu-berlin.de/~eserte/ # BEGIN { if (!eval q{ use Test::More; 1; }) { print "1..0 # skip: no Test::More module\n"; exit; } } use Tk; use Tk::HistEntry; use strict; plan tests => 4; my $top = new MainWindow; $top->geometry($top->screenwidth . "x" .$top->screenheight . "+0+0"); my $he = $top->HistEntry(-match => 1, )->pack; isa_ok($he, "Tk::HistEntry"); $he->addhistory('Foo'); $he->addhistory('Bar'); my $e = $he->_entry; isa_ok($e, "Tk::LabEntry"); my $focus_e = $e->Subwidget("entry"); $e->focus; $e->update; eval { $e->event('generate', '', -keysym => 'F'); $e->event('generate', '', -keysym => 'o'); $e->update; }; SKIP: { skip("Focus lost? $@", 1) if $@; skip("Focus lost!", 1) if ($top->focusCurrent||"") ne $focus_e; is($e->get, 'Foo', "Expected first entry"); } { local $TODO = "Rethink BackSpace behavior..."; eval { $e->event('generate', '', -keysym => 'BackSpace'); $e->update; }; SKIP: { skip("Focus lost? $@", 1) if $@; skip("Focus lost!", 1) if ($top->focusCurrent||"") ne $focus_e; is($e->get, 'F', 'Only one character entered'); } } #MainLoop; Tk-HistEntry-0.43/t/newclass.t000555 001750 001750 00000011325 07712517053 017046 0ustar00eserteeserte000000 000000 # -*- perl -*- # # $Id: newclass.t,v 1.9 2003/08/01 17:06:51 eserte Exp $ # Author: Slaven Rezic # # Copyright (C) 1997,1998 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: eserte@cs.tu-berlin.de # WWW: http://user.cs.tu-berlin.de/~eserte/ # BEGIN { $^W = 1; $| = 1; $loaded = 0; $last = 15; print "1..$last\n"; } END {print "not ok 1\n" unless $loaded;} use Tk::HistEntry; use strict; use vars qw($loaded $last $VISUAL); $loaded = 1; $VISUAL = $ENV{PERL_TEST_INTERACTIVE}; my $ok = 1; print "ok " . $ok++ . "\n"; use Tk; my $top = new MainWindow; eval { require Tk::FireButton; $top->event('generate', ''); die "event generate is working different on Win32" if $^O eq 'MSWin32'; }; if ($@) { print "ok " . $ok++ . " # Skipping this test (Tk::FireButton and/or event missing)\n"; for ($ok .. $last) { print "ok # Skipping...\n"; } exit; } package MyHistEntry; @MyHistEntry::ISA = qw(Tk::Frame); Construct Tk::Widget 'MyHistEntry'; { my $foo = $Tk::FireButton::INCBITMAP; $foo = $Tk::FireButton::DECBITMAP; } sub Populate { my($f, $args) = @_; my $e = $f->Component(SimpleHistEntry => 'entry'); my $binc = $f->Component( FireButton => 'inc', -bitmap => $Tk::FireButton::INCBITMAP, -command => sub { $e->historyUp }, ); my $bdec = $f->Component( FireButton => 'dec', -bitmap => $Tk::FireButton::DECBITMAP, -command => sub { $e->historyDown }, ); $f->gridColumnconfigure(0, -weight => 1); $f->gridColumnconfigure(1, -weight => 0); $f->gridRowconfigure(0, -weight => 1); $f->gridRowconfigure(1, -weight => 1); $binc->grid(-row => 0, -column => 1, -sticky => 'news'); $bdec->grid(-row => 1, -column => 1, -sticky => 'news'); $e->grid(-row => 0, -column => 0, -rowspan => 2, -sticky => 'news'); $f->ConfigSpecs (-repeatinterval => ['CHILDREN', "repeatInterval", "RepeatInterval", 100 ], -repeatdelay => ['CHILDREN', "repeatDelay", "RepeatDeleay", 300 ], DEFAULT => [$e], ); $f->Delegates(DEFAULT => $e); $f; } package main; $top->geometry($top->screenwidth . "x" .$top->screenheight . "+0+0"); my($bla); my($b2, $lb2); $b2 = $top->MyHistEntry(-textvariable => \$bla, -repeatinterval => 30, -bell => 1, -dup => 1, -command => sub { my($w, $s, $added) = @_; if ($added) { $lb2->insert('end', $s); $lb2->see('end'); } $bla = ''; })->pack; print "ok " . $ok++ . "\n"; $b2->update; print "ok " . $ok++ . "\n"; $lb2 = $top->Scrolled('Listbox', -scrollbars => 'osoe' )->pack; my $e = $b2->Subwidget('entry'); my $inc = $b2->Subwidget('inc'); my $dec = $b2->Subwidget('dec'); $e->focus; $e->insert("end", 'first'); $e->event('generate', "", -keysym => 'Return'); print ((($b2->history)[-1] eq 'first' ? "" : "not ") . "ok " . $ok++ . "\n"); my @h = $e->history; print ((@h == 1 && $h[0] eq 'first' ? "" : "not ") . "ok " . $ok++ . "\n"); $e->event('generate', "", -keysym => 'Up'); print (($e->get eq 'first' ? "" : "not ") . "ok " . $ok++ . "\n"); $e->event('generate', "", -keysym => 'Down'); print (($e->get eq '' ? "" : "not ") . "ok " . $ok++ . "\n"); $e->insert(0, 'second'); $e->event('generate', "", -keysym => 'Return'); @h = $e->history; print ((@h == 2 && $h[1] eq 'second' ? "" : "not ") . "ok " . $ok++ . "\n"); $inc->invoke; $inc->invoke; print (($e->get eq 'first' ? "" : "not ") . "ok " . $ok++ . "\n"); $dec->invoke; print (($e->get eq 'second' ? "" : "not ") . "ok " . $ok++ . "\n"); # The next two tests are disabled, because they fail on systems without # configure Alt key. $e->focus; $e->event('generate', "", -state => 8, -keysym => 'less'); #print (($e->get eq 'first' ? "" : "not ") . "ok " . $ok++ . "\n"); print "ok ". $ok++ . "\n"; $e->event('generate', "", -state => 8, -keysym => 'greater'); #print (($e->get eq 'second' ? "" : "not ") . "ok " . $ok++ . "\n"); print "ok ". $ok++ . "\n"; $e->historyAdd("third"); @h = $e->history; print ((@h == 3 && $h[2] eq 'third' ? "" : "not ") . "ok " . $ok++ . "\n"); $e->invoke("fourth"); @h = $lb2->get(0, 'end'); # only three elements (because of use of historyAdd) print ((@h == 3 && $h[2] eq 'fourth' ? "" : "not ") . "ok " . $ok++ . "\n"); $e->delete(0, 'end'); $e->insert(0, 'bla'); $e->historyAdd; @h = $e->history; print ((@h == 5 && $h[4] eq 'bla' ? "" : "not ") . "ok " . $ok++ . "\n"); my $cb = $top->Button(-text => "Ok", -command => sub { $top->destroy })->pack; $cb->focus; $top->after(30000, sub { $top->destroy }); MainLoop if $VISUAL; Tk-HistEntry-0.43/t/basic.t000555 001750 001750 00000014471 07747314332 016320 0ustar00eserteeserte000000 000000 # -*- perl -*- # # $Id: basic.t,v 1.17 2003/10/27 22:14:50 eserte Exp $ # Author: Slaven Rezic # # Copyright (C) 1997,1998 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: eserte@cs.tu-berlin.de # WWW: http://user.cs.tu-berlin.de/~eserte/ # BEGIN { $^W = 1; $| = 1; $loaded = 0; $last = 46; print "1..$last"; # if ($] >= 5.005 && $] < 5.006) { # print " todo 13;"; # } print "\n"; } END {print "not ok 1\n" unless $loaded;} use Tk::HistEntry; use strict; use vars qw($loaded $last $VISUAL); use FindBin; chdir "$FindBin::RealBin"; package main; sub _not { print "# Line " . (caller)[2] . "\n"; print "not "; } $loaded = 1; $VISUAL = $ENV{PERL_TEST_INTERACTIVE}; my $ok = 1; print "ok " . $ok++ . "\n"; use Tk; my $top = new MainWindow; my($foo, $bla); my($b1, $b2); $b1 = $top->SimpleHistEntry(-textvariable => \$foo, -bell => 1, -dup => 0, -case => 1, -auto => 1, -match => 1, )->pack; if (!Tk::Exists($b1)) { _not; } print "ok " . $ok++ . "\n"; if ($b1->class ne 'SimpleHistEntry') { _not; } print "ok " . $ok++ . "\n"; $b2 = $top->HistEntry(-textvariable => \$bla, -bell => 1, -dup => 0, -label => 'Browse:', -labelPack => [-side => 'top'], )->pack; if (!Tk::Exists($b2)) { _not; } print "ok " . $ok++ . "\n"; if ($b2->class ne 'HistEntry') { _not; } print "ok " . $ok++ . "\n"; my @test_values = qw(bla foo bar); my($b4) = $top->HistEntry->pack; foreach (@test_values) { $b4->historyAdd($_) } if (join(",", @test_values) ne join(",", $b4->history)) { _not; } print "ok " . $ok++ . "\n"; $b4->_entry->insert("end", "blubber"); $b4->addhistory(); if (join(",", @test_values, "blubber") ne join(",", $b4->history)) { _not; } print "ok " . $ok++ . "\n"; $b4->OnDestroy(sub { $b4->historySave("hist.tmp.save") }); my($b5) = $top->SimpleHistEntry->pack; foreach (@test_values) { $b5->historyAdd($_) } if (join(",", @test_values) ne join(",", $b5->history)) { _not; } print "ok " . $ok++ . "\n"; $b5->insert("end", "blubber"); $b5->addhistory(); if (join(",", @test_values, "blubber") ne join(",", $b5->history)) { _not; } print "ok " . $ok++ . "\n"; $b5->OnDestroy(sub { $b5->historySave("hist2.tmp.save") }); print "ok " . $ok++ . "\n"; foreach ($b1, $b2) { $_->update; print "ok " . $ok++ . "\n"; } foreach my $sw ($b2->Subwidget) { if ($sw->isa('Tk::LabEntry')) { foreach my $ssw ($sw->Subwidget) { if ($ssw->isa('Tk::Label')) { my $t = $ssw->cget(-text); _not if ($t ne 'Browse:'); print "ok " . $ok++ . "\n"; } } } } my $e1 = $b1->_entry; print ((defined $e1 ? "" : "not ") . "ok " . $ok++ . "\n"); my $e2 = $b2->_entry; print ((defined $e2 ? "" : "not ") . "ok " . $ok++ . "\n"); my $lb2 = $b2->_listbox; print ((defined $lb2 ? "" : "not ") . "ok " . $ok++ . "\n"); foreach ([$e1, $b1, 1], [$e2, $b2, 2]) { my($e,$b,$nr) = @$_; $e->insert(0, "first $nr"); $b->historyAdd; my @h = $b->history; print ((@h == 1 && $h[0] eq "first $nr" ? "" : "not ") . "ok " . $ok++ . "\n"); $b->historyAdd("second $nr"); @h = $b->history; print ((@h == 2 && $h[1] eq "second $nr" ? "" : "not ") . "ok " . $ok++ . "\n"); $b->addhistory("third $nr"); @h = $b->history; print ((@h == 3 && $h[2] eq "third $nr" ? "" : "not ") . "ok " . $ok++ . "\n"); if ($b eq $b2) { my $h2str1 = join(", ", $lb2->get(0, 'end')); my $h2str2 = join(", ", @h); print (($h2str1 eq $h2str2 ? "" : "not ") . "ok " . $ok++ . "\n"); } print (($b->can('addhistory') ? "" : "not") . "ok " . $ok++ . "\n"); print (($b->can('historyAdd') ? "" : "not") . "ok " . $ok++ . "\n"); } my(@oldhist) = $b4->history; $b4->destroy; my(@oldhist2) = $b5->history; $b5->destroy; # testing historyMergeFromFile for HistEntry my $b3 = $top->HistEntry; $b3->historyMergeFromFile("hist.tmp.save"); if (join(",", @oldhist) ne join(",", $b3->history)) { _not; } print "ok " . $ok++ . "\n"; unlink "hist.tmp.save"; # testing historyReset $b3->historyReset; my(@histafterreset) = $b3->history; if (@histafterreset) { _not; } print "ok " . $ok++ . "\n"; @histafterreset = $b3->_listbox->get(0, "end"); if (@histafterreset) { _not; } print "ok " . $ok++ . "\n"; # testing historyMergeFromFile for SimpleHistEntry my $b6 = $top->SimpleHistEntry; $b6->historyMergeFromFile("hist2.tmp.save"); if (join(",", @oldhist2) ne join(",", $b6->history)) { _not; } print "ok " . $ok++ . "\n"; unlink "hist2.tmp.save"; # testing historyReset for SimpleHistEntry $b6->historyReset; @histafterreset = $b6->history; if (@histafterreset) { _not; } print "ok " . $ok++ . "\n"; # testing insert/get/delete methods $b3->insert('end', "blablubber"); my $b3_got = $b3->get; if ($b3_got eq "") { _not; warn "Got <$b3_got>, expected non-empty string"; } print "ok " . $ok++ . "\n"; $b3->delete(0, 'end'); if ($b3->get ne "") { _not; } print "ok " . $ok++ . "\n"; # check duplicates foreach my $b ($b1, $b2) { my $hist_entries = 4; $b->historyAdd("foobar"); if (scalar $b->history != $hist_entries) { _not; } print "ok " . $ok++ . "\n"; $b->historyAdd("foobar"); if (scalar $b->history != $hist_entries) { _not; } print "ok " . $ok++ . "\n"; $b->historyAdd("foobar2"); $hist_entries++; if (scalar $b->history != $hist_entries) { _not; } print "ok " . $ok++ . "\n"; $b->_entry->delete(0, "end"); $b->_entry->insert(0, "foobar"); $b->historyAdd; if (scalar $b->history != $hist_entries) { _not; } print "ok " . $ok++ . "\n"; } { # check -history config option my $he = $top->SimpleHistEntry(-history => [qw(1 2 3)]); if (join(" ",$he->cget(-history)) ne "1 2 3") { _not; } print "ok " . $ok++ . "\n"; if (join(" ",$he->history) ne "1 2 3") { _not; } print "ok " . $ok++ . "\n"; my $he2 = $top->HistEntry(-history => [qw(1 2 3)]); if (join(" ",$he2->cget(-history)) ne "1 2 3") { _not; } print "ok " . $ok++ . "\n"; if (join(" ",$he2->history) ne "1 2 3") { _not; } print "ok " . $ok++ . "\n"; } $top->Button(-text => "OK", -command => sub { $top->destroy })->pack->focus; $top->after(30000, sub { $top->destroy }); MainLoop if $VISUAL; Tk-HistEntry-0.43/t/invoke.t000555 001750 001750 00000001654 07035742156 016530 0ustar00eserteeserte000000 000000 # -*- perl -*- # # $Id: invoke.t,v 1.1 1999/03/18 19:18:52 eserte Exp $ # Author: Slaven Rezic # # Copyright (C) 1997,1998 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: eserte@cs.tu-berlin.de # WWW: http://user.cs.tu-berlin.de/~eserte/ # BEGIN { $^W = 1; $| = 1; $loaded = 0; $last = 3; print "1..$last\n"; } END {print "not ok 1\n" unless $loaded;} use Tk::HistEntry; use strict; use vars qw($loaded $last); package main; $loaded = 1; my $ok = 1; print "ok " . $ok++ . "\n"; use Tk; my $top = new MainWindow; my $he = $top->HistEntry(-command => sub { }, -limit => 1)->pack; $he->invoke("aaa"); my(@h) = $he->history; if (join(",", @h) ne "aaa") { print "not "; } print "ok " . $ok++ . "\n"; $he->invoke("bbb"); @h = $he->history; if (join(",", @h) ne "bbb") { print "not "; } print "ok " . $ok++ . "\n";