more jumpables, and hit-bit bug

[p5sagit/p5-mst-13.2.git] / lib / Term / Complete.t

#!./perl

BEGIN {
	print "1..0 # Skip: not a tty\n" unless -t STDOUT;
	chdir 't' unless -d 't';
	@INC = '../lib';
}

use warnings;
use Test::More tests => 8;
use vars qw( $Term::Complete::complete $complete );

use_ok( 'Term::Complete' );

*complete = \$Term::Complete::complete;

my $in = tie *STDIN, 'FakeIn', "fro\t";
my $out = tie *STDOUT, 'FakeOut';
my @words = ( 'frobnitz', 'frobozz', 'frostychocolatemilkshakes' );

Complete('', \@words);
my $data = get_expected('fro', @words);

# there should be an \a after our word
like( $$out, qr/fro\a/, 'found bell character' );

# now remove the \a -- there should be only one
is( $out->scrub(), 1, '(single) bell removed');

# 'fro' should match all three words
like( $$out, qr/$data/, 'all three words possible' );
$out->clear();

# should only find 'frobnitz' and 'frobozz'
$in->add('frob');
Complete('', @words);
$out->scrub();
is( $$out, get_expected('frob', 'frobnitz', 'frobozz'), 'expected frob*' );
$out->clear();

# should only do 'frobozz'
$in->add('frobo');
Complete('', @words);
$out->scrub();
is( $$out, get_expected( 'frobo', 'frobozz' ), 'only frobozz possible' );
$out->clear();

# change the completion character
$complete = "!";
$in->add('frobn');
Complete('prompt:', @words);
$out->scrub();
like( $$out, qr/prompt:frobn/, 'prompt is okay' );

# now remove the prompt and we should be okay
$$out =~ s/prompt://g;
is( $$out, get_expected('frobn', 'frobnitz' ), 'works with new $complete' );

# easier than matching space characters
sub get_expected {
	my $word = shift;
	return join('.', $word, @_, $word, '.');
}

package FakeIn;

sub TIEHANDLE {
	my ($class, $text) = @_;
	$text .= "$main::complete\025";
	bless(\$text, $class);
}

sub add {
	my ($self, $text) = @_;
	$$self = $text . "$main::complete\025";
}

sub GETC {
	my $self = shift;
	return length $$self ? substr($$self, 0, 1, '') : "\r";
}

package FakeOut;

sub TIEHANDLE {
	bless(\(my $text), $_[0]);
}

sub clear {
	${ $_[0] } = '';
}

# remove the bell character
sub scrub {
	${ $_[0] } =~ tr/\a//d;
}

# must shift off self
sub PRINT {
	my $self = shift;
	($$self .= join('', @_)) =~ s/\s+/./gm;
}