revbank/revbank

#!/usr/bin/env perl

use v5.32;
use warnings;
use feature qw(signatures);
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 = "4.2.4";
our %HELP1 = (
    "abort" => "Abort the current transaction",
);

my @words;
my $retry;
my @retry;

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 = split " ", $ARGV[1];
    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 @trailing = @{ pop @retry };
        my @rejected = pop @retry;
        my @accepted = @retry;
        $readline->insert_text(join " ", @accepted, @rejected, @trailing);
        $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) {
        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;

            @words = ($split_input ? split(" ", $input) : $input);
        }

        WORD: for (;;) {
            redo PROMPT if not @words;
            abort if grep $_ eq 'abort', @words;

            my $origword = my $word = shift @words;
            my @allwords = ($origword);
            push @retry, $word;

            ALL_PLUGINS: { PLUGIN: for my $plugin (@plugins) {
                my ($rv, @rvargs) = eval { $plugin->$method($cart, $word) };
                if ($@) {
                    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) {
                    $prompt = $rv;
                    @plugins = $plugin;
                    ($method) = @rvargs;
                    call_hooks "plugin_fail", $plugin->id, "$method: No method supplied"
                        if not ref $method;

                    abort "Incomplete command." if $one_off and not @words;
                    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;
                    #abort if @words;
                    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) {
                    @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.