Move prompt code to RevBank::Prompt
Wanted to move split_input() to a package for unit testing, thought I'd move prompt() too since the main executable has become messy, and this would be a good first step in resolving that.
This commit is contained in:
Juerd Waalboer
parent
0cd178d950
commit
0b2ea27117
2 changed files with 171 additions and 142 deletions
135
lib/RevBank/Prompt.pm
Executable file
135
lib/RevBank/Prompt.pm
Executable file
|
|
@ -0,0 +1,135 @@
|
||||||
|
package RevBank::Prompt;
|
||||||
|
|
||||||
|
use v5.32;
|
||||||
|
use warnings;
|
||||||
|
use feature qw(signatures isa);
|
||||||
|
no warnings "experimental::signatures";
|
||||||
|
|
||||||
|
use IO::Select;
|
||||||
|
use List::Util qw(uniq);
|
||||||
|
use Term::ReadLine;
|
||||||
|
require Term::ReadLine::Gnu; # The other one sucks.
|
||||||
|
|
||||||
|
use RevBank::Global;
|
||||||
|
|
||||||
|
my %escapes = (a => "\a", r => "\r", n => "\n", t => "\t", 0 => "\0");
|
||||||
|
my %unescapes = reverse %escapes;
|
||||||
|
my $unescapes = join "", keys %unescapes;
|
||||||
|
|
||||||
|
sub split_input($input) {
|
||||||
|
$input =~ s/\s+$//;
|
||||||
|
|
||||||
|
my @terms;
|
||||||
|
my $pos = 0;
|
||||||
|
|
||||||
|
while (
|
||||||
|
$input =~ m[
|
||||||
|
\G \s*+
|
||||||
|
(?| (') ( (?: \\. | [^\\'] )*+ ) ' (?=\s|;|$)
|
||||||
|
| (") ( (?: \\. | [^\\"] )*+ ) " (?=\s|;|$)
|
||||||
|
| () ( (?: \\. | [^\\;'"\s] )++ ) (?=\s|;|$)
|
||||||
|
| () (;)
|
||||||
|
)
|
||||||
|
]xg
|
||||||
|
) {
|
||||||
|
push @terms, (
|
||||||
|
(not $1) && $2 eq ";" ? "\0SEPARATOR"
|
||||||
|
: (not $1) && $2 eq "abort" ? "\0ABORT"
|
||||||
|
: $1 && $2 eq "abort" ? "abort"
|
||||||
|
: $2
|
||||||
|
);
|
||||||
|
$pos = pos($input) || 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
# End of string not reached
|
||||||
|
return \$pos if $pos < length($input);
|
||||||
|
|
||||||
|
# End of string reached
|
||||||
|
s[\\(.)]{ $escapes{$1} // $1 }ge for @terms;
|
||||||
|
return @terms;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub reconstruct($word) {
|
||||||
|
$word =~ s/([;'"\\])/\\$1/g;
|
||||||
|
$word =~ s/\0SEPARATOR/;/;
|
||||||
|
$word =~ s/([$unescapes])/\\$unescapes{$1}/g;
|
||||||
|
$word = "'$word'" if $word =~ /\s/ or $word eq "abort";
|
||||||
|
return $word;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub prompt($prompt, $completions = [], $default = "", $pos = 0, $cart = undef, $plugins = []) {
|
||||||
|
state $readline = Term::ReadLine->new($0);
|
||||||
|
|
||||||
|
my $select = IO::Select->new;
|
||||||
|
$select->add(\*STDIN);
|
||||||
|
|
||||||
|
if ($prompt) {
|
||||||
|
$prompt =~ s/$/:/ if $prompt !~ /[?>](?:\x01[^\x02]*\x02)?$/;
|
||||||
|
$prompt .= " ";
|
||||||
|
} else {
|
||||||
|
# \x01...\x02 = zero width markers for readline
|
||||||
|
# \e[...m = ansi escape (32 = green, 1 = bright)
|
||||||
|
$prompt = "\x01\e[32;1m\x02>\x01\e[0m\x02 ";
|
||||||
|
}
|
||||||
|
|
||||||
|
my @matches;
|
||||||
|
$readline->Attribs->{completion_entry_function} = sub {
|
||||||
|
my ($word, $state) = @_;
|
||||||
|
return undef if $word eq "";
|
||||||
|
@matches = grep /^\Q$word\E/i, @$completions if $state == 0;
|
||||||
|
return shift @matches;
|
||||||
|
};
|
||||||
|
|
||||||
|
# Term::ReadLine::Gnu (1.37) does not expose rl_completion_case_fold,
|
||||||
|
# but it can be assigned through the corresponding .inputrc command.
|
||||||
|
$readline->parse_and_bind("set completion-ignore-case on");
|
||||||
|
|
||||||
|
my $done;
|
||||||
|
my $input;
|
||||||
|
|
||||||
|
$readline->callback_handler_install($prompt, sub {
|
||||||
|
$done = 1;
|
||||||
|
$input = shift;
|
||||||
|
$readline->callback_handler_remove;
|
||||||
|
});
|
||||||
|
|
||||||
|
$readline->insert_text($default);
|
||||||
|
$readline->Attribs->{point} = $pos;
|
||||||
|
$readline->redisplay();
|
||||||
|
|
||||||
|
my $begin = my $time = time;
|
||||||
|
while (not $done) {
|
||||||
|
if ($::ABORT_HACK) {
|
||||||
|
# Global variable that a signal handling plugin can set.
|
||||||
|
# Do not use, but "return ABORT" instead.
|
||||||
|
my $reason = $::ABORT_HACK;
|
||||||
|
$::ABORT_HACK = 0;
|
||||||
|
main::abort($reason);
|
||||||
|
}
|
||||||
|
if ($select->can_read(.05)) {
|
||||||
|
$readline->callback_read_char;
|
||||||
|
$begin = $time;
|
||||||
|
}
|
||||||
|
if (time > $time) {
|
||||||
|
$time = time;
|
||||||
|
call_hooks(
|
||||||
|
"prompt_idle",
|
||||||
|
$cart,
|
||||||
|
(@$plugins > 1 ? undef : $plugins->[0]), # >1 plugin = main loop
|
||||||
|
$time - $begin,
|
||||||
|
$readline,
|
||||||
|
);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
print "\e[0m";
|
||||||
|
defined $input or return;
|
||||||
|
$readline->addhistory($input);
|
||||||
|
|
||||||
|
$input =~ s/^\s+//; # trim leading whitespace
|
||||||
|
$input =~ s/\s+$//; # trim trailing whitespace
|
||||||
|
|
||||||
|
return $input;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
178
revbank
178
revbank
|
|
@ -16,6 +16,7 @@ use RevBank::Plugins;
|
||||||
use RevBank::Global;
|
use RevBank::Global;
|
||||||
use RevBank::Messages;
|
use RevBank::Messages;
|
||||||
use RevBank::Cart;
|
use RevBank::Cart;
|
||||||
|
use RevBank::Prompt;
|
||||||
|
|
||||||
our $VERSION = "5.1.0";
|
our $VERSION = "5.1.0";
|
||||||
our %HELP1 = (
|
our %HELP1 = (
|
||||||
|
|
@ -23,54 +24,16 @@ our %HELP1 = (
|
||||||
);
|
);
|
||||||
|
|
||||||
my @words; # input
|
my @words; # input
|
||||||
my $retry; # reason (text)
|
|
||||||
my @retry; # (@accepted, $rejected, [@trailing])
|
|
||||||
|
|
||||||
my $one_off = 0;
|
my $one_off = 0;
|
||||||
|
|
||||||
my %escapes = (a => "\a", r => "\r", n => "\n", t => "\t", 0 => "\0");
|
|
||||||
my %unescapes = reverse %escapes;
|
|
||||||
|
|
||||||
sub split_input($input) {
|
|
||||||
$input =~ s/\s+$//;
|
|
||||||
|
|
||||||
my @terms;
|
|
||||||
my $pos = 0;
|
|
||||||
|
|
||||||
while (
|
|
||||||
$input =~ m[
|
|
||||||
\G \s*+
|
|
||||||
(?| (') ( (?: \\. | [^\\'] )*+ ) ' (?=\s|;|$)
|
|
||||||
| (") ( (?: \\. | [^\\"] )*+ ) " (?=\s|;|$)
|
|
||||||
| () ( (?: \\. | [^\\;'"\s] )++ ) (?=\s|;|$)
|
|
||||||
| () (;)
|
|
||||||
)
|
|
||||||
]xg
|
|
||||||
) {
|
|
||||||
push @terms, (
|
|
||||||
(not $1) && $2 eq ";" ? "\0SEPARATOR"
|
|
||||||
: (not $1) && $2 eq "abort" ? "\0ABORT"
|
|
||||||
: $1 && $2 eq "abort" ? "abort"
|
|
||||||
: $2
|
|
||||||
);
|
|
||||||
$pos = pos($input) || 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
# End of string not reached
|
|
||||||
return \$pos if $pos < length($input);
|
|
||||||
|
|
||||||
# End of string reached
|
|
||||||
s[\\(.)]{ $escapes{$1} // $1 }ge for @terms;
|
|
||||||
return @terms;
|
|
||||||
}
|
|
||||||
|
|
||||||
if (@ARGV) {
|
if (@ARGV) {
|
||||||
# Non-interactive like in sh: -c command_string
|
# Non-interactive like in sh: -c command_string
|
||||||
@ARGV >= 1 and $ARGV[0] eq '-c' or die "$0 has no switches, except -c.";
|
@ARGV >= 1 and $ARGV[0] eq '-c' or die "$0 has no switches, except -c.";
|
||||||
|
|
||||||
$one_off = 1;
|
$one_off = 1;
|
||||||
|
|
||||||
@words = split_input($ARGV[1]);
|
@words = RevBank::Prompt::split_input($ARGV[1]);
|
||||||
@words and not ref $words[0] or die "Syntax error.\n";
|
@words and not ref $words[0] or die "Syntax error.\n";
|
||||||
push @words, @ARGV[3 .. $#ARGV] if @ARGV > 3;
|
push @words, @ARGV[3 .. $#ARGV] if @ARGV > 3;
|
||||||
push @words, "help" if not @words;
|
push @words, "help" if not @words;
|
||||||
|
|
@ -78,113 +41,15 @@ if (@ARGV) {
|
||||||
|
|
||||||
$| = 1;
|
$| = 1;
|
||||||
|
|
||||||
my $readline = Term::ReadLine->new($0);
|
|
||||||
|
|
||||||
my $select = IO::Select->new;
|
|
||||||
$select->add(\*STDIN);
|
|
||||||
|
|
||||||
my $cart = RevBank::Cart->new;
|
my $cart = RevBank::Cart->new;
|
||||||
|
|
||||||
sub prompt($prompt, $plugins, $completions) {
|
|
||||||
if ($prompt) {
|
|
||||||
$prompt =~ s/$/:/ if $prompt !~ /[?>](?:\x01[^\x02]*\x02)?$/;
|
|
||||||
$prompt .= " ";
|
|
||||||
} else {
|
|
||||||
# \x01...\x02 = zero width markers for readline
|
|
||||||
# \e[...m = ansi escape (32 = green, 1 = bright)
|
|
||||||
$prompt = "\x01\e[32;1m\x02>\x01\e[0m\x02 ";
|
|
||||||
}
|
|
||||||
|
|
||||||
my @matches;
|
|
||||||
$readline->Attribs->{completion_entry_function} = sub {
|
|
||||||
my ($word, $state) = @_;
|
|
||||||
return undef if $word eq "";
|
|
||||||
@matches = grep /^\Q$word\E/i, @$completions if $state == 0;
|
|
||||||
return shift @matches;
|
|
||||||
};
|
|
||||||
|
|
||||||
# Term::ReadLine::Gnu (1.37) does not expose rl_completion_case_fold,
|
|
||||||
# but it can be assigned through the corresponding .inputrc command.
|
|
||||||
$readline->parse_and_bind("set completion-ignore-case on");
|
|
||||||
|
|
||||||
my $done;
|
|
||||||
my $input;
|
|
||||||
|
|
||||||
print "$retry\n" if $retry;
|
|
||||||
$readline->callback_handler_install($prompt, sub {
|
|
||||||
$done = 1;
|
|
||||||
$input = shift;
|
|
||||||
$readline->callback_handler_remove;
|
|
||||||
});
|
|
||||||
|
|
||||||
if ($retry) {
|
|
||||||
my $word_based = ref($retry[-1]);
|
|
||||||
my @trailing = $word_based ? @{ pop @retry } : ();
|
|
||||||
my @rejected = pop @retry;
|
|
||||||
my @accepted = @retry;
|
|
||||||
|
|
||||||
if ($word_based) {
|
|
||||||
# Reconstruct quotes and escapes
|
|
||||||
for (@accepted, @rejected, @trailing) {
|
|
||||||
s/([;'"\\])/\\$1/g;
|
|
||||||
s/\0SEPARATOR/;/;
|
|
||||||
|
|
||||||
my $unescapes = join "", keys %unescapes;
|
|
||||||
s/([$unescapes])/\\$unescapes{$1}/g;
|
|
||||||
$_ = "'$_'" if /\s/ or $_ eq "abort";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
$readline->insert_text(
|
|
||||||
$word_based
|
|
||||||
? join(" ", @accepted, @rejected, @trailing)
|
|
||||||
: join("", @accepted, @rejected)
|
|
||||||
);
|
|
||||||
$readline->Attribs->{point} = @accepted ? 1 + length "@accepted" : 0;
|
|
||||||
@retry = ();
|
|
||||||
$retry = 0;
|
|
||||||
}
|
|
||||||
$readline->redisplay();
|
|
||||||
|
|
||||||
my $begin = my $time = time;
|
|
||||||
while (not $done) {
|
|
||||||
if ($::ABORT_HACK) {
|
|
||||||
# Global variable that a signal handling plugin can set.
|
|
||||||
# Do not use, but "return ABORT" instead.
|
|
||||||
my $reason = $::ABORT_HACK;
|
|
||||||
$::ABORT_HACK = 0;
|
|
||||||
abort($reason);
|
|
||||||
}
|
|
||||||
if ($select->can_read(.05)) {
|
|
||||||
$readline->callback_read_char;
|
|
||||||
$begin = $time;
|
|
||||||
}
|
|
||||||
if (time > $time) {
|
|
||||||
$time = time;
|
|
||||||
call_hooks(
|
|
||||||
"prompt_idle",
|
|
||||||
$cart,
|
|
||||||
(@$plugins > 1 ? undef : $plugins->[0]), # >1 plugin = main loop
|
|
||||||
$time - $begin,
|
|
||||||
$readline,
|
|
||||||
);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
print "\e[0m";
|
|
||||||
defined $input or return;
|
|
||||||
$readline->addhistory($input);
|
|
||||||
|
|
||||||
$input =~ s/^\s+//; # trim leading whitespace
|
|
||||||
$input =~ s/\s+$//; # trim trailing whitespace
|
|
||||||
|
|
||||||
return $input;
|
|
||||||
}
|
|
||||||
|
|
||||||
RevBank::Plugins->load;
|
RevBank::Plugins->load;
|
||||||
|
|
||||||
call_hooks("startup");
|
call_hooks("startup");
|
||||||
|
|
||||||
|
my $retry; # reason (text)
|
||||||
|
my @retry; # (@accepted, $rejected, [@trailing])
|
||||||
|
|
||||||
OUTER: for (;;) {
|
OUTER: for (;;) {
|
||||||
if (not @words or $words[0] eq "\0SEPARATOR") {
|
if (not @words or $words[0] eq "\0SEPARATOR") {
|
||||||
call_hooks("cart_changed", $cart) if $cart->changed;
|
call_hooks("cart_changed", $cart) if $cart->changed;
|
||||||
|
|
@ -218,14 +83,43 @@ OUTER: for (;;) {
|
||||||
my $split_input = !ref($method) && $method eq 'command';
|
my $split_input = !ref($method) && $method eq 'command';
|
||||||
|
|
||||||
my @completions = uniq 'abort', map $_->Tab($method), @plugins;
|
my @completions = uniq 'abort', map $_->Tab($method), @plugins;
|
||||||
my $input = prompt $prompt, \@plugins, \@completions;
|
|
||||||
|
my $default = "";
|
||||||
|
my $pos = 0;
|
||||||
|
|
||||||
|
if ($retry) {
|
||||||
|
print "$retry\n";
|
||||||
|
|
||||||
|
my $word_based = ref($retry[-1]);
|
||||||
|
my @trailing = $word_based ? @{ pop @retry } : ();
|
||||||
|
my @rejected = pop @retry;
|
||||||
|
my @accepted = @retry;
|
||||||
|
|
||||||
|
if ($word_based) {
|
||||||
|
for (@accepted, @rejected, @trailing) {
|
||||||
|
$_ = RevBank::Prompt::reconstruct($_);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
$default = $word_based
|
||||||
|
? join(" ", @accepted, @rejected, @trailing)
|
||||||
|
: join("", @accepted, @rejected);
|
||||||
|
$pos = @accepted ? 1 + length "@accepted" : 0;
|
||||||
|
|
||||||
|
@retry = ();
|
||||||
|
$retry = 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
my $input = RevBank::Prompt::prompt(
|
||||||
|
$prompt, \@completions, $default, $pos, $cart, \@plugins
|
||||||
|
);
|
||||||
|
|
||||||
call_hooks "input", $cart, $input, $split_input;
|
call_hooks "input", $cart, $input, $split_input;
|
||||||
|
|
||||||
length $input or redo PROMPT;
|
length $input or redo PROMPT;
|
||||||
|
|
||||||
if ($split_input) {
|
if ($split_input) {
|
||||||
@words = split_input($input);
|
@words = RevBank::Prompt::split_input($input);
|
||||||
if (ref $words[0]) {
|
if (ref $words[0]) {
|
||||||
my $pos = ${ $words[0] };
|
my $pos = ${ $words[0] };
|
||||||
@retry = @words = ();
|
@retry = @words = ();
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue