revbank/revbank

#!/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 = "9.0.0";

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.