revbank/revbank

#!/usr/bin/env perl

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 FindBin qw($RealBin);
use lib "$RealBin/lib";
use RevBank::Plugins;
use RevBank::Global;
use RevBank::Messages;
use RevBank::Cart;

our $VERSION = "5.0.0";
our %HELP1 = (
    "abort" => "Abort the current transaction",
);

my @words;  # input
my $retry;  # reason (text)
my @retry;  # (@accepted, $rejected, [@trailing])

my $one_off = 0;

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
    for my $term (@terms) {
        $term =
              $term eq ';' ? "\0SEPARATOR"
            : $term =~ s/\\(.)/$1/gr;
    }
    return @terms;
}

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 = 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;
}

$| = 1;

my $readline = Term::ReadLine->new($0);

my $select = IO::Select->new;
$select->add(\*STDIN);

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;
        s/\0SEPARATOR/;/ for @accepted, @rejected, @trailing;
        $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;

call_hooks("startup");

OUTER: for (;;) {
    if (not @words or $words[0] eq "\0SEPARATOR") {
        call_hooks("cart_changed", $cart) if $cart->changed;
        print "\n";
    }

    my $prompt = "";
    my @plugins = RevBank::Plugins->new;
    my $method = "command";

    sub abort {
        print @_, " " if @_;
        @words = ();
        @retry = ();
        call_hooks "abort", $cart, \@_;
        $cart->empty;
        RevBank::FileIO::release_all_locks;
        { no warnings; redo OUTER; }
    }

    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 $input = prompt $prompt, \@plugins, \@completions;

            call_hooks "input", $cart, $input, $split_input;

            length $input or redo PROMPT;

            if ($split_input) {
                @words = 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 ($rv, @rvargs) = 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 ($@) {
                    call_hooks "plugin_fail", $plugin->id, "$method: $@";
                    abort;
                }
                if (not defined $rv) {
                    call_hooks "plugin_fail", $plugin->id, "$method: 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;
                    call_hooks "plugin_fail", $plugin->id, "$method: No method supplied"
                        if not ref $method;

                    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, "$method: "
                        . "Only 'command' should ever return NEXT.";
                    abort;
                }
                call_hooks "plugin_fail", $plugin->id, "$method: 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.