google/lib/Shelly.pm

=pod

=head1 NAME

Term::Shelly - Yet Another Shell Kit for Perl

=head1 VERSION

$Id: Shelly.pm,v 1.5 2004/06/04 04:21:23 psionic Exp $

=head1 GOAL

I needed a shell kit for an aim client I was writing. All of the Term::ReadLine modules are do blocking reads in doing their readline() functions, and as such are entirely unacceptable. This module is an effort on my part to provide the advanced functionality of great ReadLine modules like Zoid into a package that's more flexible, extendable, and most importantly, allows nonblocking reads to allow other things to happen at the same time.

=head1 NEEDS

- Settable key bindings
- Tab completion
- Support for window size changes (sigwinch)
- movement in-line editing.
- vi mode (Yeah, I lub vi)
- history
- Completion function calls

- Settable callbacks for when we have an end-of-line (EOL binding?)

=cut

package Term::Shelly;

use strict;
use warnings;

use vars qw($VERSION);
$VERSION = '0.01';

# Default perl modules...
use IO::Handle; # I need flush()... or do i?;

# Get these from CPAN
use Term::ReadKey;

# Useful constants we need...

# for find_word_bound()
use constant WORD_BEGINNING => 0;     # I want the beginning of this word.
use constant WORD_END => 1;           # I want the end of the word.
use constant WORD_ONLY => 2;          # Trailing spaces are important.
use constant WORD_REGEX => 4;         # I want to specify my own regexp

# Some key constant name mappings.
my %KEY_CONSTANTS = (
                                                        "\e[A"      => "UP",
                                                        "\e[B"      => "DOWN",
                                                        "\e[C"      => "RIGHT",
                                                        "\e[D"      => "LEFT",
                                                  );

# stty raw, basically
ReadMode 3;

# I need to know how big the terminal is (columns, anyway)

=pod

=head1 DESCRIPTION

=over 4

=cut

sub new ($) {
        my $class = shift;

        my $self = {
                "input_line" => "",
                "input_position" => 0,
                "leftcol" => 0,
        };

        bless $self, $class;

        ($self->{"termcols"}) = GetTerminalSize();
        $SIG{WINCH} = sub { ($self->{"termcols"}) = GetTerminalSize(); $self->fix_inputline() };
        my $bindings = {
                "LEFT"        => "backward-char",
                "RIGHT"       => "forward-char",
                "UP"          => "up-history",
                "DOWN"        => "down-history",

                "BACKSPACE"   => "delete-char-backward",
                "^H"          => "delete-char-backward",
                "^?"          => "delete-char-backward",
                "^W"          => "delete-word-backward",

                "^U"          => "kill-line",

                "^J"          => "newline",
                "^M"          => "newline",

                "^A"          => "beginning-of-line",
                "^E"          => "end-of-line",
                "^K"          => "kill-to-eol",
                "^L"          => "redraw",

                "^I"          => "complete-word",
                "TAB"         => "complete-word",

                #"^T"          => "expand-line",
        };

        my $mappings = {
                "backward-char"          => \&backward_char,
                "forward-char"           => \&forward_char,
                "delete-char-backward"   => \&delete_char_backward,
                "kill-line"              => \&kill_line,
                "newline"                => \&newline,
                "redraw"                 => \&fix_inputline,
                "beginning-of-line"      => \&beginning_of_line,
                "end-of-line"            => \&end_of_line,
                "delete-word-backward"   => \&delete_word_backward,

                "complete-word"          => \&complete_word,
                #"expand-line"            => \&expand_line,
        };

        $self->{"bindings"} = $bindings;
        $self->{"mappings"} = $mappings;
        return $self;
}

=pod

=item $sh->do_one_loop()

Does... one... loop. Makes a pass at grabbing input and processing it. For
speedy pasts, this loops until there are no characters left to read.
It will handle event processing, etc.

=cut

# Nonblocking readline
sub do_one_loop ($) { 
        my $self = shift;
        my $char;

        # ReadKey(.1) means no timeout waiting for data, thus is nonblocking
        while (defined($char = ReadKey(.1))) {
                $self->handle_key($char);
        }
        
}

=pod

=item handle_key($key)

Handle a single character input. This is not a "key press" so much as doing all
the necessary things to handle key presses.

=cut

sub handle_key($$) {
        my $self = shift;
        my $char = shift;

        my $line = $self->{"input_line"} || "";
        my $pos = $self->{"input_position"} || 0;

        if ($self->{"escape"}) {
                $self->{"escape_string"} .= $char;
                if ($self->{"escape_expect_ansi"}) {
                        $self->{"escape_expect_ansi"} = 0 if ($char =~ m/[a-zA-Z]/);
                }

                $self->{"escape_expect_ansi"} = 1 if ($char eq '[');
                $self->{"escape"} = 0 unless ($self->{"escape_expect_ansi"});

                unless ($self->{"escape_expect_ansi"}) {
                        my $estring = $self->{"escape_string"};

                        $self->{"escape_string"} = undef;
                        return $self->execute_binding("\e".$estring);
                }

                return 0;
        }

        if ($char eq "\e") {      # Trap escapes, they're speshul.
                $self->{"escape"} = 1;
                $self->{"escape_string"} = undef;
                
                # What now?
                return 0;
        }

        if ((ord($char) < 32) || (ord($char) > 126)) {   # Control character
                $self->execute_binding($char);
                return 0;
        }

        if ((defined($char)) && (ord($char) >= 32)) {
                substr($line, $pos, 0) = $char;
                $self->{"input_position"}++;

                # If we just did a tab completion, kill the state.
                delete($self->{"completion"}) if (defined($self->{"completion"}));
        }

        $self->{"input_line"} = $line;
        $self->fix_inputline();
}

=pod

=item execute_binding(raw_key)

Guess what this does? Ok I'll explain anyway... It takes a key and prettifies
it, then checks the known key bindings for a mapping and checks if that mapping
is a coderef (a function reference). If it is, it'll call that function. If
not, it'll do nothing. If it finds a binding for which there is no mapped
function, it'll tell you that it is an unimplemented function.

=cut

sub execute_binding ($$) {
        my $self = shift;
        my $str = shift;
        my $key = $self->prettify_key($str);

        my $bindings = $self->{"bindings"};
        my $mappings = $self->{"mappings"};

        if (defined($bindings->{$key})) {

                # Check if we have stored completion state and the next binding is
                # not complete-word. If it isn't, then kill the completion state.
                if (defined($self->{"completion"}) && 
                         $bindings->{$key} ne 'complete-word') {
                        delete($self->{"completion"});
                }

                if (ref($mappings->{$bindings->{$key}}) eq 'CODE') {

                        # This is a hack, passing $self instead of doing:
                        # $self->function, becuase I don't want to do an eval.

                        return &{$mappings->{$bindings->{$key}}}($self);

                } else {
                        error("Unimplemented function, " . $bindings->{$key});
                }
        }

        return 0;
}

=pod

=item prettify_key(raw_key)

This happy function lets me turn raw input into something less ugly. It turns
control keys into their equivalent ^X form. It does some other things to turn
the key into something more readable 

=cut

sub prettify_key ($$) {
        my $self = shift;
        my $key = shift;

        # Return ^X for control characters, like CTRL+A...
        if (length($key) == 1) {   # One-character keycombos should only be ctrl keys
                if (ord($key) <= 26) {  # Control codes, another check anyway...
                        return "^" . chr(65 + ord($key) - 1);
                }
                if (ord($key) == 127) { # Speshul backspace key
                        return "^?";
                }
                if (ord($key) < 32) {
                        return "^" . (split("", "\]_^"))[ord($key) - 28];
                }
        }

        # Return ESC-X for escape shenanigans, like ESC-W
        if (length($key) == 2) {
                my ($p, $k) = split("", $key);
                if ($p eq "\e") {    # This should always be an escape, but.. check anyway
                        return "ESC-" . $k;
                }
        }

        # Ok, so it's not ^X or ESC-X, it's gotta be some ansi funk.
        return $KEY_CONSTANTS{$key};
}

=pod 

=item real_out($string)

This function allows you to bypass any sort of evil shenanigans regarding output fudging. All this does is 'print @_;'

Don't use this unless you know what you're doing.

=cut

sub real_out {
        my $self = shift;
        print @_;
}

sub out ($;$) {
        my $self = shift;
        $self->real_out("\r\e[2K", @_, "\n");
        $self->fix_inputline();
}

sub error ($$) { 
        my $self = shift;
        print STDERR "*> ", @_, "\n";
        $self->fix_inputline();
}

=pod 

=item fix_inputline

This super-happy function redraws the input line. If input_position is beyond the bounds of the terminal, it'll shuffle around so that it can display it. This function is called just about any time any key is hit.

=cut

sub fix_inputline {
        my $self = shift;

        print "\r\e[2K";

        # If we're past the end of the terminal line, shuffle back!
        if ($self->{"input_position"} - $self->{"leftcol"} <= 0) {
                $self->{"leftcol"} -= 30;
                $self->{"leftcol"} = 0 if ($self->{"leftcol"} < 0);
        }

        # If we're before the beginning of the terminal line, shuffle over!
        if ($self->{"input_position"} - $self->{"leftcol"} > $self->{"termcols"}) {
                $self->{"leftcol"} += 30;
        }

        # Can se show the whole line? If so, do it!
        if (length($self->{"input_line"}) < $self->{"termcols"}) {
                $self->{"leftcol"} = 0;
        }

        # only print as much as we can in this one line.
        print substr($self->{"input_line"}, $self->{"leftcol"}, $self->{"termcols"});
        print "\r";
        print "\e[" . ($self->{"input_position"} - $self->{"leftcol"}) . 
              "C" if ($self->{"input_position"} > 0);
        STDOUT->flush();
}

sub newline {
        my $self = shift;
        # Process the input line.

        $self->real_out("\n");
        print "You wrote: " . $self->{"input_line"} . "\n";

        $self->{"input_line"} = "";
        $self->{"input_position"} = 0;
}

sub kill_line {
        my $self = shift;
        $self->{"input_line"} = "";
        $self->{"input_position"} = 0;
        $self->{"leftcol"} = 0;

        #real_out("\r\e[2K");

        $self->fix_inputline();

        return 0;
}

sub forward_char {
        my $self = shift;
        if ($self->{"input_position"} < length($self->{"input_line"})) {
                $self->{"input_position"}++;
                $self->real_out("\e[C");
        }
}

sub backward_char {
        my $self = shift;
        if ($self->{"input_position"} > 0) {
                $self->{"input_position"}--;
                $self->real_out("\e[D");
        }
}

sub delete_char_backward {
        my $self = shift;
        #"delete-char-backward"   => \&delete_char_backward,
        if ($self->{"input_position"} > 0) {
                substr($self->{"input_line"}, $self->{"input_position"} - 1, 1) = '';
                $self->{"input_position"}--;

                $self->fix_inputline();
        }
}

sub beginning_of_line {
        my $self = shift;
        $self->{"input_position"} = 0;
        $self->{"leftcol"} = 0;
        $self->fix_inputline();
}

sub end_of_line {
        my $self = shift;
        $self->{"input_position"} = length($self->{"input_line"});
        $self->fix_inputline();
}

sub delete_word_backward {
        my $self = shift;
        my $pos = $self->{"input_position"};
        my $line = $self->{"input_line"};
        my $regex = "[A-Za-z0-9]";
        my $bword;

        $bword = $self->find_word_bound($line, $pos, WORD_BEGINNING);

        # Delete whatever word we just found.
        substr($line, $bword, $pos - $bword) = '';

        # Update stuff...
        $self->{"input_line"} = $line;
        $self->{"input_position"} -= ($pos - $bword);

        $self->fix_inputline();
}

=pod

=item $sh->complete_word

This is called whenever the complete-word binding is triggered. See the
COMPLETION section below for how to write your own completion function.

=cut

sub complete_word {
        my $self = shift;
        my $pos = $self->{"input_position"};
        my $line = $self->{"input_line"};
        my $regex = "[A-Za-z0-9]";
        my $bword;
        my $complete;

        if (ref($self->{"completion_function"}) eq 'CODE') {
                my @matches;

        # Maintain some sort of state here if this is the first time we've 
        # hit complete_word() for this "scenario." What I mean is, we need to track
        # whether or not this user is hitting tab once or twice (or more) in the
        # same position.
RECHECK:
                if (!defined($self->{"completion"})) {
                        $bword = $self->find_word_bound($line, $pos, WORD_BEGINNING | WORD_REGEX, '\S');
                        $complete = substr($line,$bword,$pos - $bword);
                        #$self->out("Complete: $complete");

                        #$self->out("First time completing $complete");
                        $self->{"completion"} = {
                                "index" => 0,
                                "original" => $complete,
                                "pos" => $pos,
                                "bword" => $bword,
                                "line" => $line,
                                "endpos" => $pos,
                        };
                } else {
                        $bword = $self->{"completion"}->{"bword"};
                        $complete = substr($line,$bword,$pos - $bword);
                }

                # If we don't have any matches to check against...
                unless (defined($self->{"completion"}->{"matches"})) {
                        @matches = 
                                &{$self->{"completion_function"}}($line, $bword, $pos, $complete);
                        @{$self->{"completion"}->{"matches"}} = @matches;
                } else {
                        @matches = @{$self->{"completion"}->{"matches"}};
                }

                my $match = $matches[$self->{"completion"}->{"index"}];

                return unless (defined($match));

                #$self->out("Match: $match / " . $self->{"completion"}->{"index"} . " / " . @matches);

                $self->{"completion"}->{"index"}++;
                $self->{"completion"}->{"index"} = 0 if ($self->{"completion"}->{"index"} == scalar(@matches));

                substr($line, $bword, $pos - $bword) = $match;

                $self->{"completion"}->{"endpos"} = $pos;

                $pos = $bword + length($match);
                $self->{"input_position"} = $pos;
                $self->{"input_line"} = $line;

                $self->fix_inputline();

        }
}


# --------------------------------------------------------------------
# Helper functions

# Go from a position and find the beginning of the word we're on.
sub find_word_bound ($$$;$) {
        my $self = shift;
        my $line = shift;
        my $pos = shift;
        my $opts = shift || 0;
        my $regex = "[A-Za-z0-9]";
        my $bword;

        $regex = shift if ($opts & WORD_REGEX);

        # Mod? This is either -1 or +1 depending on if we're looking behind or
        # if we're looking ahead.
        my $mod = -1;
        $mod = 1 if ($opts & WORD_END);

        # What are we doing?
        # If we're in a word, go to the beginning of the word
        # If we're on a space, go to end of previous word.
        # If we're on a nonspace/nonword, go to beginning of nonword chars
        
        $bword = $pos - 1;

        # If we're at the end of the string, ignore all trailing whitespace.
        # unless WORD_ONLY is set.
        #out("
        if (($bword + 1 == $pos) && (! $opts & WORD_ONLY)) {
                $bword += $mod while (substr($line,$bword,1) =~ m/^\s$/);
        }

        # If we're not on an ALPHANUM, then we want to reverse the match.
        # that is, if we are:
        # "testing here hello .......there"
        #                           ^-- here
        # Then we want to delete (match) all the periods (nonalphanums)
        substr($regex, 1, 0) = "^" if (substr($line,$bword,1) !~ m/$regex/);

        # Back up until we hit the end of our "word"
        $bword += $mod while (substr($line,$bword,1) =~ m/$regex/ && $bword >= 0);

        # Whoops, one too far...
        $bword -= $mod;

        return $bword;
}

=pod

=back

=cut

1;
1	=pod
2
3	=head1 NAME
4
5	Term::Shelly - Yet Another Shell Kit for Perl
6
7	=head1 VERSION
8
9	$Id: Shelly.pm,v 1.5 2004/06/04 04:21:23 psionic Exp $
10
11	=head1 GOAL
12
13	I needed a shell kit for an aim client I was writing. All of the Term::ReadLine modules are do blocking reads in doing their readline() functions, and as such are entirely unacceptable. This module is an effort on my part to provide the advanced functionality of great ReadLine modules like Zoid into a package that's more flexible, extendable, and most importantly, allows nonblocking reads to allow other things to happen at the same time.
14
15	=head1 NEEDS
16
17	- Settable key bindings
18	- Tab completion
19	- Support for window size changes (sigwinch)
20	- movement in-line editing.
21	- vi mode (Yeah, I lub vi)
22	- history
23	- Completion function calls
24
25	- Settable callbacks for when we have an end-of-line (EOL binding?)
26
27	=cut
28
29	package Term::Shelly;
30
31	use strict;
32	use warnings;
33
34	use vars qw($VERSION);
35	$VERSION = '0.01';
36
37	# Default perl modules...
38	use IO::Handle; # I need flush()... or do i?;
39
40	# Get these from CPAN
41	use Term::ReadKey;
42
43	# Useful constants we need...
44
45	# for find_word_bound()
46	use constant WORD_BEGINNING => 0; # I want the beginning of this word.
47	use constant WORD_END => 1; # I want the end of the word.
48	use constant WORD_ONLY => 2; # Trailing spaces are important.
49	use constant WORD_REGEX => 4; # I want to specify my own regexp
50
51	# Some key constant name mappings.
52	my %KEY_CONSTANTS = (
53	"\e[A" => "UP",
54	"\e[B" => "DOWN",
55	"\e[C" => "RIGHT",
56	"\e[D" => "LEFT",
57	);
58
59	# stty raw, basically
60	ReadMode 3;
61
62	# I need to know how big the terminal is (columns, anyway)
63
64	=pod
65
66	=head1 DESCRIPTION
67
68	=over 4
69
70	=cut
71
72	sub new ($) {
73	my $class = shift;
74
75	my $self = {
76	"input_line" => "",
77	"input_position" => 0,
78	"leftcol" => 0,
79	};
80
81	bless $self, $class;
82
83	($self->{"termcols"}) = GetTerminalSize();
84	$SIG{WINCH} = sub { ($self->{"termcols"}) = GetTerminalSize(); $self->fix_inputline() };
85	my $bindings = {
86	"LEFT" => "backward-char",
87	"RIGHT" => "forward-char",
88	"UP" => "up-history",
89	"DOWN" => "down-history",
90
91	"BACKSPACE" => "delete-char-backward",
92	"^H" => "delete-char-backward",
93	"^?" => "delete-char-backward",
94	"^W" => "delete-word-backward",
95
96	"^U" => "kill-line",
97
98	"^J" => "newline",
99	"^M" => "newline",
100
101	"^A" => "beginning-of-line",
102	"^E" => "end-of-line",
103	"^K" => "kill-to-eol",
104	"^L" => "redraw",
105
106	"^I" => "complete-word",
107	"TAB" => "complete-word",
108
109	#"^T" => "expand-line",
110	};
111
112	my $mappings = {
113	"backward-char" => \&backward_char,
114	"forward-char" => \&forward_char,
115	"delete-char-backward" => \&delete_char_backward,
116	"kill-line" => \&kill_line,
117	"newline" => \&newline,
118	"redraw" => \&fix_inputline,
119	"beginning-of-line" => \&beginning_of_line,
120	"end-of-line" => \&end_of_line,
121	"delete-word-backward" => \&delete_word_backward,
122
123	"complete-word" => \&complete_word,
124	#"expand-line" => \&expand_line,
125	};
126
127	$self->{"bindings"} = $bindings;
128	$self->{"mappings"} = $mappings;
129	return $self;
130	}
131
132	=pod
133
134	=item $sh->do_one_loop()
135
136	Does... one... loop. Makes a pass at grabbing input and processing it. For
137	speedy pasts, this loops until there are no characters left to read.
138	It will handle event processing, etc.
139
140	=cut
141
142	# Nonblocking readline
143	sub do_one_loop ($) {
144	my $self = shift;
145	my $char;
146
147	# ReadKey(.1) means no timeout waiting for data, thus is nonblocking
148	while (defined($char = ReadKey(.1))) {
149	$self->handle_key($char);
150	}
151
152	}
153
154	=pod
155
156	=item handle_key($key)
157
158	Handle a single character input. This is not a "key press" so much as doing all
159	the necessary things to handle key presses.
160
161	=cut
162
163	sub handle_key($$) {
164	my $self = shift;
165	my $char = shift;
166
167	my $line = $self->{"input_line"} \|\| "";
168	my $pos = $self->{"input_position"} \|\| 0;
169
170	if ($self->{"escape"}) {
171	$self->{"escape_string"} .= $char;
172	if ($self->{"escape_expect_ansi"}) {
173	$self->{"escape_expect_ansi"} = 0 if ($char =~ m/[a-zA-Z]/);
174	}
175
176	$self->{"escape_expect_ansi"} = 1 if ($char eq '[');
177	$self->{"escape"} = 0 unless ($self->{"escape_expect_ansi"});
178
179	unless ($self->{"escape_expect_ansi"}) {
180	my $estring = $self->{"escape_string"};
181
182	$self->{"escape_string"} = undef;
183	return $self->execute_binding("\e".$estring);
184	}
185
186	return 0;
187	}
188
189	if ($char eq "\e") { # Trap escapes, they're speshul.
190	$self->{"escape"} = 1;
191	$self->{"escape_string"} = undef;
192
193	# What now?
194	return 0;
195	}
196
197	if ((ord($char) < 32) \|\| (ord($char) > 126)) { # Control character
198	$self->execute_binding($char);
199	return 0;
200	}
201
202	if ((defined($char)) && (ord($char) >= 32)) {
203	substr($line, $pos, 0) = $char;
204	$self->{"input_position"}++;
205
206	# If we just did a tab completion, kill the state.
207	delete($self->{"completion"}) if (defined($self->{"completion"}));
208	}
209
210	$self->{"input_line"} = $line;
211	$self->fix_inputline();
212	}
213
214	=pod
215
216	=item execute_binding(raw_key)
217
218	Guess what this does? Ok I'll explain anyway... It takes a key and prettifies
219	it, then checks the known key bindings for a mapping and checks if that mapping
220	is a coderef (a function reference). If it is, it'll call that function. If
221	not, it'll do nothing. If it finds a binding for which there is no mapped
222	function, it'll tell you that it is an unimplemented function.
223
224	=cut
225
226	sub execute_binding ($$) {
227	my $self = shift;
228	my $str = shift;
229	my $key = $self->prettify_key($str);
230
231	my $bindings = $self->{"bindings"};
232	my $mappings = $self->{"mappings"};
233
234	if (defined($bindings->{$key})) {
235
236	# Check if we have stored completion state and the next binding is
237	# not complete-word. If it isn't, then kill the completion state.
238	if (defined($self->{"completion"}) &&
239	$bindings->{$key} ne 'complete-word') {
240	delete($self->{"completion"});
241	}
242
243	if (ref($mappings->{$bindings->{$key}}) eq 'CODE') {
244
245	# This is a hack, passing $self instead of doing:
246	# $self->function, becuase I don't want to do an eval.
247
248	return &{$mappings->{$bindings->{$key}}}($self);
249
250	} else {
251	error("Unimplemented function, " . $bindings->{$key});
252	}
253	}
254
255	return 0;
256	}
257
258	=pod
259
260	=item prettify_key(raw_key)
261
262	This happy function lets me turn raw input into something less ugly. It turns
263	control keys into their equivalent ^X form. It does some other things to turn
264	the key into something more readable
265
266	=cut
267
268	sub prettify_key ($$) {
269	my $self = shift;
270	my $key = shift;
271
272	# Return ^X for control characters, like CTRL+A...
273	if (length($key) == 1) { # One-character keycombos should only be ctrl keys
274	if (ord($key) <= 26) { # Control codes, another check anyway...
275	return "^" . chr(65 + ord($key) - 1);
276	}
277	if (ord($key) == 127) { # Speshul backspace key
278	return "^?";
279	}
280	if (ord($key) < 32) {
281	return "^" . (split("", "\]_^"))[ord($key) - 28];
282	}
283	}
284
285	# Return ESC-X for escape shenanigans, like ESC-W
286	if (length($key) == 2) {
287	my ($p, $k) = split("", $key);
288	if ($p eq "\e") { # This should always be an escape, but.. check anyway
289	return "ESC-" . $k;
290	}
291	}
292
293	# Ok, so it's not ^X or ESC-X, it's gotta be some ansi funk.
294	return $KEY_CONSTANTS{$key};
295	}
296
297	=pod
298
299	=item real_out($string)
300
301	This function allows you to bypass any sort of evil shenanigans regarding output fudging. All this does is 'print @_;'
302
303	Don't use this unless you know what you're doing.
304
305	=cut
306
307	sub real_out {
308	my $self = shift;
309	print @_;
310	}
311
312	sub out ($;$) {
313	my $self = shift;
314	$self->real_out("\r\e[2K", @_, "\n");
315	$self->fix_inputline();
316	}
317
318	sub error ($$) {
319	my $self = shift;
320	print STDERR "*> ", @_, "\n";
321	$self->fix_inputline();
322	}
323
324	=pod
325
326	=item fix_inputline
327
328	This super-happy function redraws the input line. If input_position is beyond the bounds of the terminal, it'll shuffle around so that it can display it. This function is called just about any time any key is hit.
329
330	=cut
331
332	sub fix_inputline {
333	my $self = shift;
334
335	print "\r\e[2K";
336
337	# If we're past the end of the terminal line, shuffle back!
338	if ($self->{"input_position"} - $self->{"leftcol"} <= 0) {
339	$self->{"leftcol"} -= 30;
340	$self->{"leftcol"} = 0 if ($self->{"leftcol"} < 0);
341	}
342
343	# If we're before the beginning of the terminal line, shuffle over!
344	if ($self->{"input_position"} - $self->{"leftcol"} > $self->{"termcols"}) {
345	$self->{"leftcol"} += 30;
346	}
347
348	# Can se show the whole line? If so, do it!
349	if (length($self->{"input_line"}) < $self->{"termcols"}) {
350	$self->{"leftcol"} = 0;
351	}
352
353	# only print as much as we can in this one line.
354	print substr($self->{"input_line"}, $self->{"leftcol"}, $self->{"termcols"});
355	print "\r";
356	print "\e[" . ($self->{"input_position"} - $self->{"leftcol"}) .
357	"C" if ($self->{"input_position"} > 0);
358	STDOUT->flush();
359	}
360
361	sub newline {
362	my $self = shift;
363	# Process the input line.
364
365	$self->real_out("\n");
366	print "You wrote: " . $self->{"input_line"} . "\n";
367
368	$self->{"input_line"} = "";
369	$self->{"input_position"} = 0;
370	}
371
372	sub kill_line {
373	my $self = shift;
374	$self->{"input_line"} = "";
375	$self->{"input_position"} = 0;
376	$self->{"leftcol"} = 0;
377
378	#real_out("\r\e[2K");
379
380	$self->fix_inputline();
381
382	return 0;
383	}
384
385	sub forward_char {
386	my $self = shift;
387	if ($self->{"input_position"} < length($self->{"input_line"})) {
388	$self->{"input_position"}++;
389	$self->real_out("\e[C");
390	}
391	}
392
393	sub backward_char {
394	my $self = shift;
395	if ($self->{"input_position"} > 0) {
396	$self->{"input_position"}--;
397	$self->real_out("\e[D");
398	}
399	}
400
401	sub delete_char_backward {
402	my $self = shift;
403	#"delete-char-backward" => \&delete_char_backward,
404	if ($self->{"input_position"} > 0) {
405	substr($self->{"input_line"}, $self->{"input_position"} - 1, 1) = '';
406	$self->{"input_position"}--;
407
408	$self->fix_inputline();
409	}
410	}
411
412	sub beginning_of_line {
413	my $self = shift;
414	$self->{"input_position"} = 0;
415	$self->{"leftcol"} = 0;
416	$self->fix_inputline();
417	}
418
419	sub end_of_line {
420	my $self = shift;
421	$self->{"input_position"} = length($self->{"input_line"});
422	$self->fix_inputline();
423	}
424
425	sub delete_word_backward {
426	my $self = shift;
427	my $pos = $self->{"input_position"};
428	my $line = $self->{"input_line"};
429	my $regex = "[A-Za-z0-9]";
430	my $bword;
431
432	$bword = $self->find_word_bound($line, $pos, WORD_BEGINNING);
433
434	# Delete whatever word we just found.
435	substr($line, $bword, $pos - $bword) = '';
436
437	# Update stuff...
438	$self->{"input_line"} = $line;
439	$self->{"input_position"} -= ($pos - $bword);
440
441	$self->fix_inputline();
442	}
443
444	=pod
445
446	=item $sh->complete_word
447
448	This is called whenever the complete-word binding is triggered. See the
449	COMPLETION section below for how to write your own completion function.
450
451	=cut
452
453	sub complete_word {
454	my $self = shift;
455	my $pos = $self->{"input_position"};
456	my $line = $self->{"input_line"};
457	my $regex = "[A-Za-z0-9]";
458	my $bword;
459	my $complete;
460
461	if (ref($self->{"completion_function"}) eq 'CODE') {
462	my @matches;
463
464	# Maintain some sort of state here if this is the first time we've
465	# hit complete_word() for this "scenario." What I mean is, we need to track
466	# whether or not this user is hitting tab once or twice (or more) in the
467	# same position.
468	RECHECK:
469	if (!defined($self->{"completion"})) {
470	$bword = $self->find_word_bound($line, $pos, WORD_BEGINNING \| WORD_REGEX, '\S');
471	$complete = substr($line,$bword,$pos - $bword);
472	#$self->out("Complete: $complete");
473
474	#$self->out("First time completing $complete");
475	$self->{"completion"} = {
476	"index" => 0,
477	"original" => $complete,
478	"pos" => $pos,
479	"bword" => $bword,
480	"line" => $line,
481	"endpos" => $pos,
482	};
483	} else {
484	$bword = $self->{"completion"}->{"bword"};
485	$complete = substr($line,$bword,$pos - $bword);
486	}
487
488	# If we don't have any matches to check against...
489	unless (defined($self->{"completion"}->{"matches"})) {
490	@matches =
491	&{$self->{"completion_function"}}($line, $bword, $pos, $complete);
492	@{$self->{"completion"}->{"matches"}} = @matches;
493	} else {
494	@matches = @{$self->{"completion"}->{"matches"}};
495	}
496
497	my $match = $matches[$self->{"completion"}->{"index"}];
498
499	return unless (defined($match));
500
501	#$self->out("Match: $match / " . $self->{"completion"}->{"index"} . " / " . @matches);
502
503	$self->{"completion"}->{"index"}++;
504	$self->{"completion"}->{"index"} = 0 if ($self->{"completion"}->{"index"} == scalar(@matches));
505
506	substr($line, $bword, $pos - $bword) = $match;
507
508	$self->{"completion"}->{"endpos"} = $pos;
509
510	$pos = $bword + length($match);
511	$self->{"input_position"} = $pos;
512	$self->{"input_line"} = $line;
513
514	$self->fix_inputline();
515
516	}
517	}
518
519
520	# --------------------------------------------------------------------
521	# Helper functions
522
523	# Go from a position and find the beginning of the word we're on.
524	sub find_word_bound ($$$;$) {
525	my $self = shift;
526	my $line = shift;
527	my $pos = shift;
528	my $opts = shift \|\| 0;
529	my $regex = "[A-Za-z0-9]";
530	my $bword;
531
532	$regex = shift if ($opts & WORD_REGEX);
533
534	# Mod? This is either -1 or +1 depending on if we're looking behind or
535	# if we're looking ahead.
536	my $mod = -1;
537	$mod = 1 if ($opts & WORD_END);
538
539	# What are we doing?
540	# If we're in a word, go to the beginning of the word
541	# If we're on a space, go to end of previous word.
542	# If we're on a nonspace/nonword, go to beginning of nonword chars
543
544	$bword = $pos - 1;
545
546	# If we're at the end of the string, ignore all trailing whitespace.
547	# unless WORD_ONLY is set.
548	#out("
549	if (($bword + 1 == $pos) && (! $opts & WORD_ONLY)) {
550	$bword += $mod while (substr($line,$bword,1) =~ m/^\s$/);
551	}
552
553	# If we're not on an ALPHANUM, then we want to reverse the match.
554	# that is, if we are:
555	# "testing here hello .......there"
556	# ^-- here
557	# Then we want to delete (match) all the periods (nonalphanums)
558	substr($regex, 1, 0) = "^" if (substr($line,$bword,1) !~ m/$regex/);
559
560	# Back up until we hit the end of our "word"
561	$bword += $mod while (substr($line,$bword,1) =~ m/$regex/ && $bword >= 0);
562
563	# Whoops, one too far...
564	$bword -= $mod;
565
566	return $bword;
567	}
568
569	=pod
570
571	=back
572
573	=cut
574
575	1;