home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / Term / ReadLine / readline.pm < prev   
Text File  |  1997-09-08  |  77KB  |  2,620 lines
  1. ##
  2. ## Perl Readline -- The Quick Help
  3. ## (see the manual for complete info)
  4. ##
  5. ## Once this package is included (require'd), you can then call
  6. ##    $text = &readline'readline($input);
  7. ## to get lines of input from the user.
  8. ##
  9. ## Normally, it reads ~/.inputrc when loaded... to suppress this, set
  10. ##     $readline'rl_NoInitFromFile = 1;
  11. ## before requiring the package.
  12. ##
  13. ## Call rl_bind to add your own key bindings, as in
  14. ##    &readline'rl_bind('C-L', 'possible-completions');
  15. ##
  16. ## Call rl_set to set mode variables yourself, as in
  17. ##    &readline'rl_set('TcshCompleteMode', 'On');
  18. ##
  19. ## Call rl_basic_commands to set your own command completion, as in
  20. ##      &readline'rl_basic_commands('print', 'list', 'quit', 'run', 'status');
  21. ##
  22. ##
  23.  
  24. package readline;
  25.  
  26. my $autoload_broken = 1;    # currently: defined does not work with a-l
  27. my $useioctl = 1;
  28.  
  29. ##
  30. ## BLURB:
  31. ## A pretty full-function package similar to GNU's readline.
  32. ## Includes support for EUC-encoded Japanese text.
  33. ##
  34. ## Written by Jeffrey Friedl, Omron Corporation (jfriedl@omron.co.jp)
  35. ##
  36. ## Comments, corrections welcome.
  37. ##
  38. ## Thanks to the people at FSF for readline (and the code I referenced
  39. ## while writing this), and for Roland Schemers whose line_edit.pl I used
  40. ## as an early basis for this.
  41. ##
  42. $VERSION = $VERSION = 0.9901;
  43.  
  44. ## 940817.008 - Added $var_CompleteAddsuffix.
  45. ##        Now recognizes window-change signals (at least on BSD).
  46. ##              Various typos and bug fixes.
  47. ##    Changes from Chris Arthur (csa@halcyon.com):
  48. ##        Added a few new keybindings.
  49. ##              Various typos and bug fixes.
  50. ##        Support for use from a dumb terminal.
  51. ##        Pretty-printing of filename-completion matches.
  52. ##        
  53. ## 930306.007 - Added rl_start_default_at_beginning.
  54. ##        Added optional message arg to &redisplay.
  55. ##        Added explicit numeric argument var to functions that use it.
  56. ##        Redid many commands to simplify.
  57. ##        Added TransposeChars, UpcaseWord, CapitalizeWord, DownCaseWord.
  58. ##        Redid key binding specs to better match GNU.. added
  59. ##          undocumented "new-style" bindings.... can now bind
  60. ##          arrow keys and other arbitrairly long key sequences.
  61. ##        Added if/else/then to .inputrc.
  62. ##        
  63. ## 930305.006 - optional "default" added (from mmuegel@cssmp.corp.mot.com).
  64. ##
  65. ## 930211.005 - fixed strange problem with eval while keybinding
  66. ##
  67.  
  68. ##
  69. ## Ilya: 
  70. ##
  71. ## Added support for ReadKey, 
  72. ##
  73. ## Added customization variable $minlength
  74. ## to denote minimal lenth of a string to be put into history buffer.
  75. ##
  76. ## Added support for a bug in debugger: preinit cannot be a subroutine ?!!!
  77. ## (See immendiately below)
  78. ##
  79. ## Added support for WINCH hooks. The subroutine references should be put into
  80. ## @winchhooks.
  81. ##
  82. ## Added F_ToggleInsertMode, F_HistorySearchBackward,
  83. ## F_HistorySearchForward, PC keyboard bindings.
  84. ## 0.93: Updates to Operate, couple of keybindings added.
  85. ## $rl_completer_terminator_character, $rl_correct_sw added.
  86. ## Reload-init-file moved to C-x C-x.
  87. ## C-x ? and C-x * list/insert possible completions.
  88.  
  89. &preinit;
  90. &init;
  91.  
  92. # # # # use strict 'vars';
  93.  
  94. # # # # # Separation into my and vars needs some thought...
  95.  
  96. # # # # use vars qw(@KeyMap %KeyMap $rl_screen_width $rl_start_default_at_beginning
  97. # # # #         $rl_completion_function $rl_basic_word_break_characters
  98. # # # #         $rl_completer_word_break_characters $rl_special_prefixes
  99. # # # #         $rl_readline_name @rl_History $rl_MaxHistorySize
  100. # # # #             $rl_max_numeric_arg $rl_OperateCount
  101. # # # #         $KillBuffer $dumb_term $stdin_not_tty $InsertMode 
  102. # # # #         $rl_NoInitFromFile);
  103.  
  104. # # # # my ($InputLocMsg, $term_OUT, $term_IN);
  105. # # # # my ($winsz_t, $TIOCGWINSZ, $winsz, $rl_margin, $hooj, $force_redraw);
  106. # # # # my ($hook, %var_HorizontalScrollMode, %var_EditingMode, %var_OutputMeta);
  107. # # # # my ($var_HorizontalScrollMode, $var_EditingMode, $var_OutputMeta);
  108. # # # # my (%var_ConvertMeta, $var_ConvertMeta, %var_MarkModifiedLines, $var_MarkModifiedLines);
  109. # # # # my ($term_readkey, $inDOS);
  110. # # # # my (%var_PreferVisibleBell, $var_PreferVisibleBell);
  111. # # # # my (%var_TcshCompleteMode, $var_TcshCompleteMode);
  112. # # # # my (%var_CompleteAddsuffix, $var_CompleteAddsuffix);
  113. # # # # my ($minlength, @winchhooks);
  114. # # # # my ($BRKINT, $ECHO, $FIONREAD, $ICANON, $ICRNL, $IGNBRK, $IGNCR, $INLCR,
  115. # # # #     $ISIG, $ISTRIP, $NCCS, $OPOST, $RAW, $TCGETS, $TCOON, $TCSETS, $TCXONC,
  116. # # # #     $TERMIOS_CFLAG, $TERMIOS_IFLAG, $TERMIOS_LFLAG, $TERMIOS_NORMAL_IOFF,
  117. # # # #     $TERMIOS_NORMAL_ION, $TERMIOS_NORMAL_LOFF, $TERMIOS_NORMAL_LON, 
  118. # # # #     $TERMIOS_NORMAL_OOFF, $TERMIOS_NORMAL_OON, $TERMIOS_OFLAG, 
  119. # # # #     $TERMIOS_READLINE_IOFF, $TERMIOS_READLINE_ION, $TERMIOS_READLINE_LOFF, 
  120. # # # #     $TERMIOS_READLINE_LON, $TERMIOS_READLINE_OOFF, $TERMIOS_READLINE_OON, 
  121. # # # #     $TERMIOS_VMIN, $TERMIOS_VTIME, $TIOCGETP, $TIOCGWINSZ, $TIOCSETP, 
  122. # # # #     $fion, $fionread_t, $mode, $sgttyb_t, 
  123. # # # #     $termios, $termios_t, $winsz, $winsz_t);
  124. # # # # my ($line, $initialized, $term_readkey);
  125.  
  126. ##
  127. ## What's Cool
  128. ## ----------------------------------------------------------------------
  129. ## * hey, it's in perl.
  130. ## * Pretty full GNU readline like library...
  131. ## *    support for ~/.inputrc
  132. ## *    horizontal scrolling
  133. ## *    command/file completion
  134. ## *    rebinding
  135. ## *    history (with search)
  136. ## *    undo
  137. ## *    numeric prefixes
  138. ## * supports multi-byte characters (at least for the Japanese I use).
  139. ## * Has a tcsh-like completion-function mode.
  140. ##     call &readline'rl_set('tcsh-complete-mode', 'On') to turn on.
  141. ##
  142.  
  143. ##
  144. ## What's not Cool
  145. ## ----------------------------------------------------------------------
  146. ## Can you say HUGE?
  147. ## I can't spell, so comments riddled with misspellings.
  148. ## Written by someone that has never really used readline.
  149. ## History mechanism is slightly different than GNU... may get fixed
  150. ##     someday, but I like it as it is now...
  151. ## Killbuffer not a ring.. just one level.
  152. ## Obviously not well tested yet.
  153. ## Written by someone that doesn't have a bell on his terminal, so
  154. ##     proper readline use of the bell may not be here.
  155. ##
  156.  
  157.  
  158. ##
  159. ## Functions beginning with F_ are functions that are mapped to keys.
  160. ## Variables and functions beginning rl_ may be accessed/set/called/read
  161. ## from outside the package.  Other things are internal.
  162. ##
  163. ## Some notable internal-only variables of global proportions:
  164. ##   $prompt -- line prompt (passed from user)
  165. ##   $line  -- the line being input
  166. ##   $D     -- ``Dot'' -- index into $line of the cursor's location.
  167. ##   $InsertMode -- usually true. False means overwrite mode.
  168. ##   $InputLocMsg -- string for error messages, such as "[~/.inputrc line 2]"
  169. ##   *emacs_keymap -- keymap for emacs-mode bindings:
  170. ##    @emacs_keymap - bindings indexed by ASCII ordinal
  171. ##      $emacs_keymap{'name'} = "emacs_keymap"
  172. ##      $emacs_keymap{'default'} = "SelfInsert"  (default binding)
  173. ##   *vi_keymap -- keymap for vi-mode bindings
  174. ##   *KeyMap -- current keymap in effect.
  175. ##   $LastCommandKilledText -- needed so that subsequent kills accumulate
  176. ##   $lastcommand -- name of command previously run
  177. ##   $lastredisplay -- text placed upon screen during previous &redisplay
  178. ##   $si -- ``screen index''; index into $line of leftmost char &redisplay'ed
  179. ##   $force_redraw -- if set to true, causes &redisplay to be verbose.
  180. ##   $AcceptLine -- when set, its value is returned from &readline.
  181. ##   $ReturnEOF -- unless this also set, in which case undef is returned.
  182. ##   $pending -- if set, value is to be used as input.
  183. ##   @undo -- array holding all states of current line, for undoing.
  184. ##   $KillBuffer -- top of kill ring (well, don't have a kill ring yet)
  185. ##   @tcsh_complete_selections -- for tcsh mode, possible selections
  186. ##
  187. ## Some internal variables modified by &rl_set (see comment at &rl_set for
  188. ## info about how these set'able variables work)
  189. ##   $var_EditingMode -- either *emacs_map or *vi_map
  190. ##   $var_TcshCompleteMode -- if true, the completion function works like
  191. ##      in tcsh.  That is, the first time you try to complete something,
  192. ##    the common prefix is completed for you. Subsequent completion tries
  193. ##    (without other commands in between) cycles the command line through
  194. ##    the various possibilities.  If/when you get the one you want, just
  195. ##    continue typing.
  196. ## Other $var_ things not supported yet.
  197. ##
  198. ## Some variables used internally, but may be accessed from outside...
  199. ##   $VERSION -- just for good looks.
  200. ##   $rl_readline_name = name of program -- for .initrc if/endif stuff.
  201. ##   $rl_NoInitFromFile -- if defined when package is require'd, ~/.inputrc
  202. ##      will not be read.
  203. ##   @rl_History -- array of previous lines input
  204. ##   $rl_HistoryIndex -- history pointer (for moving about history array)
  205. ##   $rl_completion_function -- see "How Command Completion Works" (way) below.
  206. ##   $rl_basic_word_break_characters -- string of characters that can cause
  207. ##    a word break for forward-word, etc.
  208. ##   $rl_start_default_at_beginning --
  209. ##    Normally, the user's cursor starts at the end of any default text
  210. ##    passed to readline.  If this variable is true, it starts at the
  211. ##    beginning.
  212. ##   $rl_completer_word_break_characters --
  213. ##    like $rl_basic_word_break_characters (and in fact defaults to it),
  214. ##    but for the completion function.
  215. ##   $rl_completer_terminator_character -- what to insert to separate
  216. ##      a completed token from the rest.  Reset at beginning of
  217. ##      completion to ' ' so completion function can change it.
  218. ##   $rl_special_prefixes -- characters that are part of this string as well
  219. ##      as of $rl_completer_word_break_characters cause a word break for the
  220. ##    completer function, but remain part of the word.  An example: consider
  221. ##      when the input might be perl code, and one wants to be able to
  222. ##      complete on variable and function names, yet still have the '$',
  223. ##    '&', '@',etc. part of the $text to be completed. Then set this var
  224. ##     to '&@$%' and make sure each of these characters is in
  225. ##     $rl_completer_word_break_characters as well....
  226. ##   $rl_MaxHistorySize -- maximum size that the history array may grow.
  227. ##   $rl_screen_width -- width readline thinks it can use on the screen.
  228. ##   $rl_correct_sw -- is substructed from the real width of the terminal
  229. ##   $rl_margin -- when moving to within this far from a margin, scrolls.
  230. ##   $rl_CLEAR -- what to output to clear the screen.
  231. ##   $rl_max_numeric_arg -- maximum numeric arg allowed.
  232. ##
  233.  
  234. sub get_window_size
  235. {
  236.     my $sig = shift;
  237.     my ($num_cols,$num_rows);
  238.     
  239.     if (defined $term_readkey) {
  240.      ($num_cols,$num_rows) =  Term::ReadKey::GetTerminalSize($term_OUT);
  241.      $rl_screen_width = $num_cols - $rl_correct_sw
  242.        if defined($num_cols) && $num_cols;
  243.     } elsif (ioctl($term_IN,$TIOCGWINSZ,$winsz)) {
  244.      ($num_rows,$num_cols) = unpack($winsz_t,$winsz);
  245.      $rl_screen_width = $num_cols - $rl_correct_sw
  246.        if defined($num_cols) && $num_cols;
  247.     }
  248.     $rl_margin = int($rl_screen_width/3);
  249.     if (defined $sig) {
  250.     $force_redraw = 1;
  251.     &redisplay();
  252.     }
  253.     
  254.     for $hook (@winchhooks) {
  255.       eval {&$hook()}; warn $@ if $@ and $^W;
  256.     }
  257.     local $^W = 0;        # WINCH may be illegal...
  258.     $SIG{'WINCH'} = "readline::get_window_size";
  259. }
  260.  
  261. sub preinit
  262. {
  263.     ## Set up the input and output handles
  264.  
  265.     $term_IN = \*STDIN unless defined $term_IN;
  266.     $term_OUT = \*STDOUT unless defined $term_OUT;
  267.     ## not yet supported... always on.
  268.     $var_HorizontalScrollMode = 1;
  269.     $var_HorizontalScrollMode{'On'} = 1;
  270.     $var_HorizontalScrollMode{'Off'} = 0;
  271.  
  272.     $var_EditingMode{'emacs'} = *emacs_keymap;
  273.     #$var_EditingMode{'vi'} = *vi_keymap;
  274.     $var_EditingMode{'vi'} = *emacs_keymap;
  275.     $var_EditingMode = $var_EditingMode{'emacs'};
  276.  
  277.     ## not yet supported... always on
  278.     $var_InputMeta = 1;
  279.     $var_InputMeta{'Off'} = 0;
  280.     $var_InputMeta{'On'} = 1;
  281.  
  282.     ## not yet supported... always on
  283.     $var_OutputMeta = 1;
  284.     $var_OutputMeta{'Off'} = 0;
  285.     $var_OutputMeta{'On'} = 1;
  286.  
  287.     ## not yet supported... always off
  288.     $var_ConvertMeta = 0;
  289.     $var_ConvertMeta{'Off'} = 0;
  290.     $var_ConvertMeta{'On'} = 1;
  291.  
  292.     ## not yet supported... always off
  293.     $var_MetaFlag = 0;
  294.     $var_MetaFlag{'Off'} = 0;
  295.     $var_MetaFlag{'On'} = 1;
  296.  
  297.     ## not yet supported... always off
  298.     $var_MarkModifiedLines = 0;
  299.     $var_MarkModifiedLines{'Off'} = 0;
  300.     $var_MarkModifiedLines{'On'} = 1;
  301.  
  302.     ## not yet supported... always off
  303.     $var_PreferVisibleBell = 0;
  304.     $var_PreferVisibleBell{'On'} = 1;
  305.     $var_PreferVisibleBell{'Off'} = 0;
  306.  
  307.     ## this is an addition. Very nice.
  308.     $var_TcshCompleteMode = 0;
  309.     $var_TcshCompleteMode{'On'} = 1;
  310.     $var_TcshCompleteMode{'Off'} = 0;
  311.  
  312.     $var_CompleteAddsuffix = 1;
  313.     $var_CompleteAddsuffix{'On'} = 1;
  314.     $var_CompleteAddsuffix{'Off'} = 0;
  315.  
  316.     # To conform to interface
  317.     $minlength = 1 unless defined $minlength;
  318.  
  319.     # WINCH hooks
  320.     @winchhooks = ();
  321.  
  322.     $inDOS = $^O eq 'os2' || defined $ENV{OS2_SHELL} unless defined $inDOS;
  323.     eval {
  324.       require Term::ReadKey; $term_readkey++;
  325.     };
  326.     if ($@) {
  327.       eval {require "ioctl.pl"}; ## try to get, don't die if not found.
  328.       eval {require "sys/ioctl.ph"}; ## try to get, don't die if not found.
  329.       eval {require "sgtty.ph"}; ## try to get, don't die if not found.
  330.       if ($inDOS and !defined $TIOCGWINSZ) {
  331.       $TIOCGWINSZ=0;
  332.       $TIOCGETP=1;
  333.       $TIOCSETP=2;
  334.       $sgttyb_t="I5 C8";
  335.       $winsz_t="";
  336.       $RAW=0xf002;
  337.       $ECHO=0x0008;
  338.       }
  339.       $TIOCGETP = &TIOCGETP if defined(&TIOCGETP);
  340.       $TIOCSETP = &TIOCSETP if defined(&TIOCSETP);
  341.       $TIOCGWINSZ = &TIOCGWINSZ if defined(&TIOCGWINSZ);
  342.       $FIONREAD = &FIONREAD if defined(&FIONREAD);
  343.       $TCGETS = &TCGETS if defined(&TCGETS);
  344.       $TCSETS = &TCSETS if defined(&TCSETS);
  345.       $TCXONC = &TCXONC if defined(&TCXONC);
  346.       $TIOCGETP   = 0x40067408 if !defined($TIOCGETP);
  347.       $TIOCSETP   = 0x80067409 if !defined($TIOCSETP);
  348.       $TIOCGWINSZ = 0x40087468 if !defined($TIOCGWINSZ);
  349.       $FIONREAD   = 0x4004667f if !defined($FIONREAD);
  350.       $TCGETS     = 0x40245408 if !defined($TCGETS);
  351.       $TCSETS     = 0x80245409 if !defined($TCSETS);
  352.       $TCXONC     = 0x20005406 if !defined($TCXONC);
  353.  
  354.       ## TTY modes
  355.       $ECHO = &ECHO if defined(&ECHO);
  356.       $RAW = &RAW if defined(&RAW);
  357.       $RAW    = 040 if !defined($RAW);
  358.       $ECHO    = 010 if !defined($ECHO);
  359.       #$CBREAK    = 002 if !defined($CBREAK);
  360.       $mode = $RAW; ## could choose CBREAK for testing....
  361.  
  362.       $IGNBRK     = 1 if !defined($IGNBRK);
  363.       $BRKINT     = 2 if !defined($BRKINT);
  364.       $ISTRIP     = 040 if !defined($ISTRIP);
  365.       $INLCR      = 0100 if !defined($INLCR);
  366.       $IGNCR      = 0200 if !defined($IGNCR);
  367.       $ICRNL      = 0400 if !defined($ICRNL);
  368.       $OPOST      = 1 if !defined($OPOST);
  369.       $ISIG       = 1 if !defined($ISIG);
  370.       $ICANON     = 2 if !defined($ICANON);
  371.       $TCOON      = 1 if !defined($TCOON);
  372.       $TERMIOS_READLINE_ION = $BRKINT;
  373.       $TERMIOS_READLINE_IOFF = $IGNBRK | $ISTRIP | $INLCR | $IGNCR | $ICRNL;
  374.       $TERMIOS_READLINE_OON = 0;
  375.       $TERMIOS_READLINE_OOFF = $OPOST;
  376.       $TERMIOS_READLINE_LON = 0;
  377.       $TERMIOS_READLINE_LOFF = $ISIG | $ICANON | $ECHO;
  378.       $TERMIOS_NORMAL_ION = $BRKINT;
  379.       $TERMIOS_NORMAL_IOFF = $IGNBRK;
  380.       $TERMIOS_NORMAL_OON = $OPOST;
  381.       $TERMIOS_NORMAL_OOFF = 0;
  382.       $TERMIOS_NORMAL_LON = $ISIG | $ICANON | $ECHO;
  383.       $TERMIOS_NORMAL_LOFF = 0;
  384.  
  385.       #$sgttyb_t   = 'C4 S';
  386.       #$winsz_t = "S S S S";  # rows,cols, xpixel, ypixel
  387.       $sgttyb_t   = 'C4 S' if !defined($sgttyb_t);
  388.       $winsz_t = "S S S S" if !defined($winsz_t);  
  389.       # rows,cols, xpixel, ypixel
  390.       $winsz = pack($winsz_t,0,0,0,0);
  391.       $fionread_t = "L";
  392.       $fion = pack($fionread_t, 0);
  393.       $NCCS = 17;
  394.       $termios_t = "LLLLc" . ("c" x $NCCS);  # true for SunOS 4.1.3, at least...
  395.       $termios = ''; ## just to shut up "perl -w".
  396.       $termios = pack($termios, 0);  # who cares, just make it long enough
  397.       $TERMIOS_IFLAG = 0;
  398.       $TERMIOS_OFLAG = 1;
  399.       $TERMIOS_CFLAG = 2;
  400.       $TERMIOS_LFLAG = 3;
  401.       $TERMIOS_VMIN = 5 + 4;
  402.       $TERMIOS_VTIME = 5 + 5;
  403.     }
  404.     $rl_correct_sw = ($inDOS ? 1 : 0);
  405.  
  406.     $rl_start_default_at_beginning = 0;
  407.     $rl_screen_width = 79; ## default
  408.  
  409.     $rl_completion_function = "rl_filename_list"
  410.     unless defined($rl_completion_function);
  411.     $rl_basic_word_break_characters = "\\\t\n' \"`\@\$><=;|&{(";
  412.     $rl_completer_word_break_characters = $rl_basic_word_break_characters;
  413.     $rl_special_prefixes = '';
  414.     ($rl_readline_name = $0) =~ s#.*[/\\]## if !defined($rl_readline_name);
  415.  
  416.     @rl_History=() if !defined(@rl_History);
  417.     $rl_MaxHistorySize = 100 if !defined($rl_MaxHistorySize);
  418.     $rl_max_numeric_arg = 200 if !defined($rl_max_numeric_arg);
  419.     $rl_OperateCount = 0 if !defined($rl_OperateCount);
  420.  
  421.     $rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
  422.     @$rl_term_set or $rl_term_set = ["","","",""];
  423.  
  424.     $InsertMode=1;
  425.     $KillBuffer='';
  426.     $line='';
  427.     $InputLocMsg = ' [initialization]';
  428.     
  429.     &InitKeymap(*emacs_keymap, 'SelfInsert', 'emacs_keymap',
  430.         ($inDOS ? () : ('C-@',    'Ding') ),
  431.         'C-a',    'BeginningOfLine',
  432.         'C-b',    'BackwardChar',
  433.         'C-c',    'Interrupt',
  434.         'C-d',    'DeleteChar',
  435.         'C-e',    'EndOfLine',
  436.         'C-f',    'ForwardChar',
  437.         'C-g',    'Abort',
  438.         'M-C-g',    'Abort',
  439.         'C-h',    'BackwardDeleteChar',
  440.         "TAB" ,    'Complete',
  441.         "C-j" ,    'AcceptLine',
  442.         'C-k',    'KillLine',
  443.         'C-l',    'ClearScreen',
  444.         "C-m" ,    'AcceptLine',
  445.         'C-n',    'NextHistory',
  446.         'C-o',  'OperateAndGetNext',
  447.         'C-p',    'PreviousHistory',
  448.         'C-q',    'QuotedInsert',
  449.         'C-r',    'ReverseSearchHistory',
  450.         'C-s',    'ForwardSearchHistory',
  451.         'C-t',    'TransposeChars',
  452.         'C-u',    'UnixLineDiscard',
  453.         ##'C-v',    'QuotedInsert',
  454.         'C-v',    'HistorySearchForward',
  455.         'C-w',    'UnixWordRubout',
  456.         qq/"\cX\cX"/,    'ReReadInitFile',
  457.         qq/"\cX?"/,    'PossibleCompletions',
  458.         qq/"\cX*"/,    'InsertPossibleCompletions',
  459.         'C-y',    'Yank',
  460.         'C-z',    'Suspend',
  461.         'C-\\',    'Ding',
  462.         'C-^',    'Ding',
  463.         'C-_',    'Undo',
  464.         'DEL',    ($inDOS ?
  465.              'BackwardKillWord' : # <Control>+<Backspace>
  466.              'BackwardDeleteChar'
  467.             ),
  468.         'M-<',    'BeginningOfHistory',
  469.         'M->',    'EndOfHistory',
  470.         'M-DEL',    'BackwardKillWord',
  471.         'M-C-h',    'BackwardKillWord',
  472.         'M-C-j',    'ToggleEditingMode',
  473.         'M-C-v',    'QuotedInsert',
  474.         'M-b',    'BackwardWord',
  475.         'M-c',    'CapitalizeWord',
  476.         'M-d',    'KillWord',
  477.         'M-f',    'ForwardWord',
  478.         'M-l',    'DownCaseWord',
  479.         'M-r',    'RevertLine',
  480.         'M-t',    'TransposeWords',
  481.         'M-u',    'UpcaseWord',
  482.         'M-v',    'HistorySearchBackward',
  483.         'M-y',    'YankPop',
  484.         "M-?",    'PossibleCompletions',
  485.         "M-TAB",    'TabInsert',
  486.         qq/"\e[A"/,  'previous-history',
  487.         qq/"\e[B"/,  'next-history',
  488.         qq/"\e[C"/,  'forward-char',
  489.         qq/"\e[D"/,  'backward-char',
  490.         qq/"\eOA"/,  'previous-history',
  491.         qq/"\eOB"/,  'next-history',
  492.         qq/"\eOC"/,  'forward-char',
  493.         qq/"\eOD"/,  'backward-char',
  494.         qq/"\e[[A"/,  'previous-history',
  495.         qq/"\e[[B"/,  'next-history',
  496.         qq/"\e[[C"/,  'forward-char',
  497.         qq/"\e[[D"/,  'backward-char',
  498.         qq/"\e[2~"/,   'ToggleInsertMode', # X: <Insert>
  499.  
  500.         # HP xterm
  501.         #qq/"\e[A"/,   'PreviousHistory',    # up    arrow
  502.         #qq/"\e[B"/,   'NextHistory',        # down  arrow
  503.         #qq/"\e[C"/,   'ForwardChar',        # right arrow
  504.         #qq/"\e[D"/,   'BackwardChar',        # left  arrow
  505.         qq/"\e[H"/,   'BeginningOfLine',        # home
  506.         qq/"\e[1~"/,  'HistorySearchForward',   # find
  507.         qq/"\e[3~"/,  'ToggleInsertMode',    # insert char
  508.         qq/"\e[4~"/,  'ToggleInsertMode',    # select
  509.         qq/"\e[5~"/,  'HistorySearchBackward',    # prev
  510.         qq/"\e[6~"/,  'HistorySearchForward',    # next
  511.         qq/"\e[\0"/,  'BeginningOfLine',    # home
  512.         #'C-k',        'KillLine',        # clear display
  513.  
  514.         # hpterm
  515.  
  516.         ($ENV{'TERM'} eq 'hpterm' ?
  517.          (
  518.           qq/"\eA"/,    'PreviousHistory',     # up    arrow
  519.           qq/"\eB"/,    'NextHistory',           # down  arrow
  520.           qq/"\eC"/,    'ForwardChar',           # right arrow
  521.           qq/"\eD"/,    'BackwardChar',           # left  arrow
  522.           qq/"\eS"/,    'BeginningOfHistory',  # shift up    arrow
  523.           qq/"\eT"/,    'EndOfHistory',           # shift down  arrow
  524.           qq/"\e&r1R"/, 'EndOfLine',           # shift right arrow
  525.           qq/"\e&r1L"/, 'BeginningOfLine',     # shift left  arrow
  526.           qq/"\eJ"/,    'ClearScreen',           # clear display
  527.           qq/"\eM"/,    'UnixLineDiscard',     # delete line
  528.           qq/"\eK"/,    'KillLine',           # clear  line
  529.           qq/"\eG\eK"/, 'BackwardKillLine',    # shift clear line
  530.           qq/"\eP"/,    'DeleteChar',           # delete char
  531.           qq/"\eL"/,    'Yank',               # insert line
  532.           qq/"\eQ"/,    'ToggleInsertMode',    # insert char
  533.           qq/"\eV"/,    'HistorySearchBackward',# prev
  534.           qq/"\eU"/,    'HistorySearchForward',# next
  535.           qq/"\eh"/,    'BeginningOfLine',     # home
  536.           qq/"\eF"/,    'EndOfLine',           # shift home
  537.           qq/"\ei"/,    'Suspend',           # shift tab
  538.          ) :
  539.          ()
  540.         ),
  541.         ($inDOS ?
  542.          (
  543.           qq/"\0\16"/, 'Undo', # 14: <Alt>+<Backspace>
  544.           qq/"\0\23"/, 'RevertLine', # 19: <Alt>+<R>
  545.           qq/"\0\24"/, 'TransposeWords', # 20: <Alt>+<T>
  546.           qq/"\0\25"/, 'YankPop', # 21: <Alt>+<Y>
  547.           qq/"\0\26"/, 'UpcaseWord', # 22: <Alt>+<U>
  548.           qq/"\0\31"/, 'ReverseSearchHistory', # 25: <Alt>+<P>
  549.           qq/"\0\40"/, 'KillWord', # 32: <Alt>+<D>
  550.           qq/"\0\41"/, 'ForwardWord', # 33: <Alt>+<F>
  551.           qq/"\0\46"/, 'DownCaseWord', # 38: <Alt>+<L>
  552.           #qq/"\0\51"/, 'TildeExpand', # 41: <Alt>+<\'>
  553.           qq/"\0\56"/, 'CapitalizeWord', # 46: <Alt>+<C>
  554.           qq/"\0\60"/, 'BackwardWord', # 48: <Alt>+<B>
  555.           qq/"\0\61"/, 'ForwardSearchHistory', # 49: <Alt>+<N>
  556.           #qq/"\0\64"/, 'YankLastArg', # 52: <Alt>+<.>
  557.           qq/"\0\65"/, 'PossibleCompletions', # 53: <Alt>+</>
  558.           qq/"\0\107"/, 'BeginningOfLine', # 71: <Home>
  559.           qq/"\0\110"/, 'previous-history', # 72: <Up arrow>
  560.           qq/"\0\111"/, 'HistorySearchBackward', # 73: <Page Up>
  561.           qq/"\0\113"/, 'backward-char', # 75: <Left arrow>
  562.           qq/"\0\115"/, 'forward-char', # 77: <Right arrow>
  563.           qq/"\0\117"/, 'EndOfLine', # 79: <End>
  564.           qq/"\0\120"/, 'next-history', # 80: <Down arrow>
  565.           qq/"\0\121"/, 'HistorySearchForward', # 81: <Page Down>
  566.           qq/"\0\122"/, 'ToggleInsertMode', # 82: <Insert>
  567.           qq/"\0\123"/, 'DeleteChar', # 83: <Delete>
  568.           qq/"\0\163"/, 'BackwardWord', # 115: <Ctrl>+<Left arrow>
  569.           qq/"\0\164"/, 'ForwardWord', # 116: <Ctrl>+<Right arrow>
  570.           qq/"\0\165"/, 'KillLine', # 117: <Ctrl>+<End>
  571.           qq/"\0\166"/, 'EndOfHistory', # 118: <Ctrl>+<Page Down>
  572.           qq/"\0\167"/, 'BackwardKillLine', # 119: <Ctrl>+<Home>
  573.           qq/"\0\204"/, 'BeginningOfHistory', # 132: <Ctrl>+<Page Up>
  574.           qq/"\0\223"/, 'KillWord', # 147: <Ctrl>+<Delete>
  575.          )
  576.          : ( 'C-@',    'Ding')
  577.         )
  578.            );
  579.  
  580.     *KeyMap = *emacs_keymap;
  581.     my @add_bindings = ();
  582.     foreach ('-', '0' .. '9') { push(@add_bindings, "M-$_", 'DigitArgument'); }
  583.     foreach ("A" .. "Z") {
  584.       next if  # defined($KeyMap[27]) && defined (%{"$KeyMap{name}_27"}) &&
  585.     defined $ {"$KeyMap{name}_27"}[ord $_];
  586.       push(@add_bindings, "M-$_", 'DoLowercaseVersion');
  587.     }
  588.     &rl_bind(@add_bindings);
  589.     
  590.     ## Vi keymap not yet supported...
  591.     &InitKeymap(*vi_keymap, 'Ding', 'vi_keymap',
  592.         ' ',    'EmacsEditingMode',
  593.         "\n",    'EmacsEditingMode',
  594.         "\r",    'EmacsEditingMode',
  595.            );
  596.  
  597.     *KeyMap = $var_EditingMode;
  598.     1;                # Returning a glob causes a bug in db5.001m
  599. }
  600.  
  601. sub init
  602. {
  603.     if ($ENV{'TERM'} eq 'emacs' || $ENV{'TERM'} eq 'dumb') {
  604.     $dumb_term = 1;
  605.     } elsif (! -c $term_IN && $term_IN eq \*STDIN) { # Believe if it is given
  606.         $stdin_not_tty = 1;
  607.     } else {
  608.     &get_window_size;
  609.     &F_ReReadInitFile if !defined($rl_NoInitFromFile);
  610.     $InputLocMsg = '';
  611.     }
  612.     $initialized = 1;
  613. }
  614.  
  615.  
  616. ##
  617. ## InitKeymap(*keymap, 'default', 'name', bindings.....)
  618. ##
  619. sub InitKeymap
  620. {
  621.     local(*KeyMap) = shift(@_);
  622.     my $func = $KeyMap{'default'} = 'F_'.shift(@_);
  623.     $KeyMap{'name'} = shift(@_);
  624.     ### Temporarily disabled
  625.     die qq/Bad default function [$func] for keymap "$KeyMap{'name'}"/
  626.       if !$autoload_broken and !defined(&$func);
  627.     &rl_bind if @_ > 0;    ## The rest of @_ gets passed silently.
  628. }
  629.  
  630. ##
  631. ## Accepts an array as pairs ($keyspec, $function, [$keyspec, $function]...).
  632. ## and maps the associated bindings to the current KeyMap.
  633. ##
  634. ## keyspec should be the name of key sequence in one of two forms:
  635. ##
  636. ## Old (GNU readline documented) form:
  637. ##         M-x    to indicate Meta-x
  638. ##         C-x    to indicate Ctrl-x
  639. ##         M-C-x    to indicate Meta-Ctrl-x
  640. ##         x        simple char x
  641. ##      where 'x' above can be a single character, or the special:
  642. ##          special      means
  643. ##         --------      -----
  644. ##         space    space   ( )
  645. ##         spc    space   ( )
  646. ##         tab    tab     (\t)
  647. ##         del    delete  (0x7f)
  648. ##         rubout    delete  (0x7f)
  649. ##         newline     newline (\n)
  650. ##         lfd         newline (\n)
  651. ##         ret         return  (\r)
  652. ##         return      return  (\r)
  653. ##         escape      escape  (\e)
  654. ##         esc         escape  (\e)
  655. ##
  656. ## New form:
  657. ##      "chars"   (note the required double-quotes)
  658. ##   where each char in the list represents a character in the sequence, except
  659. ##   for the special sequences:
  660. ##      \\C-x        Ctrl-x
  661. ##      \\M-x        Meta-x
  662. ##      \\M-C-x    Meta-Ctrl-x
  663. ##      \\e        escape.
  664. ##      \\x        x (if not one of the above)
  665. ##
  666. ##
  667. ## FUNCTION should be in the form 'BeginningOfLine' or 'beginning-of-line'.
  668. ## It is an error for the function to not be known....
  669. ##
  670. ## As an example, the following lines in .inputrc will bind one's xterm
  671. ## arrow keys:
  672. ##     "\e[[A": previous-history
  673. ##     "\e[[B": next-history
  674. ##     "\e[[C": forward-char
  675. ##     "\e[[D": backward-char
  676. ##
  677.  
  678. sub actually_do_binding
  679. {
  680.   ##
  681.   ## actually_do_binding($function1, \@sequence1, ...)
  682.   ##
  683.   ## Actually inserts the binding for @sequence to $function into the
  684.   ## current map.  @sequence is an array of character ordinals.
  685.   ##
  686.   ## If @sequence is more than one element long, all but the last will
  687.   ## cause meta maps to be created.
  688.   ##
  689.   ## $Function will have an implicit "F_" prepended to it.
  690.   ##
  691.   while (@_) {
  692.     my $func = shift;
  693.     my ($key, @keys) = @{shift()};
  694.     $key += 0;
  695.     local(*KeyMap) = *KeyMap;
  696.     my $map;
  697.     while (@keys) {
  698.       if (defined($KeyMap[$key]) && ($KeyMap[$key] ne 'F_PrefixMeta')) {
  699.     warn "Warning$InputLocMsg: ".
  700.       "Re-binding char #$key from [$KeyMap[$key]] to meta.\n" if $^W;
  701.       }
  702.       $KeyMap[$key] = 'F_PrefixMeta';
  703.       $map = "$KeyMap{'name'}_$key";
  704.       InitKeymap(*$map, 'Ding', $map) if !defined(%$map);
  705.       *KeyMap = *$map;
  706.       $key = shift @keys;
  707.       #&actually_do_binding($func, \@keys);
  708.     }
  709.     if (defined($KeyMap[$key]) && $KeyMap[$key] eq 'F_PrefixMeta'
  710.     && $func ne 'PrefixMeta')
  711.       {
  712.     warn "Warning$InputLocMsg: ".
  713.       " Re-binding char #$key to non-meta ($func)\n" if $^W;
  714.       }
  715.     $KeyMap[$key] = "F_$func";
  716.   }
  717. }
  718.  
  719. sub rl_bind
  720. {
  721.     my (@keys, $key, $func, $ord, @arr);
  722.  
  723.     while (defined($key = shift(@_)) && defined($func = shift(@_)))
  724.     {
  725.     ##
  726.     ## Change the function name from something like
  727.     ##    backward-kill-line
  728.     ## to
  729.     ##    BackwardKillLine
  730.     ## if not already there.
  731.     ##
  732.     $func = "\u$func";
  733.     $func =~ s/-(.)/\u$1/g;        
  734.  
  735.     # Temporary disabled
  736.     if (!$autoload_broken and !defined($ {'readline::'}{"F_$func"})) {
  737.         warn "Warning$InputLocMsg: bad bind function [$func]\n" if $^W;
  738.         next;
  739.     }
  740.  
  741.     ## print "sequence [$key] func [$func]\n"; ##DEBUG
  742.  
  743.     @keys = ();
  744.      ## See if it's a new-style binding.
  745.     if ($key =~ m/"(.*[^\\])"/) {
  746.         $key = $1;
  747.         ## New-style bindings are enclosed in double-quotes.
  748.         ## Characters are taken verbatim except the special cases:
  749.         ##    \C-x    Control x (for any x)
  750.         ##    \M-x    Meta x (for any x)
  751.         ##    \e      Escape
  752.         ##    \x      x  (unless it fits the above pattern)
  753.         ## Look for special case of "\C-\M-x", which should be treated
  754.         ## like "\M-\C-x".
  755.         
  756.         while (length($key) > 0) {
  757.         if ($key =~ s#\\C-\\M-(.)##) {
  758.            push(@keys, ord("\e"), &ctrl(ord($1)));
  759.         } elsif ($key =~ s#\\C-(.)##) {
  760.            push(@keys, &ctrl(ord($1)));
  761.         } elsif ($key =~ s#\\(M-|e)##) {
  762.            push(@keys, ord("\e"));
  763.         } elsif ($key =~ s#\\(.)##) {
  764.            push(@keys, ord($1));
  765.         } else {
  766.            push(@keys, ord($key));
  767.            substr($key,0,1) = '';
  768.         }
  769.         }
  770.     } else {
  771.         ## ol-dstyle binding... only one key (or Meta+key)
  772.         my ($isctrl, $orig) = (0, $key);
  773.         $isctrl = $key =~ s/(C|Control|CTRL)-//i;
  774.         push(@keys, ord("\e")) if $key =~ s/(M|Meta)-//i; ## is meta?
  775.         ## Isolate key part. This matches GNU's implementation.
  776.         ## If the key is '-', be careful not to delete it!
  777.         $key =~ s/.*-(.)/$1/;
  778.         if    ($key =~ /^(space|spc)$/i)   { $key = ' ';    }
  779.         elsif ($key =~ /^(rubout|del)$/i)  { $key = "\x7f"; }
  780.         elsif ($key =~ /^tab$/i)           { $key = "\t";   }
  781.         elsif ($key =~ /^(return|ret)$/i)  { $key = "\r";   }
  782.         elsif ($key =~ /^(newline|lfd)$/i) { $key = "\n";   }
  783.         elsif ($key =~ /^(escape|esc)$/i)  { $key = "\e";   }
  784.         elsif (length($key) > 1) {
  785.             warn "Warning$InputLocMsg: strange binding [$orig]\n" if $^W;
  786.         }
  787.         $key = ord($key);
  788.         $key = &ctrl($key) if $isctrl;
  789.         push(@keys, $key);
  790.     }
  791.  
  792.     # 
  793.     ## Now do the mapping of the sequence represented in @keys
  794.      #
  795.     # print "&actually_do_binding($func, @keys)\n"; ##DEBUG
  796.     push @arr, $func, [@keys];
  797.     #&actually_do_binding($func, \@keys);
  798.     }
  799.     &actually_do_binding(@arr);
  800. }
  801.  
  802. sub F_ReReadInitFile
  803. {
  804.     my ($file) = $ENV{'HOME'}."/.inputrc";
  805.     return if !open(RC, $file);
  806.     my (@action) = ('exec'); ## exec, skip, ignore (until appropriate endif)
  807.     my (@level) = ();        ## if, else
  808.  
  809.     while (<RC>) {
  810.     s/^\s*//;
  811.     next if m/^#/;
  812.     $InputLocMsg = " [$file line $.]";
  813.     if (/^\$if\s+/) {
  814.         my($test) = $';
  815.         push(@level, 'if');
  816.         if ($action[$#action] ne 'exec') {
  817.         ## We're supposed to be skipping or ignoring this level,
  818.         ## so for subsequent levels we really ignore completely.
  819.         push(@action, 'ignore');
  820.         } else {
  821.         ## We're executing this IF... do the test.
  822.         ## The test is either "term=xxxx", or just a string that
  823.         ## we compare to $rl_readline_name;
  824.         if ($test =~ /term=([a-z0-9]+)/) {
  825.             $test = $1 eq $ENV{'TERM'};
  826.         } else {
  827.             $test = $test =~ /^(perl|$rl_readline_name)\s*$/i;
  828.         }
  829.         push(@action, $test ? 'exec' : 'skip');
  830.         }
  831.         next;
  832.     } elsif (/^\$endif\b/) {
  833.         die qq/\rWarning$InputLocMsg: unmatched endif\n/ if @level == 0;
  834.         pop(@level);
  835.         pop(@action);
  836.         next;
  837.     } elsif (/^\$else\b/) {
  838.         die qq/\rWarning$InputLocMsg: unmatched else\n/ if
  839.         @level == 0 || $level[$#level] ne 'if';
  840.         $level[$#level] = 'else'; ## an IF turns into an ELSE
  841.         if ($action[$#action] eq 'skip') {
  842.         $action[$#action] = 'exec'; ## if were SKIPing, now EXEC
  843.         } else {
  844.         $action[$#action] = 'ignore'; ## otherwise, just IGNORE.
  845.         }
  846.         next;
  847.     } elsif ($action[$#action] ne 'exec') {
  848.         ## skipping this one....
  849.     } elsif (m/\s*set\s+(\S+)\s+(\S*)\s*$/) {
  850.         &rl_set($1, $2, $file);
  851.     } elsif (m/^\s*(\S+):\s+("[^\"]*")\s*$/) {
  852.         &rl_bind($1, $2);
  853.     } elsif (m/^\s*(\S+):\s+(\S+)\s*$/) {
  854.         &rl_bind($1, $2);
  855.     } else {
  856.         chop;
  857.         warn "\rWarning$InputLocMsg: Bad line [$_]\n" if $^W;
  858.     }
  859.     }
  860.     close(RC);
  861.     ##undef(&F_ReReadInitFile); ## you can do this if you're low on memory
  862. }
  863.  
  864. sub readline_dumb {
  865.     print $term_OUT $prompt;
  866.     return undef
  867.           if !defined($line = $Term::ReadLine::Perl::term->get_line);
  868.     chop($line);
  869.     $| = $oldbar;
  870.     select $old;
  871.     return $line;
  872. }
  873.  
  874.  
  875. ##
  876. ## This is it. Called as &readline'readline($prompt, $default),
  877. ## (DEFAULT can be omitted) the next input line is returned (undef on EOF).
  878. ##
  879. sub readline
  880. {
  881.     $Term::ReadLine::Perl::term->register_Tk 
  882.       if not $Term::ReadLine::registered and $Term::ReadLine::toloop
  883.     and defined &Tk::DoOneEvent;
  884.     if ($stdin_not_tty) {
  885.     return undef if !defined($line = <$term_IN>);
  886.     chop($line);
  887.     return $line;
  888.     }
  889.  
  890.     $old = select $term_OUT;
  891.     $oldbar = $|;
  892.     local($|) = 1;
  893.     local($input);
  894.  
  895.     ## prompt should be given to us....
  896.     $prompt = defined($_[0]) ? $_[0] : 'INPUT> ';
  897.  
  898.     if ($dumb_term) {
  899.     return readline_dumb;
  900.     }
  901.  
  902.     # test if we resume an 'Operate' command
  903.     if ($rl_OperateCount > 0 && (!defined $_[1] || $_[1] eq '')) {
  904.     ## it's from a valid previous 'Operate' command and
  905.     ## user didn't give a default line
  906.     ## we leave $rl_HistoryIndex untouched
  907.     $line = $rl_History[$rl_HistoryIndex];
  908.     } else {
  909.     ## set history pointer at the end of history
  910.     $rl_HistoryIndex = $#rl_History + 1;
  911.     $rl_OperateCount = 0;
  912.     $line = defined $_[1] ? $_[1] : '';
  913.     }
  914.     $rl_OperateCount-- if $rl_OperateCount > 0;
  915.  
  916.     $line_for_revert = $line;
  917.  
  918. # I don't think we need to do this, actually...
  919. #    while (ioctl(STDIN,$FIONREAD,$fion))
  920. #    {
  921. #    local($n_chars_available) = unpack ($fionread_t, $fion);
  922. #    ## print "n_chars = $n_chars_available\n";
  923. #    last if $n_chars_available == 0;
  924. #    $line .= getc;  # should we prepend if $rl_start_default_at_beginning?
  925. #    }
  926.  
  927.     $D = $rl_start_default_at_beginning ? 0 : length($line); ## set dot.
  928.     $LastCommandKilledText = 0;     ## heck, was no last command.
  929.     $lastcommand = '';            ## Well, there you go.
  930.  
  931.     ##
  932.     ## some stuff for &redisplay.
  933.     ##
  934.     $lastredisplay = '';    ## Was no last redisplay for this time.
  935.     $lastlen = length($lastredisplay);
  936.     $lastdelta = 0;        ## Cursor was nowhere
  937.     $si = 0;            ## Want line to start left-justified
  938.     $force_redraw = 1;        ## Want to display with brute force.
  939.     if (!eval {SetTTY()}) {    ## Put into raw mode.
  940.         warn $@ if $@;
  941.         $dumb_term = 1;
  942.     return readline_dumb;
  943.     }
  944.     &redisplay();         ## Show the line (just prompt at this point).
  945.  
  946.     *KeyMap = $var_EditingMode;
  947.     undef($AcceptLine);        ## When set, will return its value.
  948.     undef($ReturnEOF);        ## ...unless this on, then return undef.
  949.     undef($pending);        ## If set, contains text to use as input.
  950.     @undo = ();            ## Undo history starts empty for each line.
  951.  
  952.     # pretend input if we 'Operate' on more than one line
  953.     &F_OperateAndGetNext($rl_OperateCount) if $rl_OperateCount > 0;
  954.  
  955.     while (!defined($AcceptLine)) {
  956.     ## get a character of input
  957.     if (!defined($pending)) {
  958.         $input = rl_getc(); # bug in debugger, returns 42. - No more!
  959.     } else {
  960.         $input = substr($pending, 0, 1);
  961.         substr($pending, 0, 1) = '';
  962.         undef($pending) if length($pending) == 0;
  963.     }
  964.  
  965.     push(@undo, &savestate); ## save state so we can undo.
  966.  
  967.     $ThisCommandKilledText = 0;
  968.     ##print "\n\rline is @$D:[$line]\n\r"; ##DEBUG
  969.     &do_command(*KeyMap, 1, ord($input)); ## actually execute input
  970.     &redisplay();
  971.     $LastCommandKilledText = $ThisCommandKilledText;
  972.     }
  973.  
  974.     undef @undo; ## Release the memory.
  975.     &ResetTTY;   ## Restore the tty state.
  976.     $| = $oldbar;
  977.     select $old;
  978.     return undef if defined($ReturnEOF);
  979.     #print STDOUT "|al=`$AcceptLine'";
  980.     $AcceptLine; ## return the line accepted.
  981. }
  982.  
  983. ## ctrl(ord('a')) will return the ordinal for Ctrl-A.
  984. sub ctrl {
  985.   $_[0] & ~ (($_[0]>=ord('a') && $_[0]<=ord('z')) ? 0x60 : 0x40);
  986. }
  987.  
  988.  
  989.  
  990. sub SetTTY {
  991.     return if $dumb_term || $stdin_not_tty;
  992.     #return system 'stty raw -echo' if defined &DB::DB;
  993.     if (defined $term_readkey) {
  994.       Term::ReadKey::ReadMode(4, $term_IN);
  995.       return 1;
  996.     }
  997. #   system 'stty raw -echo';
  998.  
  999.     $sgttyb = ''; ## just to quiet "perl -w";
  1000.   if ($useioctl && $^O ne 'solaris' && ioctl($term_IN,$TIOCGETP,$sgttyb)) {
  1001.     @tty_buf = unpack($sgttyb_t,$sgttyb);
  1002.     if (defined $ENV{OS2_SHELL}) {
  1003.       $tty_buf[3] &= ~$mode;
  1004.       $tty_buf[3] &= ~$ECHO;
  1005.     } else {
  1006.       $tty_buf[4] |= $mode;
  1007.       $tty_buf[4] &= ~$ECHO;
  1008.     }
  1009.     $sgttyb = pack($sgttyb_t,@tty_buf);
  1010.     ioctl($term_IN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!";
  1011.   } else {
  1012.      warn <<EOW if $useioctl and not defined $ENV{PERL_READLINE_NOWARN};
  1013. Can't ioctl TIOCGETP: $!
  1014. Consider installing Term::ReadKey from CPAN site nearby
  1015.     at http://www.perl.com/CPAN
  1016. Or use
  1017.     perl -MCPAN -e shell
  1018. to reach CPAN. Falling back to 'stty'.
  1019.     If you do not want to see this warning, set PERL_READLINE_NOWARN
  1020. in your environment.
  1021. EOW
  1022.                     # '; # For Emacs. 
  1023.      $useioctl = 0;
  1024.      system 'stty raw -echo' and die "Cannot call `stty': $!";
  1025.   }
  1026.   return 1;
  1027. }
  1028.  
  1029. sub ResetTTY {
  1030.     return if $dumb_term || $stdin_not_tty;
  1031.     #return system 'stty -raw echo' if defined &DB::DB;
  1032.     if (defined $term_readkey) {
  1033.       return Term::ReadKey::ReadMode(0, $term_IN);
  1034.     }
  1035.  
  1036. #   system 'stty -raw echo';
  1037.   if ($useioctl) {
  1038.     ioctl($term_IN,$TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!";
  1039.     @tty_buf = unpack($sgttyb_t,$sgttyb);
  1040.     if (defined $ENV{OS2_SHELL}) {
  1041.       $tty_buf[3] |= $mode;
  1042.       $tty_buf[3] |= $ECHO;
  1043.     } else {
  1044.       $tty_buf[4] &= ~$mode;
  1045.       $tty_buf[4] |= $ECHO;
  1046.     }
  1047.     $sgttyb = pack($sgttyb_t,@tty_buf);
  1048.     ioctl($term_IN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!";
  1049.   } else {
  1050.     system 'stty -raw echo' and die "Cannot call `stty': $!";
  1051.   }
  1052. }
  1053.  
  1054. # Substr_with_props: gives the substr of prompt+string with embedded
  1055. # face-change commands
  1056.  
  1057. sub substr_with_props {
  1058.   my ($p, $s, $from, $len) = @_;
  1059.   my $lp = length $p;
  1060.  
  1061.   defined $from or $from = 0;
  1062.   defined $len or $len = length($p) + length($s) - $from;
  1063.  
  1064.   if ($from >= $lp) {
  1065.     return $rl_term_set->[2] . substr($s, $from - $lp, $len) 
  1066.       . $rl_term_set->[3];
  1067.   } elsif ($from + $len <= $lp) {
  1068.     return $rl_term_set->[0] . substr($prompt, $from, $len) 
  1069.       . $rl_term_set->[1];
  1070.   } else {
  1071.     return $rl_term_set->[0] . substr($prompt, $from, $lp - $from) 
  1072.       . $rl_term_set->[1]
  1073.     . $rl_term_set->[2] . substr($s, 0, $from + $len - $lp) 
  1074.       . $rl_term_set->[3];
  1075.   }
  1076. }
  1077.  
  1078. ##
  1079. ## redisplay()
  1080. ##
  1081. ## Updates the screen to reflect the current $line.
  1082. ##
  1083. ## For the purposes of this routine, we prepend the prompt to a local copy of
  1084. ## $line so that we display the prompt as well.  We then modify it to reflect
  1085. ## that some characters have different sizes (i.e. control-C is represented
  1086. ## as ^C, tabs are expanded, etc.)
  1087. ##
  1088. ## This routine is somewhat complicated by two-byte characters.... must
  1089. ## make sure never to try do display just half of one.
  1090. ##
  1091. ## NOTE: If an argument is given, it is used instead of the prompt.
  1092. ##
  1093. ## This is some nasty code.
  1094. ##
  1095. sub redisplay
  1096. {
  1097.     ## local $line has prompt also; take that into account with $D.
  1098.     local($prompt) = defined($_[0]) ? $_[0] : $prompt;
  1099.     my $oline;
  1100.     local($line) = $prompt . $line;
  1101.     local($D) = $D + length($prompt);
  1102.  
  1103.     ##
  1104.     ## If the line contains anything that might require special processing
  1105.     ## for displaying (such as tabs, control characters, etc.), we will
  1106.     ## take care of that now....
  1107.     ##
  1108.     if ($line =~ m/[^\x20-\x7e]/)
  1109.     {
  1110.     local($new, $Dinc, $c) = ('', 0);
  1111.  
  1112.     ## Look at each character of $line in turn.....
  1113.         for ($i = 0; $i < length($line); $i++) {
  1114.         $c = substr($line, $i, 1);
  1115.  
  1116.         ## A tab to expand...
  1117.         if ($c eq "\t") {
  1118.         $c = ' ' x  (8 - (($i-length($prompt)) % 8));
  1119.  
  1120.         ## A control character....
  1121.         } elsif ($c =~ tr/\000-\037//) {
  1122.         $c = sprintf("^%c", ord($c)+ord('@'));
  1123.  
  1124.         ## the delete character....
  1125.         } elsif (ord($c) == 127) {
  1126.         $c = '^?';
  1127.         }
  1128.         $new .= $c;
  1129.  
  1130.         ## Bump over $D if this char is expanded and left of $D.
  1131.         $Dinc += length($c) - 1 if (length($c) > 1 && $i < $D);
  1132.     }
  1133.     $line = $new;
  1134.     $D += $Dinc;
  1135.     }
  1136.  
  1137.     ##
  1138.     ## Now $line is what we'd like to display.
  1139.     ##
  1140.     ## If it's too long to fit on the line, we must decide what we can fit.
  1141.     ##
  1142.     ## If we end up moving the screen index ($si) [index of the leftmost
  1143.     ## character on the screen], to some place other than the front of the
  1144.     ## the line, we'll have to make sure that it's not on the first byte of
  1145.     ## a 2-byte character, 'cause we'll be placing a '<' marker there, and
  1146.     ## that would screw up the 2-byte character.
  1147.     ##
  1148.     ## Similarly, if the line needs chopped off, we make sure that the
  1149.     ## placement of the tailing '>' won't screw up any 2-byte character in
  1150.     ## the vicinity.
  1151.     ##
  1152.     if ($D == length($prompt)) {
  1153.     $si = 0;   ## display from the beginning....
  1154.     } elsif ($si >= $D) {
  1155.     $si = &max(0, $D - $rl_margin);
  1156.     $si-- if $si != length($prompt) && !&OnSecondByte($si);
  1157.     } elsif ($si + $rl_screen_width <= $D) {
  1158.     $si = &min(length($line), ($D - $rl_screen_width) + $rl_margin);
  1159.     $si-- if $si != length($prompt) && !&OnSecondByte($si);
  1160.     } else {
  1161.     ## Fine as-is.... don't need to change $si.
  1162.     }
  1163.     substr($line, $si, 1) = '<' if $si != 0; ## put the "chopped-off" marker
  1164.  
  1165.     $thislen = &min(length($line) - $si, $rl_screen_width);
  1166.     if ($si + $thislen < length($line)) {
  1167.     ## need to place a '>'... make sure to place on first byte.
  1168.     $thislen-- if &OnSecondByte($si+$thislen-1);
  1169.     substr($line, $si+$thislen-1,1) = '>';
  1170.     }
  1171.  
  1172.     ##
  1173.     ## Now know what to display.
  1174.     ## Must get substr($line, $si, $thislen) on the screen,
  1175.     ## with the cursor at $D-$si characters from the left edge.
  1176.     ##
  1177.     $line = substr($line, $si, $thislen);
  1178.     $delta = $D - $si;    ## delta is cursor distance from left margin.
  1179.     if ($si > length($prompt)) {
  1180.       $prompt = "";
  1181.       $oline = $line;
  1182.     } else {
  1183.       $oline = substr($line, (length $prompt) - $si);
  1184.       $prompt = substr($prompt,$si);
  1185.     }
  1186.  
  1187.     ##
  1188.     ## Now must output $line, with cursor $delta spaces from left margin.
  1189.     ##
  1190.  
  1191.     ##
  1192.     ## If $force_redraw is not set, we can attempt to optimize the redisplay
  1193.     ## However, if we don't happen to find an easy way to optimize, we just
  1194.     ## fall through to the brute-force method of re-drawing the whole line.
  1195.     ##
  1196.     if (!$force_redraw)
  1197.     {
  1198.     ## can try to optimize here a bit.
  1199.  
  1200.     ## For when we only need to move the cursor
  1201.     if ($lastredisplay eq $line) {
  1202.         ## If we need to move forward, just overwrite as far as we need.
  1203.         if ($lastdelta < $delta) {
  1204.         print $term_OUT substr_with_props($prompt, $oline, $lastdelta, $delta-$lastdelta);
  1205.  
  1206.         ## Need to move back.
  1207.         } elsif($lastdelta > $delta) {
  1208.         ## Two ways to move back... use the fastest. One is to just
  1209.         ## backspace the proper amount. The other is to jump to the
  1210.         ## the beginning of the line and overwrite from there....
  1211.         if ($lastdelta - $delta < $delta) {
  1212.             print $term_OUT "\b" x ($lastdelta - $delta);
  1213.         } else {
  1214.             print $term_OUT "\r", substr_with_props($prompt, $oline, 0, $delta);
  1215.         }
  1216.         }
  1217.         ($lastlen, $lastredisplay, $lastdelta) = ($thislen, $line, $delta);
  1218.         return;
  1219.     }
  1220.  
  1221.     ## for when we've just added stuff to the end
  1222.     if ($thislen > $lastlen &&
  1223.         $lastdelta == $lastlen &&
  1224.         $delta == $thislen &&
  1225.         substr($line, 0, $lastlen) eq $lastredisplay)
  1226.     {
  1227.         print $term_OUT substr_with_props($prompt, $oline, $lastdelta);
  1228.         ($lastlen, $lastredisplay, $lastdelta) = ($thislen, $line, $delta);
  1229.         return;
  1230.     }
  1231.  
  1232.     ## There is much more opportunity for optimizing.....
  1233.     ## something to work on later.....
  1234.     }
  1235.  
  1236.     ##
  1237.     ## Brute force method of redisplaying... redraw the whole thing.
  1238.     ##
  1239.  
  1240.     print $term_OUT "\r", substr_with_props($prompt, $oline);
  1241.     print $term_OUT ' ' x ($lastlen - $thislen) if $lastlen > $thislen;
  1242.  
  1243.     print $term_OUT "\r",substr_with_props($prompt, $oline, 0, $delta)
  1244.     if $delta != length ($line) || $lastlen > $thislen;
  1245.  
  1246.     ($lastlen, $lastredisplay, $lastdelta) = ($thislen, $line, $delta);
  1247.  
  1248.     $force_redraw = 0;
  1249. }
  1250.  
  1251. sub min     { $_[0] < $_[1] ? $_[0] : $_[1]; }
  1252.  
  1253. sub rl_getc {
  1254.       if (defined $term_readkey) { # XXXX ???
  1255.         $Term::ReadLine::Perl::term->Tk_loop 
  1256.           if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
  1257.         $key = Term::ReadKey::ReadKey(0, $term_IN);
  1258.       } else {
  1259.         $key = $Term::ReadLine::Perl::term->get_c;
  1260.       }
  1261. }
  1262.  
  1263. ##
  1264. ## do_command(keymap, numericarg, command)
  1265. ##
  1266. ## If the KEYMAP has an entry for COMMAND, it is executed.
  1267. ## Otherwise, the default command for the keymap is executed.
  1268. ##
  1269. sub do_command
  1270. {
  1271.     local *KeyMap = shift;
  1272.     my ($count, $key) = @_;
  1273.     my $cmd = defined($KeyMap[$key]) ? $KeyMap[$key] : $KeyMap{'default'};
  1274.     if (!defined($cmd) || $cmd eq ''){
  1275.     warn "internal error (key=$key)";
  1276.     } else {
  1277.     ## print "COMMAND [$cmd($count, $key)]\r\n"; ##DEBUG
  1278.     &$cmd($count, $key);
  1279.     }
  1280.     $lastcommand = $cmd;
  1281. }
  1282.  
  1283. ##
  1284. ## Save whatever state we wish to save as a string.
  1285. ## Only other function that needs to know about it's encoded is getstate.
  1286. ##
  1287. sub savestate
  1288. {
  1289.     join("\0", $D, $si, $LastCommandKilledText, $KillBuffer, $line);
  1290. }
  1291.  
  1292.  
  1293. ##
  1294. ## $_[1] is an ASCII ordinal; inserts as per $count.
  1295. ##
  1296. sub F_SelfInsert
  1297. {
  1298.     my ($count, $ord) = @_;
  1299.     my $text2add = pack('c', $ord) x $count;
  1300.     if ($InsertMode) {
  1301.     substr($line,$D,0) .= $text2add;
  1302.     } else {
  1303.     ## note: this can screw up with 2-byte characters.
  1304.     substr($line,$D,length($text2add)) = $text2add;
  1305.     }
  1306.     $D += length($text2add);
  1307. }
  1308.  
  1309. ##
  1310. ## Return the line as-is to the user.
  1311. ##
  1312. sub F_AcceptLine
  1313. {
  1314.     ##
  1315.     ## Insert into history list if:
  1316.     ##     * bigger than the minimal length
  1317.     ##   * not same as last entry
  1318.     ##
  1319.     if (length($line) >= $minlength 
  1320.     && (!@rl_History || $rl_History[$#rl_History] ne $line)
  1321.        ) {
  1322.     ## if the history list is full, shift out an old one first....
  1323.     while (@rl_History >= $rl_MaxHistorySize) {
  1324.         shift(@rl_History);
  1325.         $rl_HistoryIndex--;
  1326.     }
  1327.     push(@rl_History, $line); ## tack new one on the end
  1328.     }
  1329.     $AcceptLine = $line;
  1330.     print $term_OUT "\r\n";
  1331. }
  1332.  
  1333. #sub F_ReReadInitFile;
  1334. #sub rl_getc;
  1335. sub F_ForwardChar;
  1336. sub F_BackwardChar;
  1337. sub F_BeginningOfLine;
  1338. sub F_EndOfLine;
  1339. sub F_ForwardWord;
  1340. sub F_BackwardWord;
  1341. sub F_RedrawCurrentLine;
  1342. sub F_ClearScreen;
  1343. # sub F_SelfInsert;
  1344. sub F_QuotedInsert;
  1345. sub F_TabInsert;
  1346. #sub F_AcceptLine;
  1347. sub F_OperateAndGetNext;
  1348. sub F_BackwardDeleteChar;
  1349. sub F_DeleteChar;
  1350. sub F_UnixWordRubout;
  1351. sub F_UnixLineDiscard;
  1352. sub F_UpcaseWord;
  1353. sub F_DownCaseWord;
  1354. sub F_CapitalizeWord;
  1355. sub F_TransposeWords;
  1356. sub F_TransposeChars;
  1357. sub F_PreviousHistory;
  1358. sub F_NextHistory;
  1359. sub F_BeginningOfHistory;
  1360. sub F_EndOfHistory;
  1361. sub F_ReverseSearchHistory;
  1362. sub F_ForwardSearchHistory;
  1363. sub F_HistorySearchBackward;
  1364. sub F_HistorySearchForward;
  1365. sub F_KillLine;
  1366. sub F_BackwardKillLine;
  1367. sub F_Yank;
  1368. sub F_YankPop;
  1369. sub F_YankNthArg;
  1370. sub F_KillWord;
  1371. sub F_BackwardKillWord;
  1372. sub F_Abort;
  1373. sub F_DoLowercaseVersion;
  1374. sub F_Undo;
  1375. sub F_RevertLine;
  1376. sub F_EmacsEditingMode;
  1377. sub F_ToggleEditingMode;
  1378. sub F_Interrupt;
  1379. sub F_PrefixMeta;
  1380. sub F_UniversalArgument;
  1381. sub F_DigitArgument;
  1382. sub F_OverwriteMode;
  1383. sub F_InsertMode;
  1384. sub F_ToggleInsertMode;
  1385. sub F_Suspend;
  1386. sub F_Ding;
  1387. sub F_PossibleCompletions;
  1388. sub F_Complete;
  1389. # Comment these 2 lines and __DATA__ line somewhere below to disable
  1390. # selfloader.
  1391.  
  1392. use SelfLoader;
  1393.  
  1394. 1;
  1395. __DATA__
  1396.  
  1397. # From here on anything may be autoloaded
  1398.  
  1399. sub max     { $_[0] > $_[1] ? $_[0] : $_[1]; }
  1400. sub isupper { ord($_[0]) >= ord('A') && ord($_[0]) <= ord('Z'); }
  1401. sub islower { ord($_[0]) >= ord('a') && ord($_[0]) <= ord('z'); }
  1402. sub toupper { &islower ? pack('c', ord($_[0])-ord('a')+ord('A')) : $_[0];}
  1403. sub tolower { &isupper ? pack('c', ord($_[0])-ord('A')+ord('a')) : $_[0];}
  1404.  
  1405. ##
  1406. ## rl_set(var_name, value_string)
  1407. ##
  1408. ## Sets the named variable as per the given value, if both are appropriate.
  1409. ## Allows the user of the package to set such things as HorizontalScrollMode
  1410. ## and EditingMode.  Value_string may be of the form
  1411. ##    HorizontalScrollMode
  1412. ##      horizontal-scroll-mode
  1413. ##
  1414. ## Also called during the parsing of ~/.inputrc for "set var value" lines.
  1415. ##
  1416. ## The previous value is returned, or undef on error.
  1417. ###########################################################################
  1418. ## Consider the following example for how to add additional variables
  1419. ## accessible via rl_set (and hence via ~/.inputrc).
  1420. ##
  1421. ## Want:
  1422. ## We want an external variable called "FooTime" (or "foo-time").
  1423. ## It may have values "January", "Monday", or "Noon".
  1424. ## Internally, we'll want those values to translate to 1, 2, and 12.
  1425. ##
  1426. ## How:
  1427. ## Have an internal variable $var_FooTime that will represent the current
  1428. ## internal value, and initialize it to the default value.
  1429. ## Make an array %var_FooTime whose keys and values are are the external
  1430. ## (January, Monday, Noon) and internal (1, 2, 12) values:
  1431. ##
  1432. ##        $var_FooTime = $var_FooTime{'January'} =  1; #default
  1433. ##                       $var_FooTime{'Monday'}  =  2;
  1434. ##                       $var_FooTime{'Noon'}    = 12;
  1435. ##
  1436. sub rl_set
  1437. {
  1438.     local($var, $val) = @_;
  1439.  
  1440.     $var = 'CompleteAddsuffix' if $var eq 'visible-stats';
  1441.  
  1442.     ## if the variable is in the form "some-name", change to "SomeName"
  1443.     local($_) = "\u$var";
  1444.     local($return) = undef;
  1445.     s/-(.)/\u$1/g;
  1446.  
  1447.     local(*V) = $ {'readline::'}{"var_$_"};
  1448.     if (!defined($V)) {
  1449.     warn("Warning$InputLocMsg:\n".
  1450.          "  Invalid variable `$var'\n") if $^W;
  1451.     } elsif (!defined($V{$val})) {
  1452.     local(@selections) = keys(%V);
  1453.     warn("Warning$InputLocMsg:\n".
  1454.          "  Invalid value `$val' for variable `$var'.\n".
  1455.          "  Choose from [@selections].\n") if $^W;
  1456.     } else {
  1457.     $return = $V;
  1458.         $V = $V{$val}; ## make the setting
  1459.     }
  1460.     $return;
  1461. }
  1462.  
  1463. ##
  1464. ## OnSecondByte($index)
  1465. ##
  1466. ## Returns true if the byte at $index into $line is the second byte
  1467. ## of a two-byte character.
  1468. ##
  1469. sub OnSecondByte
  1470. {
  1471.     return 0 if $_[0] == 0 || $_[0] == length($line);
  1472.  
  1473.     die 'internal error' if $_[0] > length($line);
  1474.  
  1475.     ##
  1476.     ## must start looking from the beginning of the line .... can
  1477.     ## have one- and two-byte characters interspersed, so can't tell
  1478.     ## without starting from some know location.....
  1479.     ##
  1480.     local($i);
  1481.     for ($i = 0; $i < $_[0]; $i++) {
  1482.     next if ord(substr($line, $i, 1)) < 0x80;
  1483.     ## We have the first byte... must bump up $i to skip past the 2nd.
  1484.     ## If that one we're skipping past is the index, it should be changed
  1485.     ## to point to the first byte of the pair (therefore, decremented).
  1486.         return 1 if ++$i == $_[0];
  1487.     }
  1488.     0; ## seemed to be OK.
  1489. }
  1490.  
  1491. ##
  1492. ## CharSize(index)
  1493. ##
  1494. ## Returns the size of the character at the given INDEX in the
  1495. ## current line.  Most characters are just one byte in length,
  1496. ## but if the byte at the index and the one after has the high
  1497. ## bit set those two bytes are one character of size=2.
  1498. ##
  1499. ## Assumes that index points to the first of a 2-byte char if not
  1500. ## pointing to a 2-byte char.
  1501. ##
  1502. sub CharSize
  1503. {
  1504.     return 2 if ord(substr($line, $_[0],   1)) >= 0x80 &&
  1505.                 ord(substr($line, $_[0]+1, 1)) >= 0x80;
  1506.     1;
  1507. }
  1508.  
  1509. sub GetTTY
  1510. {
  1511.     $base_termios = $termios;  # make it long enough
  1512.     ioctl($term_IN,$TCGETS,$base_termios) || die "Can't ioctl TCGETS: $!";
  1513. }
  1514.  
  1515. sub XonTTY
  1516. {
  1517.     # I don't know which of these I actually need to do this to, so we'll
  1518.     # just cover all bases.
  1519.  
  1520.     ioctl($term_IN,$TCXONC,$TCOON);    # || die "Can't ioctl TCXONC STDIN: $!";
  1521.     ioctl($term_OUT,$TCXONC,$TCOON);   # || die "Can't ioctl TCXONC STDOUT: $!";
  1522. }
  1523.  
  1524. sub ___SetTTY
  1525. {
  1526. # print "before SetTTY\n\r";
  1527. # system 'stty -a';
  1528.  
  1529.     &XonTTY;
  1530.  
  1531.     &GetTTY
  1532.     if !defined($base_termios);
  1533.  
  1534.     @termios = unpack($termios_t,$base_termios);
  1535.     $termios[$TERMIOS_IFLAG] |= $TERMIOS_READLINE_ION;
  1536.     $termios[$TERMIOS_IFLAG] &= ~$TERMIOS_READLINE_IOFF;
  1537.     $termios[$TERMIOS_OFLAG] |= $TERMIOS_READLINE_OON;
  1538.     $termios[$TERMIOS_OFLAG] &= ~$TERMIOS_READLINE_OOFF;
  1539.     $termios[$TERMIOS_LFLAG] |= $TERMIOS_READLINE_LON;
  1540.     $termios[$TERMIOS_LFLAG] &= ~$TERMIOS_READLINE_LOFF;
  1541.     $termios[$TERMIOS_VMIN] = 1;
  1542.     $termios[$TERMIOS_VTIME] = 0;
  1543.     $termios = pack($termios_t,@termios);
  1544.     ioctl($term_IN,$TCSETS,$termios) || die "Can't ioctl TCSETS: $!";
  1545.  
  1546. # print "after SetTTY\n\r";
  1547. # system 'stty -a';
  1548. }
  1549.  
  1550. sub normal_tty_mode
  1551. {
  1552.     return if $stdin_not_tty || $dumb_term || !$initialized;
  1553.     &XonTTY;
  1554.     &GetTTY if !defined($base_termios);
  1555.     &ResetTTY;
  1556. }
  1557.  
  1558. sub ___ResetTTY
  1559. {
  1560. # print "before ResetTTY\n\r";
  1561. # system 'stty -a';
  1562.  
  1563.     @termios = unpack($termios_t,$base_termios);
  1564.     $termios[$TERMIOS_IFLAG] |= $TERMIOS_NORMAL_ION;
  1565.     $termios[$TERMIOS_IFLAG] &= ~$TERMIOS_NORMAL_IOFF;
  1566.     $termios[$TERMIOS_OFLAG] |= $TERMIOS_NORMAL_OON;
  1567.     $termios[$TERMIOS_OFLAG] &= ~$TERMIOS_NORMAL_OOFF;
  1568.     $termios[$TERMIOS_LFLAG] |= $TERMIOS_NORMAL_LON;
  1569.     $termios[$TERMIOS_LFLAG] &= ~$TERMIOS_NORMAL_LOFF;
  1570.     $termios = pack($termios_t,@termios);
  1571.     ioctl($term_IN,$TCSETS,$termios) || die "Can't ioctl TCSETS: $!";
  1572.  
  1573. # print "after ResetTTY\n\r";
  1574. # system 'stty -a';
  1575. }
  1576.  
  1577. ##
  1578. ## WordBreak(index)
  1579. ##
  1580. ## Returns true if the character at INDEX into $line is a basic word break
  1581. ## character, false otherwise.
  1582. ##
  1583. sub WordBreak
  1584. {
  1585.     index($rl_basic_word_break_characters, substr($line,$_[0],1)) != -1;
  1586. }
  1587.  
  1588. sub getstate
  1589. {
  1590.     ($D, $si, $LastCommandKilledText, $KillBuffer, $line) = split(/\0/, $_[0]);
  1591.     $ThisCommandKilledText = $LastCommandKilledText;
  1592. }
  1593.  
  1594. ##
  1595. ## kills from D=$_[0] to $_[1] (to the killbuffer if $_[2] is true)
  1596. ##
  1597. sub kill_text
  1598. {
  1599.     my($from, $to, $save) = (&min($_[0], $_[1]), &max($_[0], $_[1]), $_[2]);
  1600.     my $len = $to - $from;
  1601.     if ($save) {
  1602.     $ThisCommandKilledText = 1;
  1603.     $KillBuffer = '' if !$LastCommandKilledText;
  1604.     $KillBuffer .= substr($line, $from, $len);
  1605.     }
  1606.     substr($line, $from, $len) = '';
  1607.  
  1608.     ## adjust $D
  1609.     if ($D > $from) {
  1610.     $D -= $len;
  1611.     $D = $from if $D < $from;
  1612.     }
  1613. }
  1614.  
  1615.  
  1616. ###########################################################################
  1617. ## Bindable functions... pretty much in the same order as in readline.c ###
  1618. ###########################################################################
  1619.  
  1620. ##
  1621. ## Returns true if $D at the end of the line.
  1622. ##
  1623. sub at_end_of_line
  1624. {
  1625.     ($D + &CharSize($D)) == (length($line) + 1);
  1626. }
  1627.  
  1628.  
  1629. ##
  1630. ## Move forward (right) $count characters.
  1631. ##
  1632. sub F_ForwardChar
  1633. {
  1634.     my $count = shift;
  1635.     return &F_BackwardChar(-$count) if $count < 0;
  1636.  
  1637.     while (!&at_end_of_line && $count-- > 0) {
  1638.     $D += &CharSize($D);
  1639.     }
  1640. }
  1641.  
  1642. ##
  1643. ## Move backward (left) $count characters.
  1644. ##
  1645. sub F_BackwardChar
  1646. {
  1647.     my $count = shift;
  1648.     return &F_ForwardChar(-$count) if $count < 0;
  1649.  
  1650.     while (($D > 0) && ($count-- > 0)) {
  1651.     $D--;                     ## Move back one regardless,
  1652.     $D-- if &OnSecondByte($D); ## another if over a big char.
  1653.     }
  1654. }
  1655.  
  1656. ##
  1657. ## Go to beginning of line.
  1658. ##
  1659. sub F_BeginningOfLine
  1660. {
  1661.     $D = 0;
  1662. }
  1663.  
  1664. ##
  1665. ## Move to the end of the line.
  1666. ##
  1667. sub F_EndOfLine
  1668. {
  1669.     &F_ForwardChar(100) while !&at_end_of_line;
  1670. }
  1671.  
  1672. ##
  1673. ## Move to the end of this/next word.
  1674. ## Done as many times as $count says.
  1675. ##
  1676. sub F_ForwardWord
  1677. {
  1678.     my $count = shift;
  1679.     return &F_BackwardWord(-$count) if $count < 0;
  1680.  
  1681.     while (!&at_end_of_line && $count-- > 0)
  1682.     {
  1683.     ## skip forward to the next word (if not already on one)
  1684.     &F_ForwardChar(1) while !&at_end_of_line && &WordBreak($D);
  1685.     ## skip forward to end of word
  1686.     &F_ForwardChar(1) while !&at_end_of_line && !&WordBreak($D);
  1687.     }
  1688. }
  1689.  
  1690. ##
  1691. ## 
  1692. ## Move to the beginning of this/next word.
  1693. ## Done as many times as $count says.
  1694. ##
  1695. sub F_BackwardWord
  1696. {
  1697.     my $count = shift;
  1698.     return &F_ForwardWord(-$count) if $count < 0;
  1699.  
  1700.     while ($D > 0 && $count-- > 0) {
  1701.     ## skip backward to the next word (if not already on one)
  1702.     &F_BackwardChar(1) while (($D > 0) && &WordBreak($D-1));
  1703.     ## skip backward to start of word
  1704.     &F_BackwardChar(1) while (($D > 0) && !&WordBreak($D-1));
  1705.     }
  1706. }
  1707.  
  1708. ##
  1709. ## Refresh the input line.
  1710. ##
  1711. sub F_RedrawCurrentLine
  1712. {
  1713.     $force_redraw = 1;
  1714. }
  1715.  
  1716. ##
  1717. ## Clear the screen and refresh the line.
  1718. ## If given a numeric arg other than 1, simply refreshes the line.
  1719. ##
  1720. sub F_ClearScreen
  1721. {
  1722.     my $count = shift;
  1723.     return &F_RedrawCurrentLine if $count != 1;
  1724.  
  1725.     $rl_CLEAR = `clear` if !defined($rl_CLEAR);
  1726.     print $term_OUT $rl_CLEAR;
  1727.     $force_redraw = 1;
  1728. }
  1729.  
  1730. ##
  1731. ## Insert the next character read verbatim.
  1732. ##
  1733. sub F_QuotedInsert
  1734. {
  1735.     my $count = shift;
  1736.     &F_SelfInsert($count, ord(rl_getc));
  1737. }
  1738.  
  1739. ##
  1740. ## Insert a tab.
  1741. ##
  1742. sub F_TabInsert
  1743. {
  1744.     my $count = shift;
  1745.     &F_SelfInsert($count, ord("\t"));
  1746. }
  1747.  
  1748. ## Operate - accept the current line and fetch from the
  1749. ## history the next line relative to current line for default.
  1750. sub F_OperateAndGetNext
  1751. {
  1752.     my $count = shift;
  1753.  
  1754.     &F_AcceptLine;
  1755.  
  1756.     my $remainingEntries = $#rl_History - $rl_HistoryIndex;
  1757.     if ($count > 0 && $remainingEntries >= 0) {  # there is something to repeat
  1758.     if ($remainingEntries > 0) {  # if we are not on last line
  1759.         $rl_HistoryIndex++;       # fetch next one
  1760.         $count = $remainingEntries if $count > $remainingEntries;
  1761.     }
  1762.     $rl_OperateCount = $count;
  1763.     }
  1764. }
  1765.  
  1766. ##
  1767. ## Removes $count chars to left of cursor (if not at beginning of line).
  1768. ## If $count > 1, deleted chars saved to kill buffer.
  1769. ##
  1770. sub F_BackwardDeleteChar
  1771. {
  1772.     my $count = shift;
  1773.     return F_DeleteChar(-$count) if $count < 0;
  1774.     my $oldD = $D;
  1775.     &F_BackwardChar($count);
  1776.     return if $D == $oldD;
  1777.     &kill_text($oldD, $D, $count > 1);
  1778. }
  1779.  
  1780. ##
  1781. ## Removes the $count chars from under the cursor.
  1782. ## If there is no line and the last command was different, tells
  1783. ## readline to return EOF.
  1784. ## If there is a line, and the cursor is at the end of it, and we're in
  1785. ## tcsh completion mode, then list possible completions.
  1786. ## If $count > 1, deleted chars saved to kill buffer.
  1787. ##
  1788. sub F_DeleteChar
  1789. {
  1790.     my $count = shift;
  1791.     return F_DeleteBackwardChar(-$count) if $count < 0;
  1792.     if (length($line) == 0) {    # EOF sent (probably OK in DOS too)
  1793.     $AcceptLine = $ReturnEOF = 1 if $lastcommand ne 'F_DeleteChar';
  1794.     return;
  1795.     }
  1796.     if ($D == length ($line))
  1797.     {
  1798.     &complete_internal('?') if $var_TcshCompleteMode;
  1799.     return;
  1800.     }
  1801.     my $oldD = $D;
  1802.     &F_ForwardChar($count);
  1803.     return if $D == $oldD;
  1804.     &kill_text($oldD, $D, $count > 1);
  1805. }
  1806.  
  1807. ##
  1808. ## Kill to previous whitespace.
  1809. ##
  1810. sub F_UnixWordRubout
  1811. {
  1812.     return &F_Ding if $D == 0;
  1813.     my ($oldD, $rl_basic_word_break_characters) = ($D, "\t ");
  1814.     F_BackwardWord(1);
  1815.     kill_text($D, $oldD, 1);
  1816. }
  1817.  
  1818. ##
  1819. ## Kill line from cursor to beginning of line.
  1820. ##
  1821. sub F_UnixLineDiscard
  1822. {
  1823.     return &F_Ding if $D == 0;
  1824.     kill_text(0, $D, 1);
  1825. }
  1826.  
  1827. sub F_UpcaseWord     { &changecase($_[0], 'up');   }
  1828. sub F_DownCaseWord   { &changecase($_[0], 'down'); }
  1829. sub F_CapitalizeWord { &changecase($_[0], 'cap');  }
  1830.  
  1831. ##
  1832. ## Translated from GNUs readline.c
  1833. ## One arg is 'up' to upcase $_[0] words,
  1834. ##            'down' to downcase them,
  1835. ##         or something else to capitolize them.
  1836. ## If $_[0] is negative, the dot is not moved.
  1837. ##
  1838. sub changecase
  1839. {
  1840.     my $op = $_[1];
  1841.  
  1842.     my ($start, $state, $c, $olddot) = ($D, 0);
  1843.     if ($_[0] < 0)
  1844.     {
  1845.     $olddot = $D;
  1846.     $_[0] = -$_[0];
  1847.     }
  1848.  
  1849.     &F_ForwardWord;  ## goes forward $_[0] words.
  1850.  
  1851.     while ($start < $D) {
  1852.     $c = substr($line, $start, 1);
  1853.  
  1854.     if ($op eq 'up') {
  1855.         $c = &toupper($c);
  1856.     } elsif ($op eq 'down') {
  1857.         $c = &tolower($c);
  1858.     } else { ## must be 'cap'
  1859.         if ($state == 1) {
  1860.             $c = &tolower($c);
  1861.         } else {
  1862.             $c = &toupper($c);
  1863.         $state = 1;
  1864.         }
  1865.         $state = 0 if $c !~ tr/a-zA-Z//;
  1866.     }
  1867.  
  1868.     substr($line, $start, 1) = $c;
  1869.     $start++;
  1870.     }
  1871.     $D = $olddot if defined($olddot);
  1872. }
  1873.  
  1874. sub F_TransposeWords { } ## not implemented yet
  1875.  
  1876. ##
  1877. ## Switch char at dot with char before it.
  1878. ## If at the end of the line, switch the previous two...
  1879. ## (NOTE: this could screw up multibyte characters.. should do correctly)
  1880. sub F_TransposeChars
  1881. {
  1882.     if ($D == length($line) && $D >= 2) {
  1883.         substr($line,$D-2,2) = substr($line,$D-1,1).substr($line,$D-2,1);
  1884.     } elsif ($D >= 1) {
  1885.     substr($line,$D-1,2) = substr($line,$D,1)  .substr($line,$D-1,1);
  1886.     } else {
  1887.     &F_Ding;
  1888.     }
  1889. }
  1890.  
  1891. ##
  1892. ## Use the previous entry in the history buffer (if there is one)
  1893. ##
  1894. sub F_PreviousHistory
  1895. {
  1896.     return if $rl_HistoryIndex == 0;
  1897.  
  1898.     $rl_HistoryIndex--;
  1899.     ($D, $line) = (0, $rl_History[$rl_HistoryIndex]);
  1900.     &F_EndOfLine;
  1901. }
  1902.  
  1903. ##
  1904. ## Use the next entry in the history buffer (if there is one)
  1905. ##
  1906. sub F_NextHistory
  1907. {
  1908.     return if $rl_HistoryIndex > $#rl_History;
  1909.  
  1910.     $rl_HistoryIndex++;
  1911.     if ($rl_HistoryIndex > $#rl_History) {
  1912.     $D = 0;
  1913.     $line = '';
  1914.     } else {
  1915.     ($D, $line) = (0, $rl_History[$rl_HistoryIndex]);
  1916.     &F_EndOfLine;
  1917.     }
  1918. }
  1919.  
  1920. sub F_BeginningOfHistory
  1921. {
  1922.     if ($rl_HistoryIndex != 0) {
  1923.     $rl_HistoryIndex = 0;
  1924.     ($D, $line) = (0, $rl_History[$rl_HistoryIndex]);
  1925.     &F_EndOfLine;
  1926.     }
  1927. }
  1928.  
  1929. sub F_EndOfHistory
  1930. {
  1931.     if (@rl_History != 0 && $rl_HistoryIndex != $#rl_History) {
  1932.     $rl_HistoryIndex = $#rl_History;
  1933.     ($D, $line) = (0, $rl_History[$rl_HistoryIndex]);
  1934.     &F_EndOfLine;
  1935.     }
  1936. }
  1937.  
  1938. sub F_ReverseSearchHistory
  1939. {
  1940.     &DoSearch($_[0] >= 0 ? 1 : 0);
  1941. }
  1942.  
  1943. sub F_ForwardSearchHistory
  1944. {
  1945.     &DoSearch($_[0] >= 0 ? 0 : 1);
  1946. }
  1947.  
  1948. sub F_HistorySearchBackward
  1949. {
  1950.     &DoSearchStart(($_[0] >= 0 ? 1 : 0),substr($line,0,$D));
  1951. }
  1952.  
  1953. sub F_HistorySearchForward
  1954. {
  1955.     &DoSearchStart(($_[0] >= 0 ? 0 : 1),substr($line,0,$D));
  1956. }
  1957.  
  1958. ## returns a new $i or -1 if not found.
  1959. sub search { 
  1960.   my ($i, $str) = @_;
  1961.   return -1 if $i < 0 || $i > $#rl_History;      ## for safety
  1962.   while (1) {
  1963.     return $i if rindex($rl_History[$i], $str) >= 0;
  1964.     if ($reverse) {
  1965.       return -1 if $i-- == 0;
  1966.     } else {
  1967.       return -1 if $i++ == $#rl_History;
  1968.     }
  1969.   }
  1970. }
  1971.  
  1972. sub DoSearch
  1973. {
  1974.     my $reverse = shift;
  1975.     my $oldline = $line;
  1976.     my $oldD = $D;
  1977.  
  1978.     my $searchstr = '';  ## string we're searching for
  1979.     my $I = -1;           ## which history line
  1980.  
  1981.     $si = 0;
  1982.  
  1983.     while (1)
  1984.     {
  1985.     if ($I != -1) {
  1986.         $line .= $rl_History[$I];
  1987.         $D += index($rl_History[$I], $searchstr);
  1988.     }
  1989.     &redisplay( '('.($reverse?'reverse-':'') ."i-search) `$searchstr': ");
  1990.  
  1991.     $c = rl_getc;
  1992.     if ($KeyMap[ord($c)] eq 'F_ReverseSearchHistory') {
  1993.         if ($reverse && $I != -1) {
  1994.         if ($tmp = &search($I-1,$searchstr), $tmp >= 0) {
  1995.             $I = $tmp;
  1996.         } else {
  1997.             &F_Ding;
  1998.         }
  1999.         }
  2000.         $reverse = 1;
  2001.     } elsif ($KeyMap[ord($c)] eq 'F_ForwardSearchHistory') {
  2002.         if (!$reverse && $I != -1) {
  2003.         if ($tmp = &search($I+1,$searchstr), $tmp >= 0) {
  2004.             $I = $tmp;
  2005.         } else {
  2006.             &F_Ding;
  2007.         }
  2008.         }
  2009.         $reverse = 0;
  2010.         } elsif ($c eq "\007") {  ## abort search... restore line and return
  2011.         $line = $oldline;
  2012.         $D = $oldD;
  2013.         return;
  2014.         } elsif (ord($c) < 32 || ord($c) > 126) {
  2015.         $pending = $c if $c ne "\e";
  2016.         if ($I < 0) {
  2017.         ## just restore
  2018.         $line = $oldline;
  2019.         $D = $oldD;
  2020.         } else {
  2021.         #chose this line
  2022.         $line = $rl_History[$I];
  2023.         $D = index($rl_History[$I], $searchstr);
  2024.         }
  2025.         &redisplay();
  2026.         last;
  2027.     } else {
  2028.         ## Add this character to the end of the search string and
  2029.         ## see if that'll match anything.
  2030.         $tmp = &search($I < 0 ? $rl_HistoryIndex-$reverse: $I, $searchstr.$c);
  2031.         if ($tmp == -1) {
  2032.         &F_Ding;
  2033.         } else {
  2034.         $searchstr .= $c;
  2035.         $I = $tmp;
  2036.         }
  2037.     }
  2038.     }
  2039. }
  2040.  
  2041. ## returns a new $i or -1 if not found.
  2042. sub searchStart { 
  2043.   my ($i, $reverse, $str) = @_;
  2044.   $i += $reverse ? - 1: +1;
  2045.   return -1 if $i < 0 || $i > $#rl_History;  ## for safety
  2046.   while (1) {
  2047.     return $i if index($rl_History[$i], $str) == 0;
  2048.     if ($reverse) {
  2049.       return -1 if $i-- == 0;
  2050.     } else {
  2051.       return -1 if $i++ == $#rl_History;
  2052.     }
  2053.   }
  2054. }
  2055.  
  2056. sub DoSearchStart
  2057. {
  2058.     my ($reverse,$what) = @_;
  2059.     my $i = searchStart($rl_HistoryIndex, $reverse, $what);
  2060.     return if $i == -1;
  2061.     $rl_HistoryIndex = $i;
  2062.     ($D, $line) = (0, $rl_History[$rl_HistoryIndex]);
  2063.     F_BeginningOfLine();
  2064.     F_ForwardChar(length($what));
  2065.  
  2066. }
  2067.  
  2068. ###########################################################################
  2069. ###########################################################################
  2070.  
  2071. ##
  2072. ## Kill from cursor to end of line.
  2073. ##
  2074. sub F_KillLine
  2075. {
  2076.     my $count = shift;
  2077.     return F_BackwardKillLine(-$count) if $count < 0;
  2078.     kill_text($D, length($line), 1);
  2079. }
  2080.  
  2081. ##
  2082. ## Delete from cursor to beginning of line.
  2083. ##
  2084. sub F_BackwardKillLine
  2085. {
  2086.     my $count = shift;
  2087.     return F_KillLine(-$count) if $count < 0;
  2088.     return F_Ding if $D == 0;
  2089.     kill_text(0, $D, 1);
  2090. }
  2091.  
  2092. ##
  2093. ## TextInsert(count, string)
  2094. ##
  2095. sub TextInsert {
  2096.   my $count = shift;
  2097.   my $text2add = shift(@_) x $count;
  2098.   if ($InsertMode) {
  2099.     substr($line,$D,0) .= $text2add;
  2100.   } else {
  2101.     substr($line,$D,length($text2add)) = $text2add;
  2102.   }
  2103.   $D += length($text2add);
  2104. }
  2105.  
  2106. sub F_Yank
  2107. {
  2108.     &TextInsert($_[0], $KillBuffer);
  2109. }
  2110.  
  2111. sub F_YankPop    { } ## not implemented yet
  2112. sub F_YankNthArg { } ## not implemented yet
  2113.  
  2114. ##
  2115. ## Kill to the end of the current word. If not on a word, kill to
  2116. ## the end of the next word.
  2117. ##
  2118. sub F_KillWord
  2119. {
  2120.     my $count = shift;
  2121.     return &F_BackwardKillWord(-$count) if $count < 0;
  2122.     my $oldD = $D;
  2123.     &F_ForwardWord($count);    ## moves forward $count words.
  2124.     kill_text($oldD, $D, 1);
  2125. }
  2126.  
  2127. ##
  2128. ## Kill backward to the start of the current word, or, if currently
  2129. ## not on a word (or just at the start of a word), to the start of the
  2130. ## previous word.
  2131. ##
  2132. sub F_BackwardKillWord
  2133. {
  2134.     my $count = shift;
  2135.     return F_KillWord(-$count) if $count < 0;
  2136.     my $oldD = $D;
  2137.     &F_BackwardWord($count);    ## moves backward $count words.
  2138.     kill_text($D, $oldD, 1);
  2139. }
  2140.  
  2141. ###########################################################################
  2142. ###########################################################################
  2143.  
  2144.  
  2145. ##
  2146. ## Abort the current input.
  2147. ##
  2148. sub F_Abort
  2149. {
  2150.     &F_Ding;
  2151. }
  2152.  
  2153.  
  2154. ##
  2155. ## If the character that got us here is upper case,
  2156. ## do the lower-case equiv...
  2157. ##
  2158. sub F_DoLowercaseVersion
  2159. {
  2160.     if ($_[1] >= ord('A') && $_[1] <= ord('Z')) {
  2161.     &do_command(*KeyMap, $_[0], $_[1] - ord('A') + ord('a'));
  2162.     } else {
  2163.     &F_Ding;
  2164.     }
  2165. }
  2166.  
  2167. ##
  2168. ## Undo one level.
  2169. ##
  2170. sub F_Undo
  2171. {
  2172.     pop(@undo); ## get rid of the state we just put on, so we can go back one.
  2173.     if (@undo) {
  2174.     &getstate(pop(@undo));
  2175.     } else {
  2176.     &F_Ding;
  2177.     }
  2178. }
  2179.  
  2180. ##
  2181. ## Replace the current line to some "before" state.
  2182. ##
  2183. sub F_RevertLine
  2184. {
  2185.     if ($rl_HistoryIndex >= $#rl_History+1) {
  2186.     $line = $line_for_revert;
  2187.     } else {
  2188.     $line = $rl_History[$rl_HistoryIndex];
  2189.     }
  2190.     $D = length($line);
  2191. }
  2192.  
  2193. sub F_EmacsEditingMode
  2194. {
  2195.     $var_EditingMode = $var_EditingMode{'emacs'};
  2196. }
  2197.  
  2198. sub F_ToggleEditingMode
  2199. {
  2200.     if ($var_EditingMode{$var_EditingMode} eq $var_EditingMode{'emacs'}) {
  2201.         $var_EditingMode = $var_EditingMode{'vi'};
  2202.     } else {
  2203.         $var_EditingMode = $var_EditingMode{'emacs'};
  2204.     }
  2205. }
  2206.  
  2207. ###########################################################################
  2208. ###########################################################################
  2209.  
  2210.  
  2211. ##
  2212. ## (Attempt to) interrupt the current program.
  2213. ##
  2214. sub F_Interrupt
  2215. {
  2216.     print $term_OUT "\r\n";
  2217.     &ResetTTY;
  2218.     kill ("INT", 0);
  2219.  
  2220.     ## We're back.... must not have died.
  2221.     $force_redraw = 1;
  2222. }
  2223.  
  2224. ##
  2225. ## Execute the next character input as a command in a meta keymap.
  2226. ##
  2227. sub F_PrefixMeta
  2228. {
  2229.     my($count, $keymap) = ($_[0], "$KeyMap{'name'}_$_[1]");
  2230.     ##print "F_PrefixMeta [$keymap]\n\r";
  2231.     die "<internal error, $_[1]>" unless defined(%$keymap);
  2232.     do_command(*$keymap, $count, ord(rl_getc));
  2233. }
  2234.  
  2235. sub F_UniversalArgument
  2236. {
  2237.     &F_DigitArgument;
  2238. }
  2239.  
  2240. ##
  2241. ## For typing a numeric prefix to a command....
  2242. ##
  2243. sub F_DigitArgument
  2244. {
  2245.     my $ord = $_[1];
  2246.     my ($NumericArg, $sign, $explicit) = (1, 1, 0);
  2247.     my $increment;
  2248.  
  2249.     do
  2250.     {
  2251.     if (defined($KeyMap[$ord]) && $KeyMap[$ord] eq 'F_UniversalArgument') {
  2252.         $NumericArg *= 4;
  2253.     } elsif ($ord == ord('-') && !$explicit) {
  2254.         $sign = -$sign;
  2255.         $NumericArg = $sign;
  2256.     } elsif ($ord >= ord('0') && $ord <= ord('9')) {
  2257.         $increment = ($ord - ord('0')) * $sign;
  2258.         if ($explicit) {
  2259.         $NumericArg = $NumericArg * 10 + $increment;
  2260.         } else {
  2261.         $NumericArg = $increment;
  2262.         $explicit = 1;
  2263.         }
  2264.     } else {
  2265.         local(*KeyMap) = $var_EditingMode;
  2266.         &redisplay();
  2267.         &do_command(*KeyMap, $NumericArg, $ord);
  2268.         return;
  2269.     }
  2270.     ## make sure it's not toooo big.
  2271.     if ($NumericArg > $rl_max_numeric_arg) {
  2272.         $NumericArg = $rl_max_numeric_arg;
  2273.     } elsif ($NumericArg < -$rl_max_numeric_arg) {
  2274.         $NumericArg = -$rl_max_numeric_arg;
  2275.     }
  2276.     &redisplay(sprintf("(arg %d) ", $NumericArg));
  2277.     } while $ord = ord(rl_getc);
  2278. }
  2279.  
  2280. sub F_OverwriteMode
  2281. {
  2282.     $InsertMode = 0;
  2283. }
  2284.  
  2285. sub F_InsertMode
  2286. {
  2287.     $InsertMode = 1;
  2288. }
  2289.  
  2290. sub F_ToggleInsertMode
  2291. {
  2292.     $InsertMode = !$InsertMode;
  2293. }
  2294.  
  2295. ##
  2296. ## (Attempt to) suspend the program.
  2297. ##
  2298. sub F_Suspend
  2299. {
  2300.     if ($inDOS && length($line)==0) { # EOF sent
  2301.     $AcceptLine = $ReturnEOF = 1 if $lastcommand ne 'F_DeleteChar';
  2302.     return;
  2303.     }
  2304.     print $term_OUT "\r\n";
  2305.     &ResetTTY;
  2306.     eval { kill ("TSTP", 0) };
  2307.     ## We're back....
  2308.     &SetTTY;
  2309.     $force_redraw = 1;
  2310. }
  2311.  
  2312. ##
  2313. ## Ring the bell.
  2314. ## Should do something with $var_PreferVisibleBell here, but what?
  2315. ##
  2316. sub F_Ding {
  2317.     print $term_OUT "\007";
  2318. }
  2319.  
  2320. ##########################################################################
  2321. #### command/file completion  ############################################
  2322. ##########################################################################
  2323.  
  2324. ##
  2325. ## How Command Completion Works
  2326. ##
  2327. ## When asked to do a completion operation, readline isolates the word
  2328. ## to the immediate left of the cursor (i.e. what's just been typed).
  2329. ## This information is then passed to some function (which may be supplied
  2330. ## by the user of this package) which will return an array of possible
  2331. ## completions.
  2332. ##
  2333. ## If there is just one, that one is used.  Otherwise, they are listed
  2334. ## in some way (depends upon $var_TcshCompleteMode).
  2335. ##
  2336. ## The default is to do filename completion.  The function that performs
  2337. ## this task is readline'rl_filename_list.
  2338. ##
  2339. ## A minimal-trouble way to have command-completion is to call
  2340. ## readline'rl_basic_commands with an array of command names, such as
  2341. ##    &readline'rl_basic_commands('quit', 'run', 'set', 'list')
  2342. ## Those command names will then be used for completion if the word being
  2343. ## completed begins the line. Otherwise, completion is disallowed.
  2344. ##
  2345. ## The way to have the most power is to provide a function to readline
  2346. ## which will accept information about a partial word that needs completed,
  2347. ## and will return the appropriate list of possibilities.
  2348. ## This is done by setting $readline'rl_completion_function to the name of
  2349. ## the function to run.
  2350. ##
  2351. ## That function will be called with three args ($text, $line, $start).
  2352. ## TEXT is the partial word that should be completed.  LINE is the entire
  2353. ## input line as it stands, and START is the index of the TEXT in LINE
  2354. ## (i.e. zero if TEXT is at the beginning of LINE).
  2355. ##
  2356. ## A cool completion function will look at LINE and START and give context-
  2357. ## sensitive completion lists. Consider something that will do completion
  2358. ## for two commands
  2359. ##     cat FILENAME
  2360. ##    finger USERNAME
  2361. ##    status [this|that|other]
  2362. ##
  2363. ## It (untested) might look like:
  2364. ##
  2365. ##    $readline'rl_completion_function = "main'complete";
  2366. ##    sub complete { local($text, $_, $start) = @_;
  2367. ##        ## return commands which may match if at the beginning....
  2368. ##        return grep(/^$text/, 'cat', 'finger') if $start == 0;
  2369. ##        return &rl_filename_list($text) if /^cat\b/;
  2370. ##        return &my_namelist($text) if /^finger\b/;
  2371. ##        return grep(/^text/, 'this', 'that','other') if /^status\b/;
  2372. ##        ();
  2373. ##    }
  2374. ## Of course, a real completion function would be more robust, but you
  2375. ## get the idea (I hope).
  2376. ##
  2377.  
  2378. ##
  2379. ## List possible completions
  2380. ##
  2381. sub F_PossibleCompletions
  2382. {
  2383.     &complete_internal('?');
  2384. }
  2385.  
  2386. ##
  2387. ## List possible completions
  2388. ##
  2389. sub F_InsertPossibleCompletions
  2390. {
  2391.     &complete_internal('*');
  2392. }
  2393.  
  2394. ##
  2395. ## Do a completion operation.
  2396. ## If the last thing we did was a completion operation, we'll
  2397. ## now list the options available (under normal emacs mode).
  2398. ##
  2399. ## Under TcshCompleteMode, each contiguous subsequent completion operation
  2400. ## lists another of the possible options.
  2401. ##
  2402. sub F_Complete
  2403. {
  2404.     if ($lastcommand eq 'F_Complete') {
  2405.     if ($var_TcshCompleteMode && @tcsh_complete_selections > 0) {
  2406.         substr($line, $tcsh_complete_start, $tcsh_complete_len)
  2407.         = $tcsh_complete_selections[0];
  2408.         $D -= $tcsh_complete_len;
  2409.         $tcsh_complete_len = length($tcsh_complete_selections[0]);
  2410.         $D += $tcsh_complete_len;
  2411.         push(@tcsh_complete_selections, shift(@tcsh_complete_selections));
  2412.     } else {
  2413.         &complete_internal('?');
  2414.     }
  2415.     } else {
  2416.     @tcsh_complete_selections = ();
  2417.     &complete_internal("\t");
  2418.     }
  2419. }
  2420.  
  2421. ##
  2422. ## The meat of command completion. Patterned closely after GNU's.
  2423. ##
  2424. ## The supposedly partial word at the cursor is "completed" as per the
  2425. ## single argument:
  2426. ##    "\t"    complete as much of the word as is unambiguous
  2427. ##    "?"    list possibilities.
  2428. ##     "*"    replace word with all possibilities. (who would use this?)
  2429. ##
  2430. ## A few notable variables used:
  2431. ##   $rl_completer_word_break_characters
  2432. ##    -- characters in this string break a word.
  2433. ##   $rl_special_prefixes
  2434. ##    -- but if in this string as well, remain part of that word.
  2435. ##
  2436. sub complete_internal
  2437. {
  2438.     my $what_to_do = shift;
  2439.     my ($point, $end) = ($D, $D);
  2440.  
  2441.     if ($point)
  2442.     {
  2443.         ## Not at the beginning of the line; Isolate the word to be completed.
  2444.     1 while (--$point && (-1 == index($rl_completer_word_break_characters,
  2445.         substr($line, $point, 1))));
  2446.  
  2447.     # Either at beginning of line or at a word break.
  2448.     # If at a word break (that we don't want to save), skip it.
  2449.     $point++ if (
  2450.             (index($rl_completer_word_break_characters,
  2451.                substr($line, $point, 1)) != -1) &&
  2452.             (index($rl_special_prefixes, substr($line, $point, 1)) == -1)
  2453.     );
  2454.     }
  2455.  
  2456.     my $text = substr($line, $point, $end - $point);
  2457.     $rl_completer_terminator_character = ' ';
  2458.     @matches = &completion_matches($rl_completion_function,$text,$line,$point);
  2459.  
  2460.     if (@matches == 0) {
  2461.     &F_Ding;
  2462.     } elsif ($what_to_do eq "\t") {
  2463.     my $replacement = shift(@matches);
  2464.     $replacement .= $rl_completer_terminator_character if @matches == 1;
  2465.     &F_Ding if @matches != 1;
  2466.     if ($var_TcshCompleteMode) {
  2467.         @tcsh_complete_selections = (@matches, $text);
  2468.         $tcsh_complete_start = $point;
  2469.         $tcsh_complete_len = length($replacement);
  2470.     }
  2471.     if ($replacement ne '') {
  2472.         substr($line, $point, $end-$point) = $replacement;
  2473.         $D = $D - ($end - $point) + length($replacement);
  2474.     }
  2475.     } elsif ($what_to_do eq '?') {
  2476.     shift(@matches); ## remove prepended common prefix
  2477.     print $term_OUT "\n\r";
  2478.     # print "@matches\n\r";
  2479.     &pretty_print_list (@matches);
  2480.     $force_redraw = 1;
  2481.     } elsif ($what_to_do eq '*') {
  2482.     shift(@matches); ## remove common prefix.
  2483.     local $" = $rl_completer_terminator_character;
  2484.     my $replacement = "@matches$rl_completer_terminator_character";
  2485.     substr($line, $point, $end-$point) = $replacement; ## insert all.
  2486.     $D = $D - ($end - $point) + length($replacement);
  2487.     } else {
  2488.     warn "\r\n[Internal error]";
  2489.     }
  2490. }
  2491.  
  2492. ##
  2493. ## completion_matches(func, text, line, start)
  2494. ##
  2495. ## FUNC is a function to call as FUNC(TEXT, LINE, START)
  2496. ##     where TEXT is the item to be completed
  2497. ##          LINE is the whole command line, and
  2498. ##          START is the starting index of TEXT in LINE.
  2499. ## The FUNC should return a list of items that might match.
  2500. ##
  2501. ## completion_matches will return that list, with the longest common
  2502. ## prefix prepended as the first item of the list.  Therefor, the list
  2503. ## will either be of zero length (meaning no matches) or of 2 or more.....
  2504. ##
  2505.  
  2506. ## Works with &rl_basic_commands. Return items from @rl_basic_commands
  2507. ## that start with the pattern in $text.
  2508. sub use_basic_commands {
  2509.   my ($text, $line, $start) = @_;
  2510.   return () if $start != 0;
  2511.   grep(/^$text/, @rl_basic_commands);
  2512. }
  2513.  
  2514. sub completion_matches
  2515. {
  2516.     my ($func, $text, $line, $start) = @_;
  2517.  
  2518.     ## get the raw list
  2519.     my @matches;
  2520.  
  2521.     #print qq/\r\neval("\@matches = &$func(\$text, \$line, \$start)\n\r/;#DEBUG
  2522.     #eval("\@matches = &$func(\$text, \$line, \$start);1") || warn "$@ ";
  2523.     @matches = &$func($text, $line, $start);
  2524.  
  2525.     ## if anything returned , find the common prefix among them
  2526.     if (@matches) {
  2527.     my $prefix = $matches[0];
  2528.     my $len = length($prefix);
  2529.     for ($i = 1; $i < @matches; $i++) {
  2530.         next if substr($matches[$i], 0, $len) eq $prefix;
  2531.         $prefix = substr($prefix, 0, --$len);
  2532.         last if $len == 0;
  2533.         $i--; ## retry this one to see if the shorter one matches.
  2534.     }
  2535.     unshift(@matches, $prefix); ## make common prefix the first thing.
  2536.     }
  2537.     @matches;
  2538. }
  2539.  
  2540. ##
  2541. ## For use in passing to completion_matches(), returns a list of
  2542. ## filenames that begin with the given pattern.  The user of this package
  2543. ## can set $rl_completion_function to 'rl_filename_list' to restore the
  2544. ## default of filename matching if they'd changed it earlier, either
  2545. ## directly or via &rl_basic_commands.
  2546. ##
  2547. sub rl_filename_list
  2548. {
  2549.     my $pattern = $_[0];
  2550.     my @files = (<$pattern*>);
  2551.     if ($var_CompleteAddsuffix) {
  2552.     foreach (@files) {
  2553.         if (-l $_) {
  2554.         $_ .= '@';
  2555.         } elsif (-d _) {
  2556.         $_ .= '/';
  2557.         } elsif (-x _) {
  2558.         $_ .= '*';
  2559.         } elsif (-S _ || -p _) {
  2560.         $_ .= '=';
  2561.         }
  2562.     }
  2563.     }
  2564.     return @files;
  2565. }
  2566.  
  2567. ##
  2568. ## For use by the user of the package. Called with a list of possible
  2569. ## commands, will allow command completion on those commands, but only
  2570. ## for the first word on a line.
  2571. ## For example: &rl_basic_commands('set', 'quit', 'type', 'run');
  2572. ##
  2573. ## This is for people that want quick and simple command completion.
  2574. ## A more thoughtful implementation would set $rl_completion_function
  2575. ## to a routine that would look at the context of the word being completed
  2576. ## and return the appropriate possibilities.
  2577. ##
  2578. sub rl_basic_commands
  2579. {
  2580.      @rl_basic_commands = @_;
  2581.      $rl_completion_function = 'use_basic_commands';
  2582. }
  2583.  
  2584. ##
  2585. ## Print an array in columns like ls -C.  Originally based on stuff
  2586. ## (lsC2.pl) by utashiro@sran230.sra.co.jp (Kazumasa Utashiro).
  2587. ##
  2588. sub pretty_print_list
  2589. {
  2590.     my @list = @_;
  2591.     return unless @list;
  2592.     my ($lines, $columns, $mark, $index);
  2593.  
  2594.     ## find width of widest entry
  2595.     my $maxwidth = 0;
  2596.     grep(length > $maxwidth && ($maxwidth = length), @list);
  2597.     $maxwidth++;
  2598.  
  2599.     $columns = $maxwidth >= $rl_screen_width
  2600.            ? 1 : int($rl_screen_width / $maxwidth);
  2601.  
  2602.     ## if there's enough margin to interspurse among the columsn, do so.
  2603.     $maxwidth += int(($rl_screen_width % $maxwidth) / $columns);
  2604.  
  2605.     $lines = int((@list + $columns - 1) / $columns);
  2606.     $columns-- while ((($lines * $columns) - @list + 1) > $lines);
  2607.  
  2608.     $mark = $#list - $lines;
  2609.     for ($l = 0; $l < $lines; $l++) {
  2610.     for ($index = $l; $index <= $mark; $index += $lines) {
  2611.         printf("%-$ {maxwidth}s", $list[$index]);
  2612.     }
  2613.        print $term_OUT $list[$index] if $index <= $#list;
  2614.     print $term_OUT "\n\r";
  2615.     }
  2616. }
  2617.  
  2618. 1;
  2619. __END__
  2620.