1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6} 7 8use warnings; 9use Test::More tests => 8; 10use vars qw( $Term::Complete::complete $complete $Term::Complete::stty ); 11 12SKIP: { 13 skip('PERL_SKIP_TTY_TEST', 8) if $ENV{PERL_SKIP_TTY_TEST}; 14 15 use_ok( 'Term::Complete' ); 16 17 # this skips tests AND prevents the "used only once" warning 18 skip('No stty, Term::Complete will not run here', 7) 19 unless defined $Term::Complete::tty_raw_noecho && 20 defined $Term::Complete::tty_restore; 21 22 # also prevent Term::Complete from running stty and messing up the terminal 23 undef $Term::Complete::tty_restore; 24 undef $Term::Complete::tty_raw_noecho; 25 undef $Term::Complete::stty; 26 27 *complete = \$Term::Complete::complete; 28 29 my $in = tie *STDIN, 'FakeIn', "fro\t"; 30 my $out = tie *STDOUT, 'FakeOut'; 31 my @words = ( 'frobnitz', 'frobozz', 'frostychocolatemilkshakes' ); 32 33 Complete('', \@words); 34 my $data = get_expected('fro', @words); 35 36 # there should be an \a after our word 37 like( $$out, qr/fro\a/, 'found bell character' ); 38 39 # now remove the \a -- there should be only one 40 is( $out->scrub(), 1, '(single) bell removed'); 41 42 # 'fro' should match all three words 43 like( $$out, qr/$data/, 'all three words possible' ); 44 $out->clear(); 45 46 # should only find 'frobnitz' and 'frobozz' 47 $in->add('frob'); 48 Complete('', @words); 49 $out->scrub(); 50 is( $$out, get_expected('frob', 'frobnitz', 'frobozz'), 'expected frob*' ); 51 $out->clear(); 52 53 # should only do 'frobozz' 54 $in->add('frobo'); 55 Complete('', @words); 56 $out->scrub(); 57 is( $$out, get_expected( 'frobo', 'frobozz' ), 'only frobozz possible' ); 58 $out->clear(); 59 60 # change the completion character 61 $complete = "!"; 62 $in->add('frobn'); 63 Complete('prompt:', @words); 64 $out->scrub(); 65 like( $$out, qr/prompt:frobn/, 'prompt is okay' ); 66 67 # now remove the prompt and we should be okay 68 $$out =~ s/prompt://g; 69 is( $$out, get_expected('frobn', 'frobnitz' ), 'works with new $complete' ); 70 71} # end of SKIP, end of tests 72 73# easier than matching space characters 74sub get_expected { 75 my $word = shift; 76 return join('.', $word, @_, $word, '.'); 77} 78 79package FakeIn; 80 81sub TIEHANDLE { 82 my ($class, $text) = @_; 83 $text .= "$main::complete\025"; 84 bless(\$text, $class); 85} 86 87sub add { 88 my ($self, $text) = @_; 89 $$self = $text . "$main::complete\025"; 90} 91 92sub GETC { 93 my $self = shift; 94 return length $$self ? substr($$self, 0, 1, '') : "\r"; 95} 96 97package FakeOut; 98 99sub TIEHANDLE { 100 bless(\(my $text), $_[0]); 101} 102 103sub clear { 104 ${ $_[0] } = ''; 105} 106 107# remove the bell character 108sub scrub { 109 ${ $_[0] } =~ tr/\a//d; 110} 111 112# must shift off self 113sub PRINT { 114 my $self = shift; 115 ($$self .= join('', @_)) =~ s/\s+/./gm; 116} 117