lib/Term/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	dpavlin	87	=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;