modules/override/Term/ReadLine/Perl/Bind.pm

   1 package Term::ReadLine::Perl::Bind;
   2 ### From http://www.perlmonks.org/?node_id=751611
   3 ### Posted by repellant (http://www.perlmonks.org/?node_id=665462)
   4
   5 ### Set readline bindkeys for common terminals
   6
   7 use warnings;
   8 use strict;
   9
  10 BEGIN {
  11     require Exporter;
  12     *import = \&Exporter::import; # just inherit import() only
  13
  14     our $VERSION   = 1.001;
  15     our @EXPORT_OK = qw(rl_bind_action $action2key $key2codes);
  16 }
  17
  18 use Term::ReadLine;
  19
  20 # http://cpansearch.perl.org/src/ILYAZ/Term-ReadLine-Perl-1.0302/ReadLine
  21 my $got_rl_perl;
  22
  23 BEGIN {
  24     $got_rl_perl = eval {
  25         require Term::ReadLine::Perl;
  26         require Term::ReadLine::readline;
  27     };
  28 }
  29
  30 # bindkey actions for terminals
  31 our $action2key = {
  32     Complete               => "Tab",
  33     PossibleCompletions    => "C-d",
  34     QuotedInsert           => "C-v",
  35
  36     ToggleInsertMode       => "Insert",
  37     DeleteChar             => "Del",
  38     UpcaseWord             => "PageUp",
  39     DownCaseWord           => "PageDown",
  40     BeginningOfLine        => "Home",
  41     EndOfLine              => "End",
  42
  43     ReverseSearchHistory   => "C-Up",
  44     ForwardSearchHistory   => "C-Down",
  45     ForwardWord            => "C-Right",
  46     BackwardWord           => "C-Left",
  47
  48     HistorySearchBackward  => "S-Up",
  49     HistorySearchForward   => "S-Down",
  50     KillWord               => "S-Right",
  51     BackwardKillWord       => "S-Left",
  52
  53     Yank                   => "A-Down", # paste
  54     KillLine               => "A-Right",
  55     BackwardKillLine       => "A-Left",
  56 };
  57
  58 our $key2codes = {
  59     "Tab"                  => [ "TAB", ],
  60     "C-d"                  => [ "C-d", ],
  61     "C-v"                  => [ "C-v", ],
  62
  63     "Insert"               => [ qq("\e[2~"), qq("\e[2z"), qq("\e[L"), ],
  64     "Del"                  => [ qq("\e[3~"), ],
  65     "PageUp"               => [ qq("\e[5~"), qq("\e[5z"), qq("\e[I"), ],
  66     "PageDown"             => [ qq("\e[6~"), qq("\e[6z"), qq("\e[G"), ],
  67     "Home"                 => [ qq("\e[7~"), qq("\e[1~"), qq("\e[H"), ],
  68     "End"                  => [ qq("\e[8~"), qq("\e[4~"), qq("\e[F"), ],
  69
  70     "C-Up"                 => [ qq("\eOa"), qq("\eOA"), qq("\e[1;5A"), ],
  71     "C-Down"               => [ qq("\eOb"), qq("\eOB"), qq("\e[1;5B"), ],
  72     "C-Right"              => [ qq("\eOc"), qq("\eOC"), qq("\e[1;5C"), ],
  73     "C-Left"               => [ qq("\eOd"), qq("\eOD"), qq("\e[1;5D"), ],
  74
  75     "S-Up"                 => [ qq("\e[a"), qq("\e[1;2A"), ],
  76     "S-Down"               => [ qq("\e[b"), qq("\e[1;2B"), ],
  77     "S-Right"              => [ qq("\e[c"), qq("\e[1;2C"), ],
  78     "S-Left"               => [ qq("\e[d"), qq("\e[1;2D"), ],
  79
  80     "A-Down"               => [ qq("\e\e[B"), qq("\e[1;3B"), ],
  81     "A-Right"              => [ qq("\e\e[C"), qq("\e[1;3C"), ],
  82     "A-Left"               => [ qq("\e\e[D"), qq("\e[1;3D"), ],
  83 };
  84
  85 # warn if any keycode is clobbered
  86 our $debug = 0;
  87
  88 # check ref type
  89 sub _is_array { ref($_[0]) && eval { @{ $_[0] } or 1 } }
  90 sub _is_hash  { ref($_[0]) && eval { %{ $_[0] } or 1 } }
  91
  92 # set bindkey actions for each terminal
  93 my %code2action;
  94
  95 sub rl_bind_action {
  96     if ($got_rl_perl)
  97     {
  98         my $a2k = shift();
  99         return () unless _is_hash($a2k);
 100
 101         while (my ($action, $bindkey) = each %{ $a2k })
 102         {
 103             # use default keycodes if none provided
 104             my @keycodes = @_ ? @_ : $key2codes;
 105
 106             for my $k2c (@keycodes)
 107             {
 108                 next unless _is_hash($k2c);
 109
 110                 my $codes = $k2c->{$bindkey};
 111                 next unless defined($codes);
 112                 $codes = [ $codes ] unless _is_array($codes);
 113
 114                 for my $code (@{ $codes })
 115                 {
 116                     if ($debug && $code2action{$code})
 117                     {
 118                         my $hexcode = $code;
 119                         $hexcode =~ s/^"(.*)"$/$1/;
 120                         $hexcode = join(" ", map { uc } unpack("(H2)*", $hexcode));
 121
 122                         warn <<"EOT";
 123 rl_bind_action(): re-binding keycode [ $hexcode ] from '$code2action{$code}' to '$action'
 124 EOT
 125                     }
 126
 127                     readline::rl_bind($code, $action);
 128                     $code2action{$code} = $action;
 129                 }
 130             }
 131         }
 132     }
 133     else
 134     {
 135         warn <<"EOT";
 136 rl_bind_action(): Term::ReadLine::Perl is not available. No bindkeys were set.
 137 EOT
 138     }
 139
 140     return $got_rl_perl;
 141 }
 142
 143 # default bind
 144 rl_bind_action($action2key);
 145
 146 # bind Delete key for 'xterm'
 147 if ($got_rl_perl && defined($ENV{TERM}) && $ENV{TERM} =~ /xterm/)
 148 {
 149     rl_bind_action($action2key, +{ "Del" => qq("\x7F") });
 150 }
 151
 152 'Term::ReadLine::Perl::Bind';
 153