Commit | Line | Data |
---|---|---|
bbd9de80 | 1 | #!./perl |
2 | ||
3 | BEGIN { | |
88587957 | 4 | chdir 't' if -d 't'; |
bbd9de80 | 5 | @INC = '../lib'; |
6 | } | |
7 | ||
8 | use warnings; | |
9 | use Test::More tests => 8; | |
25f74a49 | 10 | use vars qw( $Term::Complete::complete $complete $Term::Complete::stty ); |
fc81c880 | 11 | |
cd3eb553 | 12 | SKIP: { |
1f137b8a | 13 | skip('PERL_SKIP_TTY_TEST', 8) if $ENV{PERL_SKIP_TTY_TEST}; |
cd3eb553 | 14 | |
25f74a49 JH |
15 | use_ok( 'Term::Complete' ); |
16 | ||
17 | # this skips tests AND prevents the "used only once" warning | |
b8d190ff | 18 | skip('No stty, Term::Complete will not run here', 7) |
25f74a49 JH |
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' ); | |
fc81c880 JH |
70 | |
71 | } # end of SKIP, end of tests | |
bbd9de80 | 72 | |
73 | # easier than matching space characters | |
74 | sub get_expected { | |
75 | my $word = shift; | |
76 | return join('.', $word, @_, $word, '.'); | |
77 | } | |
78 | ||
79 | package FakeIn; | |
80 | ||
81 | sub TIEHANDLE { | |
82 | my ($class, $text) = @_; | |
83 | $text .= "$main::complete\025"; | |
84 | bless(\$text, $class); | |
85 | } | |
86 | ||
87 | sub add { | |
88 | my ($self, $text) = @_; | |
89 | $$self = $text . "$main::complete\025"; | |
90 | } | |
91 | ||
92 | sub GETC { | |
93 | my $self = shift; | |
94 | return length $$self ? substr($$self, 0, 1, '') : "\r"; | |
95 | } | |
96 | ||
97 | package FakeOut; | |
98 | ||
99 | sub TIEHANDLE { | |
100 | bless(\(my $text), $_[0]); | |
101 | } | |
102 | ||
103 | sub clear { | |
104 | ${ $_[0] } = ''; | |
105 | } | |
106 | ||
107 | # remove the bell character | |
108 | sub scrub { | |
109 | ${ $_[0] } =~ tr/\a//d; | |
110 | } | |
111 | ||
112 | # must shift off self | |
113 | sub PRINT { | |
114 | my $self = shift; | |
115 | ($$self .= join('', @_)) =~ s/\s+/./gm; | |
116 | } |