File Coverage

blib/lib/Term/ReadLine/Perl5/Common.pm
Criterion Covered Total %
statement 32 44 72.7
branch 4 8 50.0
condition 1 6 16.6
subroutine 8 10 80.0
pod 4 5 80.0
total 49 73 67.1


line stmt bran cond sub pod time code
1             package Term::ReadLine::Perl5::Common;
2 1     1   19798 use strict; use warnings;
  1     1   2  
  1         35  
  1         4  
  1         0  
  1         22  
3 1     1   491 use English;
  1         3191  
  1         5  
4              
5             =head1 NAME
6              
7             Term::ReadLine::Perl5::Common
8              
9             =head1 DESCRIPTION
10              
11             A non-OO package which contains commmon routines for the OO (L and non-OO L routines of
12             L
13              
14             =cut
15              
16 1     1   384 use Exporter;
  1         1  
  1         31  
17 1     1   4 use vars qw(@EXPORT @ISA);
  1         1  
  1         859  
18             @ISA = qw(Exporter);
19             @EXPORT = qw(ctrl unescape canonic_command_function);
20              
21             =head1 SUBROUTINES
22              
23             =head2 Key-Binding Functions
24              
25             =head3 F_Ding
26              
27             Ring the bell.
28              
29             Should do something with I<$var_PreferVisibleBel> here, but what?
30             =cut
31              
32             sub F_Ding($) {
33 0     0 1 0 my $term_OUT = shift;
34 0         0 local $\ = '';
35 0         0 local $OUTPUT_RECORD_SEPARATOR = '';
36 0         0 print $term_OUT "\007";
37 0         0 return; # Undefined return value
38             }
39              
40             =head2 Internal Functions
41              
42             =head3 ctrl
43              
44             B(I<$ord>)
45              
46             Returns the ordinal number for the corresponding control code.
47              
48             For example I returns the ordinal for I
49             or 1. I does the same thing.
50              
51             =cut
52              
53             sub ctrl {
54 2 50 33 2 1 15 $_[0] ^ (($_[0]>=ord('a') && $_[0]<=ord('z')) ? 0x60 : 0x40);
55             }
56              
57             =head3 rl_tilde_expand
58              
59             rl_tilde_expand($prefix) => list of usernames
60              
61             Returns a list of completions that begin with the given prefix,
62             I<$prefix>. This only works if we have I available.
63              
64             =cut
65              
66             sub rl_tilde_expand($) {
67 0     0 1 0 my $prefix = shift;
68 0         0 my @matches = ();
69 0         0 setpwent();
70 0         0 while (my @fields = (getpwent)[0]) {
71 0 0 0     0 push @matches, $fields[0]
72             if ( $prefix eq ''
73             || $prefix eq substr($fields[0], 0, length($prefix)) );
74             }
75 0         0 setpwent();
76 0         0 @matches;
77             }
78              
79             =head3 unescape
80              
81             unescape($string) -> List of keys
82              
83             This internal function that takes I<$string> possibly containing
84             escape sequences, and converts to a series of octal keys.
85              
86             It has special rules for dealing with readline-specific escape-sequence
87             commands.
88              
89             New-style key bindings are enclosed in double-quotes.
90             Characters are taken verbatim except the special cases:
91              
92             \C-x Control x (for any x)
93             \M-x Meta x (for any x)
94             \e Escape
95             \* Set the keymap default (JP: added this)
96             (must be the last character of the sequence)
97             \x x (unless it fits the above pattern)
98              
99             Special case "\C-\M-x", should be treated like "\M-\C-x".
100              
101             =cut
102              
103             my @ESCAPE_REGEXPS = (
104             # Ctrl-meta
105             [ qr/^\\C-\\M-(.)/, sub { ord("\e"), ctrl(ord(shift)) } ],
106             # Meta
107             [ qr/^\\(M-|e)/, sub { ord("\e") } ],
108             # Ctrl
109             [ qr/^\\C-(.)/, sub { ctrl(ord(shift)) } ],
110             # hex value
111             [ qr/^\\x([0-9a-fA-F]{2})/, sub { hex(shift) } ],
112             # octal value
113             [ qr/^\\([0-7]{3})/, sub { oct(shift) } ],
114             # default
115             [ qr/^\\\*$/, sub { 'default'; } ],
116             # EOT (Ctrl-D)
117             [ qr/^\\d/, sub { 4 } ],
118             # Backspace
119             [ qr/\\b/, sub { 0x7f } ],
120             # Escape Sequence
121             [ qr/\\(.)/,
122             sub {
123             my $chr = shift;
124             ord(($chr =~ /^[afnrtv]$/) ? eval(qq("\\$chr")) : $chr);
125             } ],
126             );
127              
128             sub unescape($) {
129 8     8 1 2914 my $key = shift;
130 8         8 my @keys;
131              
132 8         22 CHAR: while (length($key) > 0) {
133 9         12 foreach my $command (@ESCAPE_REGEXPS) {
134 44         37 my $regex = $command->[0];
135 44 100       476 if ($key =~ s/^$regex//) {
136 8         19 push @keys, $command->[1]->($1);
137 8         25 next CHAR;
138             }
139             }
140 1         2 push @keys, ord($key);
141 1         3 substr($key,0,1) = '';
142             }
143             @keys
144 8         19 }
145              
146             # Canonicalize command function names according to these rules:
147             #
148             # * names have start with an uppercase letter
149             # * a dash followed by a letter gets turned into the uppercase letter with
150             # the dash removed.
151             #
152             # Examples:
153             # yank => Yank
154             # beginning-of-line => BeginningOfLine
155             sub canonic_command_function($) {
156 2     2 0 595 my $function_name = shift;
157 2 50       7 return undef unless defined($function_name);
158 2         4 $function_name = "\u$function_name";
159 2         5 $function_name =~ s/-(.)/\u$1/g;
160 2         12 $function_name;
161             }
162              
163             unless (caller) {
164             foreach my $word (qw(yank BeginningOfLine beginning-of-line)) {
165             printf("'%s' canonicalizes to '%s'\n",
166             $word, canonic_command_function($word));
167             }
168              
169             foreach my $word (qw(\C-w \C-\M-a \M-e \x10 \007 \010 \d \b)) {
170             my @unescaped = unescape($word);
171             print "unescape($word) is ", join(', ', @unescaped), "\n";
172             }
173             }
174              
175             1;