home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl501m.zip / lib / Term / Complete.pm < prev   
Text File  |  1995-07-03  |  3KB  |  114 lines
  1. package Term::Complete;
  2. require 5.000;
  3. require Exporter;
  4.  
  5. @ISA = qw(Exporter);
  6. @EXPORT = qw(Complete);
  7.  
  8. #
  9. #      @(#)complete.pl,v1.1            (me@anywhere.EBay.Sun.COM) 09/23/91
  10. #
  11. # Author: Wayne Thompson
  12. #
  13. # Description:
  14. #     This routine provides word completion.
  15. #     (TAB) attempts word completion.
  16. #     (^D)  prints completion list.
  17. #      (These may be changed by setting $Complete::complete, etc.)
  18. #
  19. # Diagnostics:
  20. #     Bell when word completion fails.
  21. #
  22. # Dependencies:
  23. #     The tty driver is put into raw mode.
  24. #
  25. # Bugs:
  26. #
  27. # Usage:
  28. #     $input = complete('prompt_string', \@completion_list);
  29. #         or
  30. #     $input = complete('prompt_string', @completion_list);
  31. #
  32.  
  33. CONFIG: {
  34.     $complete = "\004";
  35.     $kill     = "\025";
  36.     $erase1 =   "\177";
  37.     $erase2 =   "\010";
  38. }
  39.  
  40. sub Complete {
  41.     $prompt = shift;
  42.     if (ref $_[0] || $_[0] =~ /^\*/) {
  43.     @cmp_lst = sort @{$_[0]};
  44.     }
  45.     else {
  46.     @cmp_lst = sort(@_);
  47.     }
  48.  
  49.     system('stty raw -echo');
  50.     LOOP: {
  51.         print($prompt, $return);
  52.         while (($_ = getc(STDIN)) ne "\r") {
  53.             CASE: {
  54.                 # (TAB) attempt completion
  55.                 $_ eq "\t" && do {
  56.                     @match = grep(/^$return/, @cmp_lst);
  57.                     $l = length($test = shift(@match));
  58.                     unless ($#match < 0) {
  59.                         foreach $cmp (@match) {
  60.                             until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
  61.                                 $l--;
  62.                             }
  63.                         }
  64.                         print("\a");
  65.                     }
  66.                     print($test = substr($test, $r, $l - $r));
  67.                     $r = length($return .= $test);
  68.                     last CASE;
  69.                 };
  70.  
  71.                 # (^D) completion list
  72.                 $_ eq $complete && do {
  73.                     print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
  74.                     redo LOOP;
  75.                 };
  76.  
  77.                 # (^U) kill
  78.                 $_ eq $kill && do {
  79.                     if ($r) {
  80.                         undef($r, $return);
  81.                         print("\r\n");
  82.                         redo LOOP;
  83.                     }
  84.                     last CASE;
  85.                 };
  86.  
  87.                 # (DEL) || (BS) erase
  88.                 ($_ eq $erase1 || $_ eq $erase2) && do {
  89.                     if($r) {
  90.                         print("\b \b");
  91.                         chop($return);
  92.                         $r--;
  93.                     }
  94.                     last CASE;
  95.                 };
  96.  
  97.                 # printable char
  98.                 ord >= 32 && do {
  99.                     $return .= $_;
  100.                     $r++;
  101.                     print;
  102.                     last CASE;
  103.                 };
  104.             }
  105.         }
  106.     }
  107.     system('stty -raw echo');
  108.     print("\n");
  109.     $return;
  110. }
  111.  
  112. 1;
  113.  
  114.