| 1 |
=pod |
| 2 |
|
| 3 |
=head1 NAME |
| 4 |
|
| 5 |
Term::Shelly - Yet Another Shell Kit for Perl |
| 6 |
|
| 7 |
=head1 VERSION |
| 8 |
|
| 9 |
$Id$ |
| 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 |
- history |
| 19 |
- vi mode (Yeah, I lub vi) |
| 20 |
|
| 21 |
=head1 DONE |
| 22 |
|
| 23 |
- Callback for 'anykey' |
| 24 |
- Tab completion |
| 25 |
- Support for window size changes (sigwinch) |
| 26 |
- movement/in-line editing. |
| 27 |
- Completion function calls |
| 28 |
- Settable callbacks for when we have an end-of-line (EOL binding?) |
| 29 |
|
| 30 |
=cut |
| 31 |
|
| 32 |
package Term::Shelly; |
| 33 |
|
| 34 |
use strict; |
| 35 |
use warnings; |
| 36 |
|
| 37 |
use vars qw($VERSION); |
| 38 |
$VERSION = '0.2'; |
| 39 |
|
| 40 |
# Default perl modules... |
| 41 |
use IO::Select; |
| 42 |
use IO::Handle; # I need flush()... or do i?; |
| 43 |
|
| 44 |
# Get these from CPAN |
| 45 |
use Term::ReadKey; |
| 46 |
|
| 47 |
# Useful constants we need... |
| 48 |
|
| 49 |
# for find_word_bound() |
| 50 |
use constant WORD_BEGINNING => 1; # look for the beginning of this word. |
| 51 |
use constant WORD_END => 2; # look for end of the word. |
| 52 |
use constant WORD_NEXT => 4; # look for beginning of next word |
| 53 |
use constant WORD_ONLY => 8; # Trailing spaces are important. |
| 54 |
use constant WORD_REGEX => 16; # I want to specify my own regexp |
| 55 |
|
| 56 |
# for vi_jumpchar() |
| 57 |
use constant JUMP_BACKCHARTO => 000; # 'T' in vi (backwards) |
| 58 |
use constant JUMP_BACKCHAR => 001; # 'F' in vi (backwards) |
| 59 |
use constant JUMP_CHARTO => 010; # 't' in vi (forwards) |
| 60 |
use constant JUMP_CHAR => 011; # 'f' in vi (forwards) |
| 61 |
|
| 62 |
# Some key constant name mappings. |
| 63 |
# I definately need a function to do this and some sort of hash returned which |
| 64 |
# specifies the key pressed and any modifiers too. |
| 65 |
# Like... ctrl+f5 is \e[15;5~ ... and not on all systems. |
| 66 |
my %KEY_CONSTANTS = ( |
| 67 |
"\e[A" => "UP", |
| 68 |
"\e[B" => "DOWN", |
| 69 |
"\e[C" => "RIGHT", |
| 70 |
"\e[D" => "LEFT", |
| 71 |
); |
| 72 |
|
| 73 |
# stty raw, basically |
| 74 |
ReadMode 3; |
| 75 |
|
| 76 |
# I need to know how big the terminal is (columns, anyway) |
| 77 |
|
| 78 |
=pod |
| 79 |
|
| 80 |
=head1 DESCRIPTION |
| 81 |
|
| 82 |
=over 4 |
| 83 |
|
| 84 |
=cut |
| 85 |
|
| 86 |
sub new ($) { |
| 87 |
my $class = shift; |
| 88 |
|
| 89 |
my $self = { |
| 90 |
"input_line" => "", |
| 91 |
"input_position" => 0, |
| 92 |
"input_prompt" => "", |
| 93 |
"leftcol" => 0, |
| 94 |
"echo" => 1, |
| 95 |
"vi_mode" => 0, |
| 96 |
"mode" => "insert", |
| 97 |
}; |
| 98 |
|
| 99 |
bless $self, $class; |
| 100 |
|
| 101 |
($self->{"termcols"}) = GetTerminalSize(); |
| 102 |
$SIG{WINCH} = sub { ($self->{"termcols"}) = GetTerminalSize(); $self->fix_inputline() }; |
| 103 |
$SIG{CONT} = sub { ReadMode 3; $self->fix_inputline; }; |
| 104 |
|
| 105 |
$self->{"select"} = new IO::Select(\*STDIN); |
| 106 |
|
| 107 |
my $bindings = { |
| 108 |
"ANYKEY" => "anykey", |
| 109 |
"LEFT" => "backward-char", |
| 110 |
"RIGHT" => "forward-char", |
| 111 |
"UP" => "up-history", |
| 112 |
"DOWN" => "down-history", |
| 113 |
|
| 114 |
"BACKSPACE" => "delete-char-backward", |
| 115 |
"^H" => "delete-char-backward", |
| 116 |
"^?" => "delete-char-backward", |
| 117 |
"^W" => "delete-word-backward", |
| 118 |
|
| 119 |
"^U" => "kill-line", |
| 120 |
|
| 121 |
"^J" => "newline", |
| 122 |
"^M" => "newline", |
| 123 |
|
| 124 |
"^A" => "beginning-of-line", |
| 125 |
"^E" => "end-of-line", |
| 126 |
"^K" => "kill-to-eol", |
| 127 |
"^L" => "redraw", |
| 128 |
|
| 129 |
"^I" => "complete-word", |
| 130 |
"TAB" => "complete-word", |
| 131 |
|
| 132 |
#"^T" => "expand-line", |
| 133 |
|
| 134 |
#-------------------------------- |
| 135 |
# vi bindings |
| 136 |
# |
| 137 |
|
| 138 |
# -------- DIRECTIONS |
| 139 |
|
| 140 |
"vi_h" => "vi-backward-char", # DONE |
| 141 |
"vi_l" => "vi-forward-char", # DONE |
| 142 |
"vi_k" => "vi-up-history", |
| 143 |
"vi_j" => "vi-down-history", |
| 144 |
|
| 145 |
"vi_w" => "vi-forward-word", # DONE |
| 146 |
"vi_W" => "vi-forward-whole-word", # DONE |
| 147 |
"vi_e" => "vi-end-word", # DONE |
| 148 |
"vi_E" => "vi-end-whole-word", # DONE |
| 149 |
"vi_t" => "vi-forward-charto", |
| 150 |
"vi_T" => "vi-backward-charto", |
| 151 |
"vi_f" => "vi-forward-charat", |
| 152 |
"vi_F" => "vi-backward-charat", |
| 153 |
"vi_G" => "vi-history-goto", |
| 154 |
"vi_b" => "vi-beginning-word", |
| 155 |
"vi_B" => "vi-beginning-whole-word",, |
| 156 |
"vi_n" => "vi-search-next", |
| 157 |
"vi_N" => "vi-search-prev", |
| 158 |
"vi_'" => "vi-mark-goto", |
| 159 |
'vi_$' => "vi-end-of-line", |
| 160 |
"vi_^" => "vi-beginning-of-line", |
| 161 |
|
| 162 |
# -------- INSERTION |
| 163 |
|
| 164 |
"vi_i" => "vi-insert", |
| 165 |
"vi_I" => "vi-insert-at-bol", |
| 166 |
"vi_a" => "vi-add", |
| 167 |
"vi_A" => "vi-add-at-eol", |
| 168 |
"vi_r" => "vi-replace-char", |
| 169 |
"vi_R" => "vi-replace-mode", |
| 170 |
"vi_s" => "vi-substitute-char", |
| 171 |
"vi_S" => "vi-substitute-line", |
| 172 |
#"vi_o" |
| 173 |
#"vi_O" |
| 174 |
"vi_c" => "vi-change", |
| 175 |
"vi_C" => "vi-change-to-eol", |
| 176 |
|
| 177 |
#"vi_y" => "vi-yank-direction", |
| 178 |
#"vi_Y" => "vi-yank-to-eol", |
| 179 |
#"vi_u" => "vi-undo", |
| 180 |
#"vi_p" => "vi-paste-at", |
| 181 |
#"vi_P" => "vi-paste-before", |
| 182 |
"vi_x" => "vi-delete-char-backward", |
| 183 |
"vi_X" => "vi-delete-char-forward", |
| 184 |
"vi_d" => "vi-delete", |
| 185 |
|
| 186 |
# -------- OTHER COMMANDS |
| 187 |
|
| 188 |
"vi_m" => "vi-mark", |
| 189 |
|
| 190 |
}; |
| 191 |
|
| 192 |
my $mappings = { |
| 193 |
"anykey" => [ \&anykey ], |
| 194 |
"backward-char" => [ \&backward_char ], |
| 195 |
"forward-char" => [ \&forward_char ], |
| 196 |
"delete-char-backward" => [ \&delete_char_backward ], |
| 197 |
"kill-line" => [ \&kill_line ], |
| 198 |
"newline" => [ \&newline ], |
| 199 |
"redraw" => [ \&fix_inputline ], |
| 200 |
"beginning-of-line" => [ \&beginning_of_line ], |
| 201 |
"end-of-line" => [ \&end_of_line ], |
| 202 |
"delete-word-backward" => [ \&delete_word_backward ], |
| 203 |
|
| 204 |
"complete-word" => [ \&complete_word ], |
| 205 |
#"expand-line" => [ \&expand_line ], |
| 206 |
|
| 207 |
# ----------------------------------------------------------- vi mappings |
| 208 |
"vi-backward-char" => [ \&vi_backward_char ], |
| 209 |
"vi-forward-char" => [ \&vi_forward_char ], |
| 210 |
"vi-forward-word" => [ \&vi_forward_word ], |
| 211 |
"vi-forward-whole-word" => [ \&vi_forward_whole_word ], |
| 212 |
"vi-beginning-word" => [ \&vi_beginning_word ], |
| 213 |
"vi-beginning-whole-word" => [ \&vi_beginning_whole_word ], |
| 214 |
"vi-end-of-line" => [ \&vi_eol ], |
| 215 |
"vi-beginning-of-line" => [ \&vi_bol ], |
| 216 |
"vi-forward-charto" => [ \&vi_forward_charto ], |
| 217 |
"vi-forward-charat" => [ \&vi_forward_charat ], |
| 218 |
"vi-backward-charto" => [ \&vi_backward_charto ], |
| 219 |
"vi-backward-charat" => [ \&vi_backward_charat ], |
| 220 |
|
| 221 |
"vi-end-word" => [ \&vi_end_word ], |
| 222 |
"vi-end-whole-word" => [ \&vi_end_whole_word ], |
| 223 |
"vi-insert" => [ \&vi_insert ], |
| 224 |
"vi-insert-at-bol" => [ \&vi_insert_at_bol ],, |
| 225 |
"vi-add" => [ \&vi_add ], |
| 226 |
"vi-add-at-eol" => [ \&vi_add_at_eol ], |
| 227 |
|
| 228 |
"vi-delete-char-backward" => [ \&vi_delete_char_backward ], |
| 229 |
"vi-delete-char-forward" => [ \&vi_delete_char_forward ], |
| 230 |
"vi-delete" => [ \&vi_delete ], |
| 231 |
|
| 232 |
}; |
| 233 |
|
| 234 |
$self->{"bindings"} = $bindings; |
| 235 |
$self->{"mappings"} = $mappings; |
| 236 |
return $self; |
| 237 |
} |
| 238 |
|
| 239 |
sub DESTROY { |
| 240 |
my $self = shift; |
| 241 |
$self->real_out("\n"); |
| 242 |
ReadMode 0; |
| 243 |
} |
| 244 |
|
| 245 |
=pod |
| 246 |
|
| 247 |
=item $sh->do_one_loop() |
| 248 |
|
| 249 |
Does... one... loop. Makes a pass at grabbing input and processing it. For |
| 250 |
speedy pasts, this loops until there are no characters left to read. |
| 251 |
It will handle event processing, etc. |
| 252 |
|
| 253 |
=cut |
| 254 |
|
| 255 |
# Nonblocking readline |
| 256 |
sub do_one_loop ($) { |
| 257 |
my $self = shift; |
| 258 |
my $text; |
| 259 |
my $char; |
| 260 |
|
| 261 |
# Select for .01 |
| 262 |
# |
| 263 |
if ($self->{"select"}->can_read(.01)) { |
| 264 |
my $bytes = sysread(STDIN, $text, 4096); |
| 265 |
for (my $i = 0; $i < length($text); $i++) { |
| 266 |
$char = substr($text,$i,1); |
| 267 |
$self->handle_key($char); |
| 268 |
} |
| 269 |
} |
| 270 |
|
| 271 |
} |
| 272 |
|
| 273 |
=pod |
| 274 |
|
| 275 |
=item handle_key($key) |
| 276 |
|
| 277 |
Handle a single character input. This is not a "key press" so much as doing all |
| 278 |
the necessary things to handle key presses. |
| 279 |
|
| 280 |
=cut |
| 281 |
|
| 282 |
sub handle_key($$) { |
| 283 |
my $self = shift; |
| 284 |
my $char = shift; |
| 285 |
|
| 286 |
my $line = $self->{"input_line"} || ""; |
| 287 |
my $pos = $self->{"input_position"} || 0; |
| 288 |
|
| 289 |
if (defined($self->{"input_slurper"})) { |
| 290 |
&{$self->{"input_slurper"}}($self, $char); |
| 291 |
return; |
| 292 |
} |
| 293 |
|
| 294 |
if ($self->{"escape"}) { |
| 295 |
$self->{"escape_string"} .= $char; |
| 296 |
if ($self->{"escape_expect_ansi"}) { |
| 297 |
$self->{"escape_expect_ansi"} = 0 if ($char =~ m/[a-zA-Z~]/); |
| 298 |
} |
| 299 |
|
| 300 |
$self->{"escape_expect_ansi"} = 1 if ($char eq '['); |
| 301 |
$self->{"escape"} = 0 unless ($self->{"escape_expect_ansi"}); |
| 302 |
|
| 303 |
unless ($self->{"escape_expect_ansi"}) { |
| 304 |
my $estring = $self->{"escape_string"}; |
| 305 |
|
| 306 |
$self->{"escape_string"} = undef; |
| 307 |
$self->execute_binding("\e".$estring); |
| 308 |
} else { |
| 309 |
return; |
| 310 |
} |
| 311 |
} elsif ($char eq "\e") { # Trap escapes, they're speshul. |
| 312 |
if ($self->{"vi_mode"}) { |
| 313 |
if ($self->{"mode"} eq 'insert') { |
| 314 |
$self->{"input_position"}-- if ($self->{"input_position"} > 1); |
| 315 |
$self->{"mode"} = "command"; |
| 316 |
} |
| 317 |
} else { |
| 318 |
$self->{"escape"} = 1; |
| 319 |
$self->{"escape_string"} = undef; |
| 320 |
return; |
| 321 |
} |
| 322 |
} elsif ((ord($char) < 32) || (ord($char) > 126)) { # Control character |
| 323 |
$self->execute_binding($char); |
| 324 |
} elsif ((defined($char)) && (ord($char) >= 32)) { |
| 325 |
if (defined($self->{"mode"}) && $self->{"mode"} eq "command") { |
| 326 |
if ($char =~ m/[0-9]/) { |
| 327 |
$self->{"vi_count"} .= $char; |
| 328 |
} else { |
| 329 |
my $cmdwait = defined($self->{"vi_command_waiting"}); |
| 330 |
|
| 331 |
$self->{"vi_count"} ||= 1; |
| 332 |
while ($self->{"vi_count"} > 0) { |
| 333 |
$self->execute_binding("vi_$char"); |
| 334 |
$self->{"vi_count"}--; |
| 335 |
} |
| 336 |
if ($cmdwait) { |
| 337 |
&{$self->{"vi_command_waiting"}}($self, 1); |
| 338 |
$self->{"input_position"} = $self->{"vi_input_position"}; |
| 339 |
delete $self->{"vi_command_waiting"}; |
| 340 |
} |
| 341 |
} |
| 342 |
} else { |
| 343 |
if (defined($self->{"bindings"}->{"$char"})) { |
| 344 |
$self->execute_binding($char); |
| 345 |
} else { |
| 346 |
# Insert the character in our string, wherever we are. |
| 347 |
#substr($line, $pos, 0) = $char; |
| 348 |
#$self->{"input_position"}++; |
| 349 |
$self->insert_at_cursor($char); |
| 350 |
} |
| 351 |
} |
| 352 |
|
| 353 |
# If we just did a tab completion, kill the state. |
| 354 |
delete($self->{"completion"}) if (defined($self->{"completion"})); |
| 355 |
$self->fix_inputline(); |
| 356 |
} |
| 357 |
|
| 358 |
# This is sometimes a nice feature to have... |
| 359 |
# Press the any key!!! |
| 360 |
$self->{"lastchar"} = $char; |
| 361 |
$self->execute_binding("ANYKEY"); |
| 362 |
|
| 363 |
#$self->fix_inputline(); |
| 364 |
} |
| 365 |
|
| 366 |
=pod |
| 367 |
|
| 368 |
=item execute_binding(raw_key) |
| 369 |
|
| 370 |
Guess what this does? Ok I'll explain anyway... It takes a key and prettifies |
| 371 |
it, then checks the known key bindings for a mapping and checks if that mapping |
| 372 |
is a coderef (a function reference). If it is, it'll call that function. If |
| 373 |
not, it'll do nothing. If it finds a binding for which there is no mapped |
| 374 |
function, it'll tell you that it is an unimplemented function. |
| 375 |
|
| 376 |
=cut |
| 377 |
|
| 378 |
sub execute_binding ($$) { |
| 379 |
my $self = shift; |
| 380 |
my $str = shift; |
| 381 |
my $key = $self->prettify_key($str); |
| 382 |
|
| 383 |
#$self->out("Key: $key"); |
| 384 |
|
| 385 |
my $bindings = $self->{"bindings"}; |
| 386 |
my $mappings = $self->{"mappings"}; |
| 387 |
|
| 388 |
if (defined($bindings->{$key})) { |
| 389 |
|
| 390 |
# Check if we have stored completion state and the next binding is |
| 391 |
# not complete-word. If it isn't, then kill the completion state. |
| 392 |
if (defined($self->{"completion"}) && $key ne 'ANYKEY' && |
| 393 |
$bindings->{$key} ne 'complete-word') { |
| 394 |
delete($self->{"completion"}); |
| 395 |
} |
| 396 |
|
| 397 |
if (ref($mappings->{$bindings->{$key}}) =~ m/(CODE|ARRAY)/) { |
| 398 |
|
| 399 |
# This is a hack, passing $self instead of doing: |
| 400 |
# $self->function, becuase I don't want to do an eval. |
| 401 |
|
| 402 |
if ($1 eq 'ARRAY') { |
| 403 |
map { &{$_}($self) } @{$mappings->{$bindings->{$key}}}; |
| 404 |
} else { |
| 405 |
&{$mappings->{$bindings->{$key}}}($self); |
| 406 |
} |
| 407 |
|
| 408 |
} else { |
| 409 |
$self->error("Unimplemented function, " . $bindings->{$key}); |
| 410 |
} |
| 411 |
} |
| 412 |
} |
| 413 |
|
| 414 |
=pod |
| 415 |
|
| 416 |
=item prettify_key(raw_key) |
| 417 |
|
| 418 |
This happy function lets me turn raw input into something less ugly. It turns |
| 419 |
control keys into their equivalent ^X form. It does some other things to turn |
| 420 |
the key into something more readable |
| 421 |
|
| 422 |
=cut |
| 423 |
|
| 424 |
sub prettify_key ($$) { |
| 425 |
my $self = shift; |
| 426 |
my $key = shift; |
| 427 |
|
| 428 |
# Return ^X for control characters, like CTRL+A... |
| 429 |
if (length($key) == 1) { # One-character keycombos should only be ctrl keys |
| 430 |
if (ord($key) <= 26) { # Control codes, another check anyway... |
| 431 |
return "^" . chr(65 + ord($key) - 1); |
| 432 |
} |
| 433 |
if (ord($key) == 127) { # Speshul backspace key |
| 434 |
return "^?"; |
| 435 |
} |
| 436 |
if (ord($key) < 32) { |
| 437 |
return "^" . (split("", "\]_^"))[ord($key) - 28]; |
| 438 |
} |
| 439 |
} |
| 440 |
|
| 441 |
# Return ESC-X for escape shenanigans, like ESC-W |
| 442 |
if (length($key) == 2) { |
| 443 |
my ($p, $k) = split("", $key); |
| 444 |
if ($p eq "\e") { # This should always be an escape, but.. check anyway |
| 445 |
return "ESC-" . $k; |
| 446 |
} |
| 447 |
} |
| 448 |
|
| 449 |
# Ok, so it's not ^X or ESC-X, it's gotta be some ansi funk or a normal char. |
| 450 |
return $KEY_CONSTANTS{$key} || $key; |
| 451 |
} |
| 452 |
|
| 453 |
=pod |
| 454 |
|
| 455 |
=item real_out($string) |
| 456 |
|
| 457 |
This function allows you to bypass any sort of evil shenanigans regarding output fudging. All this does is 'print @_;' |
| 458 |
|
| 459 |
Don't use this unless you know what you're doing. |
| 460 |
|
| 461 |
=cut |
| 462 |
|
| 463 |
sub real_out { |
| 464 |
my $self = shift; |
| 465 |
print @_; |
| 466 |
} |
| 467 |
|
| 468 |
sub out ($;$) { |
| 469 |
my $self = shift; |
| 470 |
$self->real_out("\r\e[2K", @_, "\n"); |
| 471 |
$self->fix_inputline(); |
| 472 |
} |
| 473 |
|
| 474 |
sub error ($$) { |
| 475 |
my $self = shift; |
| 476 |
$self->real_out("\r\e[2K"); |
| 477 |
print STDERR "*> ", @_, "\n"; |
| 478 |
$self->fix_inputline(); |
| 479 |
} |
| 480 |
|
| 481 |
=pod |
| 482 |
|
| 483 |
=item fix_inputline |
| 484 |
|
| 485 |
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. |
| 486 |
|
| 487 |
=cut |
| 488 |
|
| 489 |
sub fix_inputline ($) { |
| 490 |
my $self = shift; |
| 491 |
|
| 492 |
print "\r\e[2K"; |
| 493 |
|
| 494 |
if ($self->{"echo"} == 0) { |
| 495 |
#print "Echo is off...\n"; |
| 496 |
print $self->{"input_prompt"}; |
| 497 |
return; |
| 498 |
} |
| 499 |
|
| 500 |
# If we're before the beginning of the terminal line, shuffle over! |
| 501 |
if ($self->{"input_position"} - $self->{"leftcol"} <= 0) { |
| 502 |
$self->{"leftcol"} -= 30; |
| 503 |
$self->{"leftcol"} = 0 if ($self->{"leftcol"} < 0); |
| 504 |
} |
| 505 |
|
| 506 |
# If we're past the end of the terminal line, shuffle back! |
| 507 |
# length = input_position - leftcol + input_prompt - leftcol |
| 508 |
my $pl = length($self->{"input_prompt"}) - $self->{"leftcol"}; |
| 509 |
$pl = 0 if ($pl < 0); |
| 510 |
if ($self->{"input_position"} - $self->{"leftcol"} + $pl > $self->{"termcols"}) { |
| 511 |
$self->{"leftcol"} += 30; |
| 512 |
} |
| 513 |
|
| 514 |
# Can se show the whole line? If so, do it! |
| 515 |
if (length($self->{"input_line"}) + length($self->{"input_prompt"}) < $self->{"termcols"}) { |
| 516 |
$self->{"leftcol"} = 0; |
| 517 |
} |
| 518 |
|
| 519 |
# only print as much as we can in this one line. |
| 520 |
my $prompt = $self->{"input_prompt"}; |
| 521 |
my $offset = 0; |
| 522 |
if ($self->{"leftcol"} <= length($self->{"input_prompt"})) { |
| 523 |
print substr($prompt,$self->{"leftcol"}); |
| 524 |
$offset = length(substr($prompt,$self->{"leftcol"})); |
| 525 |
} |
| 526 |
|
| 527 |
print substr($self->{"input_line"}, $self->{"leftcol"}, $self->{"termcols"} - $offset); |
| 528 |
print "\r"; |
| 529 |
print "\e[" . ($self->{"input_position"} - $self->{"leftcol"} + $offset) . |
| 530 |
"C" if (($self->{"input_position"} + $offset) > 0); |
| 531 |
STDOUT->flush(); |
| 532 |
} |
| 533 |
|
| 534 |
sub newline { |
| 535 |
my $self = shift; |
| 536 |
# Process the input line. |
| 537 |
|
| 538 |
if ($self->{"supress_newline_echo"}) { |
| 539 |
# Clear the line |
| 540 |
$self->real_out("\e[2K"); |
| 541 |
} else { |
| 542 |
$self->real_out("\n"); |
| 543 |
} |
| 544 |
|
| 545 |
my $line = $self->{"input_line"}; |
| 546 |
|
| 547 |
$self->{"input_line"} = ""; |
| 548 |
$self->{"input_position"} = 0; |
| 549 |
$self->{"leftcol"} = 0; |
| 550 |
|
| 551 |
$self->callback("readline", $line); |
| 552 |
#if (ref($self->{"readline_callback"}) eq 'CODE') { |
| 553 |
#&{$self->{"readline_callback"}}($line); |
| 554 |
#} |
| 555 |
|
| 556 |
$self->fix_inputline(); |
| 557 |
} |
| 558 |
|
| 559 |
sub kill_line { |
| 560 |
my $self = shift; |
| 561 |
|
| 562 |
# Ask for more data perhaps... |
| 563 |
$self->callback("fardelete");# if (length($self->{"input_line"}) == 0); |
| 564 |
|
| 565 |
$self->{"input_line"} = ""; |
| 566 |
$self->{"input_position"} = 0; |
| 567 |
$self->{"leftcol"} = 0; |
| 568 |
|
| 569 |
#real_out("\r\e[2K"); |
| 570 |
|
| 571 |
$self->fix_inputline(); |
| 572 |
|
| 573 |
return 0; |
| 574 |
} |
| 575 |
|
| 576 |
sub forward_char { |
| 577 |
my $self = shift; |
| 578 |
if ($self->{"input_position"} < length($self->{"input_line"})) { |
| 579 |
$self->{"input_position"}++; |
| 580 |
$self->real_out("\e[C"); |
| 581 |
} |
| 582 |
} |
| 583 |
|
| 584 |
sub backward_char { |
| 585 |
my $self = shift; |
| 586 |
if ($self->{"input_position"} > 0) { |
| 587 |
$self->{"input_position"}--; |
| 588 |
$self->real_out("\e[D"); |
| 589 |
} |
| 590 |
} |
| 591 |
|
| 592 |
sub delete_char_backward { |
| 593 |
my $self = shift; |
| 594 |
|
| 595 |
$self->callback("fardelete") if (length($self->{"input_line"}) == 0); |
| 596 |
|
| 597 |
if ($self->{"input_position"} > 0) { |
| 598 |
substr($self->{"input_line"}, $self->{"input_position"} - 1, 1) = ''; |
| 599 |
$self->{"input_position"}--; |
| 600 |
$self->fix_inputline(); |
| 601 |
} |
| 602 |
} |
| 603 |
|
| 604 |
sub beginning_of_line { |
| 605 |
my $self = shift; |
| 606 |
$self->{"input_position"} = 0; |
| 607 |
$self->{"leftcol"} = 0; |
| 608 |
$self->fix_inputline(); |
| 609 |
} |
| 610 |
|
| 611 |
sub end_of_line { |
| 612 |
my $self = shift; |
| 613 |
$self->{"input_position"} = length($self->{"input_line"}); |
| 614 |
$self->fix_inputline(); |
| 615 |
} |
| 616 |
|
| 617 |
sub delete_word_backward { |
| 618 |
my $self = shift; |
| 619 |
my $pos = $self->{"input_position"}; |
| 620 |
my $line = $self->{"input_line"}; |
| 621 |
#my $regex = '[A-Za-z0-9]'; |
| 622 |
my $regex = '\S'; |
| 623 |
my $bword; |
| 624 |
|
| 625 |
$self->callback("fardelete") if (length($self->{"input_line"}) == 0); |
| 626 |
$bword = $self->find_word_bound($line, $pos, WORD_BEGINNING | WORD_REGEX, $regex); |
| 627 |
|
| 628 |
#$self->error("Testing $bword $pos"); |
| 629 |
# Delete whatever word we just found. |
| 630 |
substr($line, $bword, $pos - $bword) = ''; |
| 631 |
|
| 632 |
# Update stuff... |
| 633 |
$self->{"input_line"} = $line; |
| 634 |
$self->{"input_position"} -= ($pos - $bword); |
| 635 |
|
| 636 |
$self->fix_inputline(); |
| 637 |
} |
| 638 |
|
| 639 |
sub vi_backward_char { |
| 640 |
my $self = shift; |
| 641 |
|
| 642 |
$self->backward_char(); |
| 643 |
$self->{"vi_done"} = 1; |
| 644 |
} |
| 645 |
|
| 646 |
sub vi_forward_char { |
| 647 |
my $self = shift; |
| 648 |
|
| 649 |
$self->forward_char(); |
| 650 |
$self->{"vi_done"} = 1; |
| 651 |
} |
| 652 |
|
| 653 |
sub vi_forward_word { |
| 654 |
my $self = shift; |
| 655 |
my $pos = $self->{"input_position"}; |
| 656 |
my $line = $self->{"input_line"}; |
| 657 |
my $bword = $pos; |
| 658 |
my $BITS = WORD_NEXT; |
| 659 |
my $regex = shift; |
| 660 |
|
| 661 |
$BITS |= WORD_REGEX if (defined($regex)); |
| 662 |
$bword = $self->find_word_bound($line, $pos, $BITS, $regex); |
| 663 |
|
| 664 |
$self->{"input_position"} = $bword; |
| 665 |
|
| 666 |
$self->{"vi_done"}; |
| 667 |
} |
| 668 |
|
| 669 |
sub vi_forward_whole_word { |
| 670 |
my $self = shift; |
| 671 |
$self->vi_forward_word('\S'); |
| 672 |
$self->{"vi_done"} = 1; |
| 673 |
} |
| 674 |
|
| 675 |
sub vi_beginning_word { |
| 676 |
my $self = shift; |
| 677 |
my $pos = $self->{"input_position"}; |
| 678 |
my $line = $self->{"input_line"}; |
| 679 |
my $bword = $pos; |
| 680 |
my $BITS = WORD_BEGINNING; |
| 681 |
my $regex = shift; |
| 682 |
|
| 683 |
$BITS |= WORD_REGEX if (defined($regex)); |
| 684 |
$bword = $self->find_word_bound($line, $pos, $BITS, $regex); |
| 685 |
|
| 686 |
$self->{"input_position"} = $bword; |
| 687 |
|
| 688 |
$self->{"vi_done"}; |
| 689 |
} |
| 690 |
|
| 691 |
sub vi_beginning_whole_word { |
| 692 |
my $self = shift; |
| 693 |
$self->vi_beginning_word('\S'); |
| 694 |
$self->{"vi_done"} = 1; |
| 695 |
} |
| 696 |
|
| 697 |
sub vi_end_word { |
| 698 |
my $self = shift; |
| 699 |
my $pos = $self->{"input_position"}; |
| 700 |
my $line = $self->{"input_line"}; |
| 701 |
my $bword = $pos; |
| 702 |
my $BITS = WORD_END; |
| 703 |
my $regex = shift; |
| 704 |
|
| 705 |
$BITS |= WORD_REGEX if (defined($regex)); |
| 706 |
$bword = $self->find_word_bound($line, $pos, $BITS, $regex); |
| 707 |
|
| 708 |
$self->{"input_position"} = $bword; |
| 709 |
|
| 710 |
$self->{"vi_done"}; |
| 711 |
} |
| 712 |
|
| 713 |
sub vi_end_whole_word { |
| 714 |
my $self = shift; |
| 715 |
$self->vi_end_word('\S'); |
| 716 |
$self->{"vi_done"} = 1; |
| 717 |
} |
| 718 |
|
| 719 |
sub vi_forward_charto { |
| 720 |
my $self = shift; |
| 721 |
|
| 722 |
# We need to wait for another character input... |
| 723 |
$self->{"jumpchardir"} = JUMP_CHARTO; |
| 724 |
$self->{"input_slurper"} = \&vi_jumpchar; |
| 725 |
} |
| 726 |
|
| 727 |
sub vi_forward_charat { |
| 728 |
my $self = shift; |
| 729 |
|
| 730 |
# We need to wait for another character input... |
| 731 |
$self->{"jumpchardir"} = JUMP_CHAR; |
| 732 |
$self->{"input_slurper"} = \&vi_jumpchar; |
| 733 |
} |
| 734 |
|
| 735 |
sub vi_backward_charto { |
| 736 |
my $self = shift; |
| 737 |
|
| 738 |
$self->{"jumpchardir"} = JUMP_BACKCHARTO; |
| 739 |
$self->{"input_slurper"} = \&vi_jumpchar; |
| 740 |
} |
| 741 |
|
| 742 |
sub vi_backward_charat { |
| 743 |
my $self = shift; |
| 744 |
|
| 745 |
$self->{"jumpchardir"} = JUMP_BACKCHAR; |
| 746 |
$self->{"input_slurper"} = \&vi_jumpchar; |
| 747 |
} |
| 748 |
|
| 749 |
sub vi_jumpchar { |
| 750 |
my $self = shift; |
| 751 |
my $char = shift; |
| 752 |
my $pos = $self->{"input_position"}; |
| 753 |
my $line = $self->{"input_line"}; |
| 754 |
my $newpos; |
| 755 |
my $mod = 0; |
| 756 |
|
| 757 |
delete $self->{"input_slurper"}; |
| 758 |
|
| 759 |
$mod = ($self->{"jumpchardir"} & JUMP_CHARTO ? 1 : -1); |
| 760 |
|
| 761 |
if ($mod == 1) { |
| 762 |
#$self->out("F: $line / $pos / " . $line =~ m/^(.{$pos}[^$char]*)$char/); |
| 763 |
#$self->out(" " . " " x ($pos) . "^ / $1"); |
| 764 |
$pos = length($1) if (defined($1)); |
| 765 |
} else { |
| 766 |
#$self->out("B: $line / $pos / " . $line =~ m/$char([^$char]*.{$pos})$/); |
| 767 |
#$self->out(" " . " " x ($pos - 1) . "^ / $1"); |
| 768 |
$pos = length($line) - length($1) if (defined($1)); |
| 769 |
} |
| 770 |
$self->{"input_position"} = $pos; |
| 771 |
|
| 772 |
$self->fix_inputline(); |
| 773 |
} |
| 774 |
|
| 775 |
sub vi_bol { |
| 776 |
my $self = shift; |
| 777 |
$self->{"input_position"} = 0; |
| 778 |
$self->{"vi_done"} = 1; |
| 779 |
} |
| 780 |
|
| 781 |
sub vi_eol { |
| 782 |
my $self = shift; |
| 783 |
$self->{"input_position"} = length($self->{"input_line"}); |
| 784 |
$self->{"vi_done"} = 1; |
| 785 |
} |
| 786 |
sub vi_insert { |
| 787 |
my $self = shift; |
| 788 |
|
| 789 |
$self->{"mode"} = "insert"; |
| 790 |
$self->{"vi_done"} = 1; |
| 791 |
} |
| 792 |
|
| 793 |
sub vi_insert_at_bol { |
| 794 |
my $self = shift; |
| 795 |
|
| 796 |
$self->vi_bol(); |
| 797 |
$self->vi_insert(); |
| 798 |
$self->{"vi_done"} = 1; |
| 799 |
} |
| 800 |
|
| 801 |
sub vi_add { |
| 802 |
my $self = shift; |
| 803 |
|
| 804 |
$self->{"input_position"}++ if ($self->{"input_position"} < length($self->{"input_line"})); |
| 805 |
|
| 806 |
$self->vi_insert(); |
| 807 |
$self->{"vi_done"} = 1; |
| 808 |
} |
| 809 |
|
| 810 |
sub vi_add_at_eol { |
| 811 |
my $self = shift; |
| 812 |
|
| 813 |
$self->vi_eol(); |
| 814 |
$self->vi_add(); |
| 815 |
$self->{"vi_done"} = 1; |
| 816 |
} |
| 817 |
|
| 818 |
sub vi_delete_char_forward { |
| 819 |
my $self = shift; |
| 820 |
unless ($self->{"input_position"} == 0) { |
| 821 |
substr($self->{"input_line"}, $self->{"input_position"} - 1, 1) = ''; |
| 822 |
$self->{"input_position"}--; |
| 823 |
} |
| 824 |
} |
| 825 |
|
| 826 |
sub vi_delete_char_backward { |
| 827 |
my $self = shift; |
| 828 |
|
| 829 |
$self->callback("fardelete") if (length($self->{"input_line"}) == 0); |
| 830 |
|
| 831 |
substr($self->{"input_line"}, $self->{"input_position"}, 1) = ''; |
| 832 |
$self->{"input_position"}-- if ($self->{"input_position"} == length($self->{"input_line"}) && $self->{"input_position"} > 0); |
| 833 |
} |
| 834 |
|
| 835 |
sub vi_delete { |
| 836 |
my $self = shift; |
| 837 |
my $exec = shift || 0; |
| 838 |
|
| 839 |
if ($exec == 1) { |
| 840 |
my ($start, $end); |
| 841 |
|
| 842 |
$self->callback("fardelete") if (length($self->{"input_line"}) == 0); |
| 843 |
|
| 844 |
if ($self->{"input_position"} < $self->{"vi_input_position"}) { |
| 845 |
$start = $self->{"input_position"}; |
| 846 |
$end = $self->{"vi_input_position"}; |
| 847 |
} else { |
| 848 |
$start = $self->{"vi_input_position"}; |
| 849 |
$end = $self->{"input_position"}; |
| 850 |
} |
| 851 |
substr($self->{"input_line"}, $start, ($end - $start)) = ''; |
| 852 |
} else { |
| 853 |
# Mark such that we remember what command we're doing at the time |
| 854 |
# and set ourselves as the call back for the end of the next valid |
| 855 |
# command. soo.... something like: |
| 856 |
$self->{"vi_command_waiting"} = \&vi_delete; |
| 857 |
$self->{"vi_input_position"} = $self->{"input_position"}; |
| 858 |
} |
| 859 |
|
| 860 |
} |
| 861 |
|
| 862 |
=pod |
| 863 |
|
| 864 |
=item $sh->complete_word |
| 865 |
|
| 866 |
This is called whenever the complete-word binding is triggered. See the |
| 867 |
COMPLETION section below for how to write your own completion function. |
| 868 |
|
| 869 |
=cut |
| 870 |
|
| 871 |
sub complete_word { |
| 872 |
my $self = shift; |
| 873 |
my $pos = $self->{"input_position"}; |
| 874 |
my $line = $self->{"input_line"}; |
| 875 |
my $regex = "[A-Za-z0-9]"; |
| 876 |
my $bword; |
| 877 |
my $complete; |
| 878 |
|
| 879 |
if (ref($self->{"completion_function"}) eq 'CODE') { |
| 880 |
my @matches; |
| 881 |
|
| 882 |
# Maintain some sort of state here if this is the first time we've |
| 883 |
# hit complete_word() for this "scenario." What I mean is, we need to track |
| 884 |
# whether or not this user is hitting tab once or twice (or more) in the |
| 885 |
# same position. |
| 886 |
RECHECK: |
| 887 |
if (!defined($self->{"completion"})) { |
| 888 |
$bword = $self->find_word_bound($line, $pos, WORD_BEGINNING | WORD_REGEX, '\S'); |
| 889 |
$complete = substr($line,$bword,$pos - $bword); |
| 890 |
#$self->out("Complete: $complete"); |
| 891 |
#$self->out(length($line) . " / $bword / $pos"); |
| 892 |
|
| 893 |
# Make sure we can actually do this ? |
| 894 |
|
| 895 |
#$self->out("First time completing $complete"); |
| 896 |
$self->{"completion"} = { |
| 897 |
"index" => 0, |
| 898 |
"original" => $complete, |
| 899 |
"pos" => $pos, |
| 900 |
"bword" => $bword, |
| 901 |
"line" => $line, |
| 902 |
"endpos" => $pos, |
| 903 |
}; |
| 904 |
} else { |
| 905 |
$bword = $self->{"completion"}->{"bword"}; |
| 906 |
#$self->out(length($line) . " / $bword / $pos"); |
| 907 |
$complete = substr($line,$bword,$pos - $bword); |
| 908 |
} |
| 909 |
|
| 910 |
# If we don't have any matches to check against... |
| 911 |
unless (defined($self->{"completion"}->{"matches"})) { |
| 912 |
@matches = |
| 913 |
&{$self->{"completion_function"}}($line, $bword, $pos, $complete); |
| 914 |
@{$self->{"completion"}->{"matches"}} = @matches; |
| 915 |
} else { |
| 916 |
@matches = @{$self->{"completion"}->{"matches"}}; |
| 917 |
} |
| 918 |
|
| 919 |
my $match = $matches[$self->{"completion"}->{"index"}]; |
| 920 |
|
| 921 |
return unless (defined($match)); |
| 922 |
|
| 923 |
$self->{"completion"}->{"index"}++; |
| 924 |
$self->{"completion"}->{"index"} = 0 if ($self->{"completion"}->{"index"} == scalar(@matches)); |
| 925 |
|
| 926 |
#$self->out(length($line) . " / $bword / $pos"); |
| 927 |
substr($line, $bword, $pos - $bword) = $match . " "; |
| 928 |
|
| 929 |
$self->{"completion"}->{"endpos"} = $pos; |
| 930 |
|
| 931 |
$pos = $bword + length($match) + 1; |
| 932 |
$self->{"input_position"} = $pos; |
| 933 |
$self->{"input_line"} = $line; |
| 934 |
|
| 935 |
$self->fix_inputline(); |
| 936 |
} |
| 937 |
} |
| 938 |
|
| 939 |
sub anykey { |
| 940 |
my $self = shift; |
| 941 |
|
| 942 |
$self->callback("anykey"); |
| 943 |
#if (ref($self->{"anykey_callback"}) eq 'CODE') { |
| 944 |
#&{$self->{"anykey_callback"}}; |
| 945 |
#} |
| 946 |
} |
| 947 |
|
| 948 |
|
| 949 |
|
| 950 |
#------------------------------------------------------------------------------ |
| 951 |
# Useful functions to set prompt and other things. |
| 952 |
|
| 953 |
=pod |
| 954 |
|
| 955 |
=item $sh->prompt([$prompt]) |
| 956 |
|
| 957 |
Get or set the prompt |
| 958 |
|
| 959 |
=cut |
| 960 |
|
| 961 |
sub prompt ($;$) { |
| 962 |
my $self = shift; |
| 963 |
|
| 964 |
if (@_) { |
| 965 |
$self->{"input_prompt"} = shift; |
| 966 |
$self->fix_inputline(); |
| 967 |
} |
| 968 |
return $self->{"input_prompt"}; |
| 969 |
} |
| 970 |
|
| 971 |
sub echo ($;$) { |
| 972 |
my $self = shift; |
| 973 |
|
| 974 |
if (@_) { |
| 975 |
$self->{"echo"} = shift; |
| 976 |
} |
| 977 |
return $self->{"echo"}; |
| 978 |
} |
| 979 |
|
| 980 |
# -------------------------------------------------------------------- |
| 981 |
# Helper functions |
| 982 |
# |
| 983 |
|
| 984 |
sub callback($$;$) { |
| 985 |
my $self = shift; |
| 986 |
my $callback = shift() . "_callback"; |
| 987 |
if (ref($self->{$callback}) eq 'CODE') { |
| 988 |
$self->{$callback}->(@_); |
| 989 |
} |
| 990 |
} |
| 991 |
|
| 992 |
# Go from a position and find the beginning of the word we're on. |
| 993 |
sub find_word_bound ($$$$;$) { |
| 994 |
my ($self, $line, $pos, $opts, $rx) = @_; |
| 995 |
my $nrx; |
| 996 |
$rx = '\\w' if (!($opts & WORD_REGEX)); |
| 997 |
|
| 998 |
# Mod? This is either -1 or +1 depending on if we're looking behind or |
| 999 |
# if we're looking ahead. |
| 1000 |
my $mod = ($opts & WORD_BEGINNING) ? -1 : 1; |
| 1001 |
$nrx = qr/[^$rx]/; |
| 1002 |
$rx = qr/[$rx]/; |
| 1003 |
|
| 1004 |
if ($opts & WORD_NEXT) { |
| 1005 |
#$regex = qr/^.{$pos}(.+?)(?<!$regex)$regex/; |
| 1006 |
$rx = qr/^.{$pos}(.+?)(?<!$rx)$rx/; |
| 1007 |
} elsif ($opts & WORD_BEGINNING) { |
| 1008 |
#$regex = qr/($regex+[^$regex]*)(?<=^.{$pos})/; |
| 1009 |
$rx = qr/($rx+$nrx*)(?<=^.{$pos})/; |
| 1010 |
} elsif ($opts & WORD_END) { |
| 1011 |
#$regex = qr/^.{$pos}(.+?)$regex(?:[^$regex]|$)/; |
| 1012 |
$rx = qr/^.{$pos}(.+?)$rx(?:$nrx|$)/; |
| 1013 |
} |
| 1014 |
|
| 1015 |
#$self->out("$rx"); |
| 1016 |
|
| 1017 |
if ($line =~ $rx) { |
| 1018 |
$pos += length($1) * $mod; |
| 1019 |
} else { |
| 1020 |
$pos = ($mod == 1 ? length($line) : 0); |
| 1021 |
} |
| 1022 |
|
| 1023 |
return $pos; |
| 1024 |
} |
| 1025 |
|
| 1026 |
# ----------------------------------------------------------------------------- |
| 1027 |
# Functions people might call on us... |
| 1028 |
# |
| 1029 |
|
| 1030 |
sub insert_at_cursor($$) { |
| 1031 |
my $self = shift; |
| 1032 |
my $string = shift; |
| 1033 |
|
| 1034 |
substr($self->{"input_line"}, $self->{"input_position"}, 0) = $string; |
| 1035 |
$self->{"input_position"} += length($string) |
| 1036 |
} |
| 1037 |
|
| 1038 |
=pod |
| 1039 |
|
| 1040 |
=back |
| 1041 |
|
| 1042 |
=cut |
| 1043 |
|
| 1044 |
1; |
Parent Directory
| 
Revision Log