diff options
author | Florian Ragwitz <rafl@debian.org> | 2011-07-13 17:26:42 +0200 |
---|---|---|
committer | Florian Ragwitz <rafl@debian.org> | 2011-07-13 17:56:23 +0200 |
commit | 7f4d7a860e99508a6d987ad8b17c5f085376cf40 (patch) | |
tree | a24d0bdb50a5d35facb159c2914111c70248a5d7 /lib | |
parent | e22e289db465f8d0c6edd99855cde6ed8d7ffa3c (diff) | |
download | perl-7f4d7a860e99508a6d987ad8b17c5f085376cf40.tar.gz |
Dual-life Term::Complete
Diffstat (limited to 'lib')
-rw-r--r-- | lib/.gitignore | 6 | ||||
-rw-r--r-- | lib/Term/Complete.pm | 188 | ||||
-rw-r--r-- | lib/Term/Complete.t | 116 |
3 files changed, 1 insertions, 309 deletions
diff --git a/lib/.gitignore b/lib/.gitignore index db67151c4f..959499485a 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -346,11 +346,7 @@ /Storable.pm /Switch.pm /Sys -/Term/ANSIColor.pm -/Term/Cap.pm -/Term/UI.pm -/Term/UI/History.pm -/Term/ReadLine.pm +/Term /Test.pm /Test/Builder /Test/Builder.pm diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm deleted file mode 100644 index 601e495643..0000000000 --- a/lib/Term/Complete.pm +++ /dev/null @@ -1,188 +0,0 @@ -package Term::Complete; -require 5.000; -require Exporter; - -use strict; -our @ISA = qw(Exporter); -our @EXPORT = qw(Complete); -our $VERSION = '1.402'; - -# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91 - -=head1 NAME - -Term::Complete - Perl word completion module - -=head1 SYNOPSIS - - $input = Complete('prompt_string', \@completion_list); - $input = Complete('prompt_string', @completion_list); - -=head1 DESCRIPTION - -This routine provides word completion on the list of words in -the array (or array ref). - -The tty driver is put into raw mode and restored using an operating -system specific command, in UNIX-like environments C<stty>. - -The following command characters are defined: - -=over 4 - -=item E<lt>tabE<gt> - -Attempts word completion. -Cannot be changed. - -=item ^D - -Prints completion list. -Defined by I<$Term::Complete::complete>. - -=item ^U - -Erases the current input. -Defined by I<$Term::Complete::kill>. - -=item E<lt>delE<gt>, E<lt>bsE<gt> - -Erases one character. -Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>. - -=back - -=head1 DIAGNOSTICS - -Bell sounds when word completion fails. - -=head1 BUGS - -The completion character E<lt>tabE<gt> cannot be changed. - -=head1 AUTHOR - -Wayne Thompson - -=cut - -our($complete, $kill, $erase1, $erase2, $tty_raw_noecho, $tty_restore, $stty, $tty_safe_restore); -our($tty_saved_state) = ''; -CONFIG: { - $complete = "\004"; - $kill = "\025"; - $erase1 = "\177"; - $erase2 = "\010"; - foreach my $s (qw(/bin/stty /usr/bin/stty)) { - if (-x $s) { - $tty_raw_noecho = "$s raw -echo"; - $tty_restore = "$s -raw echo"; - $tty_safe_restore = $tty_restore; - $stty = $s; - last; - } - } -} - -sub Complete { - my($prompt, @cmp_lst, $cmp, $test, $l, @match); - my ($return, $r) = ("", 0); - - $return = ""; - $r = 0; - - $prompt = shift; - if (ref $_[0] || $_[0] =~ /^\*/) { - @cmp_lst = sort @{$_[0]}; - } - else { - @cmp_lst = sort(@_); - } - - # Attempt to save the current stty state, to be restored later - if (defined $stty && defined $tty_saved_state && $tty_saved_state eq '') { - $tty_saved_state = qx($stty -g 2>/dev/null); - if ($?) { - # stty -g not supported - $tty_saved_state = undef; - } - else { - $tty_saved_state =~ s/\s+$//g; - $tty_restore = qq($stty "$tty_saved_state" 2>/dev/null); - } - } - system $tty_raw_noecho if defined $tty_raw_noecho; - LOOP: { - local $_; - print($prompt, $return); - while (($_ = getc(STDIN)) ne "\r") { - CASE: { - # (TAB) attempt completion - $_ eq "\t" && do { - @match = grep(/^\Q$return/, @cmp_lst); - unless ($#match < 0) { - $l = length($test = shift(@match)); - foreach $cmp (@match) { - until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { - $l--; - } - } - print("\a"); - print($test = substr($test, $r, $l - $r)); - $r = length($return .= $test); - } - last CASE; - }; - - # (^D) completion list - $_ eq $complete && do { - print(join("\r\n", '', grep(/^\Q$return/, @cmp_lst)), "\r\n"); - redo LOOP; - }; - - # (^U) kill - $_ eq $kill && do { - if ($r) { - $r = 0; - $return = ""; - print("\r\n"); - redo LOOP; - } - last CASE; - }; - - # (DEL) || (BS) erase - ($_ eq $erase1 || $_ eq $erase2) && do { - if($r) { - print("\b \b"); - chop($return); - $r--; - } - last CASE; - }; - - # printable char - ord >= 32 && do { - $return .= $_; - $r++; - print; - last CASE; - }; - } - } - } - - # system $tty_restore if defined $tty_restore; - if (defined $tty_saved_state && defined $tty_restore && defined $tty_safe_restore) - { - system $tty_restore; - if ($?) { - # tty_restore caused error - system $tty_safe_restore; - } - } - print("\n"); - $return; -} - -1; diff --git a/lib/Term/Complete.t b/lib/Term/Complete.t deleted file mode 100644 index 7386474c99..0000000000 --- a/lib/Term/Complete.t +++ /dev/null @@ -1,116 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use warnings; -use Test::More tests => 8; -use vars qw( $Term::Complete::complete $complete $Term::Complete::stty ); - -SKIP: { - skip('PERL_SKIP_TTY_TEST', 8) if $ENV{PERL_SKIP_TTY_TEST}; - - use_ok( 'Term::Complete' ); - - # this skips tests AND prevents the "used only once" warning - skip('No stty, Term::Complete will not run here', 7) - unless defined $Term::Complete::tty_raw_noecho && - defined $Term::Complete::tty_restore; - - # also prevent Term::Complete from running stty and messing up the terminal - undef $Term::Complete::tty_restore; - undef $Term::Complete::tty_raw_noecho; - undef $Term::Complete::stty; - - *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' ); - -} # end of SKIP, end of tests - -# 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; -} |