view release on metacpan or  search on metacpan

HistEntry.pm  view on Meta::CPAN

    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(@_) }