Dual-life Term::Complete

2 files changed, 299 insertions, 0 deletions

diff --git a/dist/Term-Complete/lib/Term/Complete.pm b/dist/Term-Complete/lib/Term/Complete.pm
new file mode 100644
index 0000000000..601e495643
--- /dev/null
+++ b/dist/Term-Complete/lib/Term/Complete.pm
@@ -0,0 +1,188 @@
+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/dist/Term-Complete/t/Complete.t b/dist/Term-Complete/t/Complete.t
new file mode 100644
index 0000000000..b24863e279
--- /dev/null
+++ b/dist/Term-Complete/t/Complete.t
@@ -0,0 +1,111 @@
+#!./perl
+
+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;
+}