324 lines
10 KiB
Perl
Executable file
324 lines
10 KiB
Perl
Executable file
#!/usr/bin/env perl
|
|
|
|
use v5.32;
|
|
use warnings;
|
|
use experimental 'isa'; # stable since v5.36
|
|
use experimental 'signatures'; # stable since v5.36
|
|
|
|
use List::Util qw(uniq);
|
|
use Sub::Util qw(subname);
|
|
use POSIX qw(ttyname);
|
|
|
|
use FindBin qw($RealBin);
|
|
use lib "$RealBin/lib";
|
|
use RevBank::Plugins;
|
|
use RevBank::Global;
|
|
use RevBank::Messages;
|
|
use RevBank::Cart;
|
|
use RevBank::Prompt;
|
|
|
|
our $VERSION = "8.3.1";
|
|
|
|
our %HELP1 = (
|
|
"abort" => "Abort the current transaction",
|
|
);
|
|
|
|
my @words; # input
|
|
|
|
my $one_off = 0;
|
|
|
|
if (@ARGV) {
|
|
# Non-interactive like in sh: -c command_string
|
|
@ARGV >= 1 and $ARGV[0] eq '-c' or die "$0 has no switches, except -c.";
|
|
|
|
$one_off = 1;
|
|
|
|
@words = RevBank::Prompt::split_input($ARGV[1]);
|
|
@words and not ref $words[0] or die "Syntax error.\n";
|
|
push @words, @ARGV[3 .. $#ARGV] if @ARGV > 3;
|
|
push @words, "help" if not @words;
|
|
} elsif (not ttyname fileno STDIN) {
|
|
warn "\e[31;1mNo controlling terminal, things will be borken!\n";
|
|
warn "Use ssh -t (or RequestTTY in .ssh/config) for interactive sessions.\e[m\n";
|
|
}
|
|
|
|
|
|
$| = 1;
|
|
|
|
my $cart = RevBank::Cart->new;
|
|
|
|
RevBank::Plugins->load;
|
|
|
|
call_hooks("startup");
|
|
|
|
my $retry; # reason (text)
|
|
my @retry; # (@accepted, $rejected, [@trailing])
|
|
|
|
my $prompt;
|
|
my @plugins;
|
|
my $method;
|
|
|
|
sub abort {
|
|
@words = ();
|
|
@retry = ();
|
|
|
|
my $is_interrupt = @_ && $_[0] eq "^C";
|
|
print "\n" if $is_interrupt;
|
|
|
|
if ($is_interrupt and $cart->size and ref $method) {
|
|
call_hooks "interrupt", $cart, \@_;
|
|
call_hooks "cart_changed", $cart; # XXX ugly; refactor redisplay with instructions
|
|
print "Pressing ^C again will also abort.\n";
|
|
} else {
|
|
print @_, " " unless $is_interrupt;
|
|
call_hooks "abort", $cart, \@_;
|
|
$cart->empty;
|
|
RevBank::FileIO::release_all_locks;
|
|
}
|
|
no warnings qw(exiting);
|
|
redo OUTER;
|
|
}
|
|
|
|
OUTER: for (;;) {
|
|
if (not @words) {
|
|
call_hooks("cart_changed", $cart) if $cart->changed;
|
|
print "\n";
|
|
}
|
|
|
|
$prompt = "";
|
|
@plugins = RevBank::Plugins->new;
|
|
$method = "command";
|
|
|
|
PROMPT: {
|
|
if (not @words) {
|
|
if ($one_off) {
|
|
exit if $one_off++ > 1;
|
|
|
|
abort "Incomplete command." if $cart->size;
|
|
exit;
|
|
}
|
|
|
|
call_hooks "prompt", $cart, $prompt;
|
|
my $split_input = !ref($method) && $method eq 'command';
|
|
|
|
my @completions = uniq 'abort', map $_->Tab($method), @plugins;
|
|
|
|
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($_);
|
|
}
|
|
}
|
|
|
|
my $sep = $word_based ? " " : "";
|
|
$default = join($sep, @accepted, @rejected, @trailing);
|
|
$pos = @accepted ? length "@accepted$sep" : 0;
|
|
|
|
@retry = ();
|
|
$retry = 0;
|
|
}
|
|
|
|
my $input = RevBank::Prompt::prompt(
|
|
$prompt, \@completions, $default, $pos, $cart, \@plugins
|
|
);
|
|
if (not defined $input) {
|
|
exit if not ttyname fileno STDIN; # Controlling terminal gone
|
|
}
|
|
|
|
call_hooks "input", $cart, $input, $split_input;
|
|
|
|
length $input or redo PROMPT;
|
|
|
|
if ($split_input) {
|
|
@words = RevBank::Prompt::split_input($input);
|
|
if (ref $words[0]) {
|
|
my $pos = ${ $words[0] };
|
|
|
|
@retry = @words = ();
|
|
$retry = "Syntax error.";
|
|
|
|
if ($input =~ /['"]/) {
|
|
$retry .= " (Quotes must match and (only) be at both ends of a term.)";
|
|
if (($input =~ tr/'//) == 1 and $input !~ /"/) {
|
|
$retry .= "\nDid you mean: " . $input =~ s/'/\\'/r;
|
|
}
|
|
}
|
|
|
|
push @retry, substr($input, 0, $pos) if $pos > 0;
|
|
push @retry, substr($input, $pos);
|
|
redo PROMPT;
|
|
}
|
|
} else {
|
|
$input = "\0ABORT" if $input =~ /^\s*abort\s*$/;
|
|
@words = $input;
|
|
}
|
|
}
|
|
|
|
WORD: for (;;) {
|
|
redo PROMPT if not @words;
|
|
abort if grep $_ eq "\0ABORT", @words;
|
|
|
|
my $origword = my $word = shift @words;
|
|
my @allwords = ($origword);
|
|
|
|
next WORD if $word eq "\0SEPARATOR";
|
|
|
|
abort if $method eq "command" and $word eq "abort"; # here, even when quoted
|
|
|
|
|
|
push @retry, $word;
|
|
|
|
ALL_PLUGINS: { PLUGIN: for my $plugin (@plugins) {
|
|
|
|
$cart->prohibit_checkout(
|
|
@words && $words[0] ne "\0SEPARATOR",
|
|
"unexpected trailing input (use ';' to separate transactions)."
|
|
);
|
|
|
|
my $coderef = ref($method) ? $method : $plugin->can($method);
|
|
my ($mname) = $coderef
|
|
? (subname($coderef) eq "__ANON__" ? "" : subname($coderef) . ": ")
|
|
: (ref($method) ? "" : "$method: ");
|
|
|
|
my ($rv, @rvargs) =
|
|
|
|
($word =~ /[^\x20-\x7f]/ and $method eq 'command' || !$plugin->AllChars($method))
|
|
|
|
? (REJECT, "Unexpected control character in input.")
|
|
: eval { $plugin->$method($cart, $word) };
|
|
|
|
if ($@ isa 'RevBank::Cart::CheckoutProhibited') {
|
|
@words or die "Internal inconsistency"; # other cause than trailing input
|
|
|
|
push @retry, shift @words; # reject next word (first of trailing)
|
|
push @retry, [@words];
|
|
@words = ();
|
|
$retry = $@->reason;
|
|
redo OUTER;
|
|
} elsif ($@ isa 'RevBank::Exception::RejectInput') {
|
|
$rv = REJECT;
|
|
@rvargs = $@->reason;
|
|
} elsif ($@) {
|
|
call_hooks "plugin_fail", $plugin->id, "$mname$@";
|
|
abort;
|
|
}
|
|
|
|
if (not defined $rv) {
|
|
call_hooks "plugin_fail", $plugin->id, $mname . "No return code";
|
|
abort;
|
|
}
|
|
if (not ref $rv) {
|
|
abort "Incomplete command." if $one_off and not @words;
|
|
|
|
if (@words and $words[0] eq "\0SEPARATOR") {
|
|
push @retry, shift @words; # reject the ';'
|
|
push @retry, [@words];
|
|
@words = ();
|
|
$retry = "Incomplete command (expected: $rv)";
|
|
redo OUTER;
|
|
}
|
|
|
|
$prompt = $rv;
|
|
@plugins = $plugin;
|
|
($method) = @rvargs;
|
|
if (not ref $method) {
|
|
call_hooks "plugin_fail", $plugin->id, $mname . "No method supplied";
|
|
abort;
|
|
}
|
|
|
|
next WORD;
|
|
}
|
|
if ($rv == ABORT) {
|
|
abort(@rvargs);
|
|
}
|
|
if ($rv == REDO) {
|
|
$word = $rvargs[0];
|
|
call_hooks "redo", $plugin->id, $origword, $word;
|
|
push @allwords, $word;
|
|
|
|
redo ALL_PLUGINS;
|
|
}
|
|
if ($rv == REJECT) {
|
|
my ($reason) = @rvargs;
|
|
if (@words) {
|
|
call_hooks "retry", $plugin->id, $reason, @words ? 1 : 0;
|
|
push @retry, [@words];
|
|
@words = ();
|
|
$retry = $reason;
|
|
redo OUTER;
|
|
} else {
|
|
call_hooks "reject", $plugin->id, $reason, @words ? 1 : 0;
|
|
@retry = ();
|
|
redo PROMPT;
|
|
}
|
|
}
|
|
if ($rv == ACCEPT) {
|
|
if ($method ne 'command' and @words and $words[0] ne "\0SEPARATOR") {
|
|
@retry = (); # remove what's already done
|
|
push @retry, shift @words; # reject first
|
|
push @retry, [@words];
|
|
@words = ();
|
|
$retry = "Confirm trailing input to execute. (Hint: use ';' after command arguments.)";
|
|
redo OUTER;
|
|
}
|
|
@retry = ();
|
|
next OUTER;
|
|
}
|
|
if ($rv == NEXT) {
|
|
next PLUGIN if $method eq 'command';
|
|
call_hooks "plugin_fail", $plugin->id, $mname
|
|
. "Only 'command' should ever return NEXT.";
|
|
abort;
|
|
}
|
|
call_hooks "plugin_fail", $plugin->id, $mname . "Invalid return value";
|
|
abort;
|
|
}
|
|
call_hooks "invalid_input", $cart, $origword, $word, \@allwords;
|
|
@retry = ();
|
|
abort if @words;
|
|
redo OUTER;
|
|
} }
|
|
}
|
|
}
|
|
|
|
=head1 NAME
|
|
|
|
revbank - Banking for hackerspace visitors
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Maybe I'll write some documentation, but not now.
|
|
|
|
Shell-like invocation with C<-c> is supported, sort of, but it has to be a
|
|
complete command. Currently, multiple commands are supported on the command
|
|
line (space separated), but that's an unintended feature...
|
|
|
|
=head1 PLUGINS
|
|
|
|
Refer to L<RevBank::Plugins> for documentation about writing plugins.
|
|
|
|
Plugins themselves may have some documentation in the respective plugin files.
|
|
|
|
Note that plugins that begin with C<revspace_> are revspace specific hacks, and
|
|
were not written with reusability in mind. They will probably not work for your
|
|
setup.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Juerd Waalboer <#####@juerd.nl>
|
|
|
|
=head1 LICENSE
|
|
|
|
Pick your favorite OSI license.
|
|
|
|
|