home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / XS.pm < prev    next >
Text File  |  2002-07-27  |  14KB  |  522 lines
  1. #!/usr/local/bin/perl
  2. #
  3. #    XS.pm : perl function definition for Term::ReadLine::Gnu
  4. #
  5. #    $Id: XS.pm,v 1.20 2002-07-27 22:39:49-05 hiroo Exp $
  6. #
  7. #    Copyright (c) 2002 Hiroo Hayashi.  All rights reserved.
  8. #
  9. #    This program is free software; you can redistribute it and/or
  10. #    modify it under the same terms as Perl itself.
  11.  
  12. package Term::ReadLine::Gnu::XS;
  13.  
  14. use Carp;
  15. use strict;
  16. use AutoLoader 'AUTOLOAD';
  17.  
  18. # make aliases
  19. use vars qw(%Attribs);
  20. *Attribs = \%Term::ReadLine::Gnu::Attribs;
  21.  
  22. use vars qw(*read_history);
  23. *read_history = \&read_history_range;
  24.  
  25. # alias for 8 characters limitation imposed by AutoSplit
  26. use vars qw(*rl_unbind_key *rl_unbind_function *rl_unbind_command
  27.         *history_list *history_arg_extract);
  28. *rl_unbind_key = \&unbind_key;
  29. *rl_unbind_function = \&unbind_function;
  30. *rl_unbind_command = \&unbind_command;
  31. *history_list = \&hist_list;
  32. *history_arg_extract = \&hist_arg_extract;
  33.  
  34. # For backward compatibility.  Using these name (*_in_map) is deprecated.
  35. use vars qw(*rl_unbind_function_in_map *rl_unbind_command_in_map);
  36. *rl_unbind_function_in_map = \&unbind_function;
  37. *rl_unbind_command_in_map  = \&unbind_command;
  38.  
  39. rl_add_defun('history-expand-line',     \&history_expand_line);
  40. # bind operate-and-get-next to \C-o by default for the compatibility
  41. # with bash and Term::ReadLine::Perl
  42. rl_add_defun('operate-and-get-next',     \&operate_and_get_next, ord "\co");
  43. rl_add_defun('display-readline-version', \&display_readline_version);
  44. rl_add_defun('change-ornaments',     \&change_ornaments);
  45.  
  46. # for ornaments()
  47.  
  48. # Prompt-start, prompt-end, command-line-start, command-line-end
  49. #     -- zero-width beautifies to emit around prompt and the command line.
  50. # string encoded:
  51. my $rl_term_set = ',,,';
  52.  
  53. # These variables are used by completion functions.  Don't use for
  54. # other purpose.
  55. my $_i;
  56. my @_matches;
  57. my @_tstrs;
  58. my $_tstrs_init = 0;
  59.  
  60. 1;
  61.  
  62. # Uncomment the following line to enable AutoSplit.  If you are using
  63. # AutoLoader.pm distributed with Perl 5.004 or earlier, you must
  64. # update AutoLoader.pm due to its bug.
  65.  
  66. #__END__
  67.  
  68.  
  69. #
  70. #    Readline Library function wrappers
  71. #
  72.  
  73. # Convert keymap name to Keymap if the argument is not reference to Keymap
  74. sub _str2map ($) {
  75.     return ref $_[0] ? $_[0]
  76.     : (rl_get_keymap_by_name($_[0]) || carp "unknown keymap name \`$_[0]\'\n");
  77. }
  78.  
  79. # Convert function name to Function if the argument is not reference
  80. # to Function
  81. sub _str2fn ($) {
  82.     return ref $_[0] ? $_[0]
  83.     : (rl_named_function($_[0]) || carp "unknown function name \`$_[0]\'\n");
  84. }
  85.  
  86. sub rl_copy_keymap ($)    { return _rl_copy_keymap(_str2map($_[0])); }
  87. sub rl_discard_keymap ($) { return _rl_discard_keymap(_str2map($_[0])); }
  88. sub rl_set_keymap ($)     { return _rl_set_keymap(_str2map($_[0])); }
  89.  
  90. sub rl_bind_key ($$;$) {
  91.     if (defined $_[2]) {
  92.     return _rl_bind_key($_[0], _str2fn($_[1]), _str2map($_[2]));
  93.     } else {
  94.     return _rl_bind_key($_[0], _str2fn($_[1]));
  95.     }
  96. }
  97.  
  98. # rl_unbind_key
  99. sub unbind_key ($;$) {
  100.     if (defined $_[1]) {
  101.     return _rl_unbind_key($_[0], _str2map($_[1]));
  102.     } else {
  103.     return _rl_unbind_key($_[0]);
  104.     }
  105. }
  106.  
  107. # rl_unbind_function
  108. sub unbind_function ($;$) {
  109.     # libreadline.* in Debian GNU/Linux 2.0 tells wrong value as '2.1-bash'
  110.     my ($version) = $Attribs{library_version}
  111.     =~ /(\d+\.\d+)/;
  112.     if ($version < 2.2) {
  113.     carp "rl_unbind_function() is not supported.  Ignored\n";
  114.     return;
  115.     }
  116.     if (defined $_[1]) {
  117.     return _rl_unbind_function($_[0], _str2map($_[1]));
  118.     } else {
  119.     return _rl_unbind_function($_[0]);
  120.     }
  121. }
  122.  
  123. # rl_unbind_command
  124. sub unbind_command ($;$) {
  125.     my ($version) = $Attribs{library_version}
  126.     =~ /(\d+\.\d+)/;
  127.     if ($version < 2.2) {
  128.     carp "rl_unbind_command() is not supported.  Ignored\n";
  129.     return;
  130.     }
  131.     if (defined $_[1]) {
  132.     return _rl_unbind_command($_[0], _str2map($_[1]));
  133.     } else {
  134.     return _rl_unbind_command($_[0]);
  135.     }
  136. }
  137.  
  138. sub rl_set_key ($$;$) {
  139.     my ($version) = $Attribs{library_version}
  140.     =~ /(\d+\.\d+)/;
  141.     if ($version < 4.2) {
  142.     carp "rl_set_key() is not supported.  Ignored\n";
  143.     return;
  144.     }
  145.     if (defined $_[2]) {
  146.     return _rl_set_key($_[0], _str2fn($_[1]), _str2map($_[2]));
  147.     } else {
  148.     return _rl_set_key($_[0], _str2fn($_[1]));
  149.     }
  150. }
  151.  
  152. sub rl_macro_bind ($$;$) {
  153.     my ($version) = $Attribs{library_version}
  154.     =~ /(\d+\.\d+)/;
  155.     if (defined $_[2]) {
  156.     return _rl_macro_bind($_[0], $_[1], _str2map($_[2]));
  157.     } else {
  158.     return _rl_macro_bind($_[0], $_[1]);
  159.     }
  160. }
  161.  
  162. sub rl_generic_bind ($$$;$) {
  163.     if      ($_[0] == Term::ReadLine::Gnu::ISFUNC) {
  164.     if (defined $_[3]) {
  165.         _rl_generic_bind_function($_[1], _str2fn($_[2]), _str2map($_[3]));
  166.     } else {
  167.         _rl_generic_bind_function($_[1], _str2fn($_[2]));
  168.     }
  169.     } elsif ($_[0] == Term::ReadLine::Gnu::ISKMAP) {
  170.     if (defined $_[3]) {
  171.         _rl_generic_bind_keymap($_[1], _str2map($_[2]), _str2map($_[3]));
  172.     } else {
  173.         _rl_generic_bind_keymap($_[1], _str2map($_[2]));
  174.     }
  175.     } elsif ($_[0] == Term::ReadLine::Gnu::ISMACR) {
  176.     if (defined $_[3]) {
  177.         _rl_generic_bind_macro($_[1], $_[2], _str2map($_[3]));
  178.     } else {
  179.         _rl_generic_bind_macro($_[1], $_[2]);
  180.     }
  181.     } else {
  182.     carp("Term::ReadLine::Gnu::rl_generic_bind: invalid \`type\'\n");
  183.     }
  184. }
  185.  
  186. sub rl_call_function ($;$$) {
  187.     if (defined $_[2]) {
  188.     return _rl_call_function(_str2fn($_[0]), $_[1], $_[2]);
  189.     } elsif (defined $_[1]) {
  190.     return _rl_call_function(_str2fn($_[0]), $_[1]);
  191.     } else {
  192.     return _rl_call_function(_str2fn($_[0]));
  193.     }
  194. }
  195.  
  196. sub rl_invoking_keyseqs ($;$) {
  197.     if (defined $_[1]) {
  198.     return _rl_invoking_keyseqs(_str2fn($_[0]), _str2map($_[1]));
  199.     } else {
  200.     return _rl_invoking_keyseqs(_str2fn($_[0]));
  201.     }
  202. }
  203.  
  204. sub rl_add_funmap_entry ($$) {
  205.     my ($version) = $Attribs{library_version}
  206.     =~ /(\d+\.\d+)/;
  207.     if ($version < 4.2) {
  208.     carp "rl_add_funmap_entry() is not supported.  Ignored\n";
  209.     return;
  210.     }
  211.     return _rl_add_funmap_entry($_[0], _str2fn($_[1]));
  212. }
  213.  
  214. sub rl_tty_set_default_bindings (;$) {
  215.     if (defined $_[0]) {
  216.     return _rl_tty_set_defaut_bindings(_str2map($_[1]));
  217.     } else {
  218.     return _rl_tty_set_defaut_bindings();
  219.     }
  220. }
  221.  
  222. sub rl_message {
  223.     my $fmt = shift;
  224.     my $line = sprintf($fmt, @_);
  225.     _rl_message($line);
  226. }
  227.  
  228. sub rl_completion_mode {
  229.     # libreadline.* in Debian GNU/Linux 2.0 tells wrong value as '2.1-bash'
  230.     my ($version) = $Attribs{library_version}
  231.     =~ /(\d+\.\d+)/;
  232.     if ($version < 4.3) {
  233.     carp "rl_completion_mode() is not supported.  Ignored\n";
  234.     return;
  235.     }
  236.     return _rl_completion_mode(_str2fn($_[0]));
  237. }
  238.  
  239. #
  240. #    for compatibility with Term::ReadLine::Perl
  241. #
  242. sub rl_filename_list {
  243.     my ($text) = @_;
  244.  
  245.     # lcd : lowest common denominator
  246.     my ($lcd, @matches) = rl_completion_matches($text,
  247.                         \&rl_filename_completion_function);
  248.     return @matches ? @matches : $lcd;
  249. }
  250.  
  251. #
  252. #    History Library function wrappers
  253. #
  254. # history_list
  255. sub hist_list () {
  256.     my ($i, $history_base, $history_length, @d);
  257.     $history_base   = $Attribs{history_base};
  258.     $history_length = $Attribs{history_length};
  259.     for ($i = $history_base; $i < $history_base + $history_length; $i++) {
  260.     push(@d, history_get($i));
  261.     }
  262.     @d;
  263. }
  264.  
  265. # history_arg_extract
  266. sub hist_arg_extract ( ;$$$ ) {
  267.     my ($line, $first, $last) = @_;
  268.     $line  = $_      unless defined $line;
  269.     $first = 0       unless defined $first;
  270.     $last  = ord '$' unless defined $last; # '
  271.     $first = ord '$' if defined $first and $first eq '$'; # '
  272.     $last  = ord '$' if defined $last  and $last  eq '$'; # '
  273.     &_history_arg_extract($line, $first, $last);
  274. }
  275.  
  276. sub get_history_event ( $$;$ ) {
  277.     _get_history_event($_[0], $_[1], defined $_[2] ? ord $_[2] : 0);
  278. }
  279.  
  280. #
  281. #    Ornaments
  282. #
  283.  
  284. # This routine originates in Term::ReadLine.pm.
  285.  
  286. # Debian GNU/Linux discourages users from using /etc/termcap.  A
  287. # subroutine ornaments() defined in Term::ReadLine.pm uses
  288. # Term::Caps.pm which requires /etc/termcap.
  289.  
  290. # This module calls termcap (or its compatible) library, which the GNU
  291. # Readline Library already uses, instead of Term::Caps.pm.
  292.  
  293. # Some terminals do not support 'ue' (underline end).
  294. use vars qw(%term_no_ue);
  295. %term_no_ue = ( kterm => 1 );
  296.  
  297. sub ornaments {
  298.     return $rl_term_set unless @_;
  299.     $rl_term_set = shift;
  300.     $rl_term_set ||= ',,,';
  301.     $rl_term_set = $term_no_ue{$ENV{TERM}} ? 'us,me,,' : 'us,ue,,'
  302.     if $rl_term_set eq '1';
  303.     my @ts = split /,/, $rl_term_set, 4;
  304.     my @rl_term_set
  305.     = map {
  306.         # non-printing characters must be informed to readline
  307.         my $t;
  308.         ($_ and $t = tgetstr($_))
  309.         ? (Term::ReadLine::Gnu::RL_PROMPT_START_IGNORE
  310.            . $t
  311.            . Term::ReadLine::Gnu::RL_PROMPT_END_IGNORE)
  312.             : '';
  313.     } @ts;
  314.     $Attribs{term_set} = \@rl_term_set;
  315.     return $rl_term_set;
  316. }
  317.  
  318. #
  319. #    a sample custom function
  320. #
  321.  
  322. # The equivalent of the Bash shell M-^ history-expand-line editing
  323. # command.
  324.  
  325. # This routine was borrowed from bash.
  326. sub history_expand_line {
  327.     my ($count, $key) = @_;
  328.     my ($expanded, $new_line) = history_expand($Attribs{line_buffer});
  329.     if ($expanded > 0) {
  330.       rl_modifying(0, $Attribs{end}); # save undo information
  331.       $Attribs{line_buffer} = $new_line;
  332.     } elsif ($expanded < 0) {
  333.       my $OUT = $Attribs{outstream};
  334.       print $OUT "\n$new_line\n";
  335.       rl_on_new_line();
  336.     }                # $expanded == 0 : no change
  337. }
  338.  
  339. # The equivalent of the Korn shell C-o operate-and-get-next-history-line
  340. # editing command. 
  341.  
  342. # This routine was borrowed from bash.
  343. sub operate_and_get_next {
  344.     my ($count, $key) = @_;
  345.  
  346.     my $saved_history_line_to_use = -1;
  347.     my $old_rl_startup_hook;
  348.  
  349.     # Accept the current line.
  350.     rl_call_function('accept-line', 1, $key);
  351.  
  352.     # Find the current line, and find the next line to use. */
  353.     my $where = where_history();
  354.     if ((history_is_stifled()
  355.      && ($Attribs{history_length} >= $Attribs{max_input_history}))
  356.     || ($where >= $Attribs{history_length} - 1)) {
  357.     $saved_history_line_to_use = $where;
  358.     } else {
  359.     $saved_history_line_to_use = $where + 1;
  360.     }
  361.     $old_rl_startup_hook = $Attribs{startup_hook};
  362.     $Attribs{startup_hook} = sub {
  363.     if ($saved_history_line_to_use >= 0) {
  364.         rl_call_function('previous-history',
  365.                  $Attribs{history_length}
  366.                  - $saved_history_line_to_use,
  367.                  0);
  368.         $Attribs{startup_hook} = $old_rl_startup_hook;
  369.         $saved_history_line_to_use = -1;
  370.     }
  371.     };
  372. }
  373.  
  374. sub display_readline_version {    # show version
  375.     my($count, $key) = @_;    # ignored in this function
  376.     my $OUT = $Attribs{outstream};
  377.     print $OUT
  378.     ("\nTerm::ReadLine::Gnu version: $Term::ReadLine::Gnu::VERSION");
  379.     print $OUT
  380.     ("\nGNU Readline Library version: $Attribs{library_version}\n");
  381.     rl_on_new_line();
  382. }
  383.  
  384. # sample function of rl_message()
  385. sub change_ornaments {
  386.     my($count, $key) = @_;    # ignored in this function
  387.     rl_save_prompt;
  388.     rl_message("[S]tandout, [U]nderlining, [B]old, [R]everse, [V]isible bell: ");
  389.     my $c = chr rl_read_key;
  390.     if ($c =~ /s/i) {
  391.     ornaments('so,me,,');
  392.     } elsif ($c =~ /u/i) {
  393.     ornaments('us,me,,');
  394.     } elsif ($c =~ /b/i) {
  395.     ornaments('md,me,,');
  396.     } elsif ($c =~ /r/i) {
  397.     ornaments('mr,me,,');
  398.     } elsif ($c =~ /v/i) {
  399.     ornaments('vb,,,');
  400.     } else {
  401.     rl_ding;
  402.     }
  403.     rl_restore_prompt;
  404.     rl_clear_message;
  405. }
  406.  
  407. #
  408. #    for tkRunning
  409. #
  410. sub Tk_getc {
  411.     &Term::ReadLine::Tk::Tk_loop
  412.     if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
  413.     my $FILE = $Attribs{instream};
  414.     return rl_getc($FILE);
  415. }
  416.  
  417. # redisplay function for secret input like password
  418. # usage:
  419. #    $a->{redisplay_function} = $a->{shadow_redisplay};
  420. #    $line = $t->readline("password> ");
  421. sub shadow_redisplay {
  422.     @_tstrs = _tgetstrs() unless $_tstrs_init;
  423.     # remove prompt start/end mark from prompt string
  424.     my $prompt = $Attribs{prompt}; my $s;
  425.     $s = Term::ReadLine::Gnu::RL_PROMPT_START_IGNORE; $prompt =~ s/$s//g;
  426.     $s = Term::ReadLine::Gnu::RL_PROMPT_END_IGNORE;   $prompt =~ s/$s//g;
  427.     my $OUT = $Attribs{outstream};
  428.     my $oldfh = select($OUT); $| = 1; select($oldfh);
  429.     print $OUT ($_tstrs[0],    # carriage return
  430.         $_tstrs[1],    # clear to EOL
  431.         $prompt, '*' x length($Attribs{line_buffer}));
  432.     print $OUT ($_tstrs[2]    # cursor left
  433.         x (length($Attribs{line_buffer}) - $Attribs{point}));
  434.     $oldfh = select($OUT); $| = 0; select($oldfh);
  435. }
  436.  
  437. sub _tgetstrs {
  438.     my @s = (tgetstr('cr'),    # carriage return
  439.          tgetstr('ce'),    # clear to EOL
  440.          tgetstr('le'));    # cursor left
  441.     warn <<"EOM" unless (defined($s[0]) && defined($s[1]) && defined($s[2]));
  442. Your terminal 'TERM=$ENV{TERM}' does not support enough function.
  443. Check if your environment variable 'TERM' is set correctly.
  444. EOM
  445.     # suppress warning "Use of uninitialized value in print at ..."
  446.     $s[0] = $s[0] || ''; $s[1] = $s[1] || ''; $s[2] = $s[2] || '';
  447.     $_tstrs_init = 1;
  448.     return @s;
  449. }
  450.  
  451. # callback handler wrapper function for CallbackHandlerInstall method
  452. sub _ch_wrapper {
  453.     my $line = shift;
  454.  
  455.     if (defined $line) {
  456.     if ($Attribs{do_expand}) {
  457.         my $result;
  458.         ($result, $line) = history_expand($line);
  459.         my $outstream = $Attribs{outstream};
  460.         print $outstream "$line\n" if ($result);
  461.  
  462.         # return without adding line into history
  463.         if ($result < 0 || $result == 2) {
  464.         return '';    # don't return `undef' which means EOF.
  465.         }
  466.     }
  467.  
  468.     # add to history buffer
  469.     add_history($line) 
  470.         if ($Attribs{MinLength} > 0
  471.         && length($line) >= $Attribs{MinLength});
  472.     }
  473.     &{$Attribs{_callback_handler}}($line);
  474. }
  475.  
  476. #
  477. #    List Completion Function
  478. #
  479. sub list_completion_function ( $$ ) {
  480.     my($text, $state) = @_;
  481.  
  482.     $_i = $state ? $_i + 1 : 0;    # clear counter at the first call
  483.     my $cw = $Attribs{completion_word};
  484.     for (; $_i <= $#{$cw}; $_i++) {
  485.     return $cw->[$_i] if ($cw->[$_i] =~ /^\Q$text/);
  486.     }
  487.     return undef;
  488. }
  489.  
  490. #
  491. #    wrapper completion function of 'completion_function'
  492. #    for compatibility with Term::ReadLine::Perl
  493. #
  494. sub _trp_completion_function ( $$ ) {
  495.     my($text, $state) = @_;
  496.  
  497.     my $cf;
  498.     return undef unless defined ($cf = $Attribs{completion_function});
  499.  
  500.     if ($state) {
  501.     $_i++;
  502.     } else {
  503.     # the first call
  504.     $_i = 0;        # clear index
  505.     @_matches = &$cf($text,
  506.              $Attribs{line_buffer},
  507.              $Attribs{point} - length($text));
  508.     # return here since $#_matches is 0 instead of -1 when
  509.     # @_matches = undef
  510.     return undef unless defined $_matches[0];
  511.     }
  512.  
  513.     for (; $_i <= $#_matches; $_i++) {
  514.     return $_matches[$_i] if ($_matches[$_i] =~ /^\Q$text/);
  515.     }
  516.     return undef;
  517. }
  518.  
  519. 1;
  520.  
  521. __END__
  522.