summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorFlorian Ragwitz <rafl@debian.org>2011-07-13 17:26:42 +0200
committerFlorian Ragwitz <rafl@debian.org>2011-07-13 17:56:23 +0200
commit7f4d7a860e99508a6d987ad8b17c5f085376cf40 (patch)
treea24d0bdb50a5d35facb159c2914111c70248a5d7 /lib
parente22e289db465f8d0c6edd99855cde6ed8d7ffa3c (diff)
downloadperl-7f4d7a860e99508a6d987ad8b17c5f085376cf40.tar.gz
Dual-life Term::Complete
Diffstat (limited to 'lib')
-rw-r--r--lib/.gitignore6
-rw-r--r--lib/Term/Complete.pm188
-rw-r--r--lib/Term/Complete.t116
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;
-}