Cleanup: use subroutine signatures, remove deprecated methods.
The signatures feature has been "experimental" since Perl 5.20 (May 2014), but expected to stay. After 8 years I'm ready to take the risk :) Have added Perl v5.28 (June 2018) as the minimum requirement, even though the current revbank should work with 5.20, to see if this bothers any users. Perl v5.28 is in Debian "buster", which is now oldstable.
This commit is contained in:
Juerd Waalboer
parent
1661661ffd
commit
eed0db7897
45 changed files with 233 additions and 444 deletions
|
|
@ -1,7 +1,10 @@
|
|||
package RevBank::Amount;
|
||||
|
||||
use v5.28;
|
||||
use warnings;
|
||||
use experimental qw(signatures);
|
||||
use feature qw(signatures);
|
||||
no warnings qw(experimental::signatures);
|
||||
|
||||
use Carp qw(carp croak);
|
||||
use Scalar::Util;
|
||||
use POSIX qw(lround);
|
||||
|
|
|
|||
|
|
@ -1,50 +1,41 @@
|
|||
package RevBank::Cart;
|
||||
use strict;
|
||||
|
||||
use v5.28;
|
||||
use warnings;
|
||||
use feature qw(signatures);
|
||||
no warnings qw(experimental::signatures);
|
||||
|
||||
use Carp ();
|
||||
use List::Util ();
|
||||
use RevBank::Global;
|
||||
use RevBank::Cart::Entry;
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
sub new($class) {
|
||||
return bless { entries => [] }, $class;
|
||||
}
|
||||
|
||||
sub add_entry {
|
||||
my ($self, $entry) = @_;
|
||||
|
||||
$self->_call_old_hooks("add", $entry);
|
||||
sub add_entry($self, $entry) {
|
||||
RevBank::Plugins::call_hooks("add_entry", $self, $entry);
|
||||
|
||||
push @{ $self->{entries} }, $entry;
|
||||
$self->{changed}++;
|
||||
$self->_call_old_hooks("added", $entry);
|
||||
RevBank::Plugins::call_hooks("added_entry", $self, $entry);
|
||||
|
||||
return $entry;
|
||||
}
|
||||
|
||||
sub add {
|
||||
# Deprecated interface: ->add($user, ...)
|
||||
if (defined $_[3] and not ref $_[3]) {
|
||||
return shift->old_add(@_);
|
||||
}
|
||||
sub add($self, $amount, $description, $data = {}) {
|
||||
Carp::croak "Unitialized amount; possibly a deprecated call style (\$cart->add(undef, ...))"
|
||||
if not defined $amount;
|
||||
Carp::croak "Non-hash data argument; possibly a deprecated call style (\$cart->add(\$user, ...)"
|
||||
if @_ == 4 and not ref $data;
|
||||
Carp::croak "Missing description; possibly a deprecated call style (\$cart->add(\$entry); use add_entry instead)"
|
||||
if not defined $description;
|
||||
|
||||
# ->add($entry)
|
||||
if (@_ == 2) {
|
||||
my ($self, $entry) = @_;
|
||||
return $self->add_entry($entry);
|
||||
}
|
||||
|
||||
# ->add($amount, ...)
|
||||
my ($self, $amount, $description, $data) = @_;
|
||||
return $self->add_entry(RevBank::Cart::Entry->new($amount, $description, $data));
|
||||
}
|
||||
|
||||
sub delete {
|
||||
Carp::croak("\$cart->delete(\$user, \$index) is no longer supported") if @_ > 2;
|
||||
|
||||
my ($self, $entry) = @_;
|
||||
sub delete($self, $entry) {
|
||||
my $entries = $self->{entries};
|
||||
|
||||
my $oldnum = @$entries;
|
||||
|
|
@ -54,27 +45,20 @@ sub delete {
|
|||
return $oldnum - @$entries;
|
||||
}
|
||||
|
||||
sub empty {
|
||||
my ($self) = @_;
|
||||
|
||||
sub empty($self) {
|
||||
$self->{entries} = [];
|
||||
$self->{changed}++;
|
||||
}
|
||||
|
||||
sub display {
|
||||
my ($self, $prefix) = @_;
|
||||
$prefix //= "";
|
||||
sub display($self, $prefix = "") {
|
||||
say "$prefix$_" for map $_->as_printable, @{ $self->{entries} };
|
||||
}
|
||||
|
||||
sub size {
|
||||
my ($self) = @_;
|
||||
sub size($self) {
|
||||
return scalar @{ $self->{entries} };
|
||||
}
|
||||
|
||||
sub checkout {
|
||||
my ($self, $user) = @_;
|
||||
|
||||
sub checkout($self, $user) {
|
||||
if ($self->entries('refuse_checkout')) {
|
||||
warn "Refusing to finalize deficient transaction.\n";
|
||||
$self->display;
|
||||
|
|
@ -108,17 +92,13 @@ sub checkout {
|
|||
return 1;
|
||||
}
|
||||
|
||||
sub entries {
|
||||
my ($self, $attribute) = @_;
|
||||
|
||||
sub entries($self, $attribute = undef) {
|
||||
my @entries = @{ $self->{entries} };
|
||||
return grep $_->has_attribute($attribute), @entries if defined $attribute;
|
||||
return @entries;
|
||||
}
|
||||
|
||||
sub changed {
|
||||
my ($self) = @_;
|
||||
|
||||
sub changed($self) {
|
||||
my $changed = 0;
|
||||
for my $entry ($self->entries('changed')) {
|
||||
$entry->attribute('changed', undef);
|
||||
|
|
@ -128,78 +108,8 @@ sub changed {
|
|||
return $changed;
|
||||
}
|
||||
|
||||
sub sum {
|
||||
my ($self) = @_;
|
||||
sub sum($self) {
|
||||
return List::Util::sum(map $_->{amount} * $_->quantity, @{ $self->{entries} });
|
||||
}
|
||||
|
||||
|
||||
### Old stuff, to be deleted in a future version:
|
||||
|
||||
sub _call_old_hooks {
|
||||
my ($self, $hook, $entry) = @_;
|
||||
|
||||
my $data = $entry->{attributes};
|
||||
|
||||
for (1 .. $entry->quantity) {
|
||||
for ($entry, $entry->contras) {
|
||||
my $item = {
|
||||
%$data,
|
||||
amount => $_->{amount},
|
||||
description => $_->{description},
|
||||
};
|
||||
|
||||
RevBank::Plugins::call_hooks($hook, $self, $_->{user}, $item);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub as_strings {
|
||||
my ($self) = @_;
|
||||
Carp::carp("Plugin uses deprecated \$cart->as_strings");
|
||||
|
||||
return map $_->as_loggable, @{ $self->{entries} };
|
||||
}
|
||||
|
||||
sub is_multi_user {
|
||||
Carp::carp("\$cart->is_multi_user is no longer supported, ignoring");
|
||||
}
|
||||
|
||||
sub select_items {
|
||||
my ($self, $key) = @_;
|
||||
Carp::carp("Plugin uses deprecated \$cart->select_items");
|
||||
|
||||
my @matches;
|
||||
for my $entry (@{ $self->{entries} }) {
|
||||
my %attributes = %{ $entry->{attributes} };
|
||||
for (1 .. $entry->quantity) {
|
||||
for my $item ($entry, $entry->contras) {
|
||||
push @matches, { %attributes, %$item }
|
||||
if @_ == 1 # No key or match given: match everything
|
||||
or @_ == 2 and $entry->has_attribute($key) # Just a key
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return @matches;
|
||||
}
|
||||
|
||||
sub old_add {
|
||||
my ($self, $user, $amount, $description, $data) = @_;
|
||||
|
||||
Carp::carp("Plugin uses deprecated old-style call to \$cart->add");
|
||||
|
||||
$data->{COMPATIBILITY} = 1;
|
||||
|
||||
my $entry = RevBank::Cart::Entry->new(
|
||||
defined $user ? 0 : $amount,
|
||||
$description,
|
||||
$data
|
||||
);
|
||||
$entry->add_contra($user, $amount, $description) if defined $user;
|
||||
$entry->{FORCE} = 1;
|
||||
|
||||
return $self->add_entry($entry);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -1,16 +1,14 @@
|
|||
use strict;
|
||||
|
||||
package RevBank::Cart::Entry;
|
||||
|
||||
use v5.28;
|
||||
use warnings;
|
||||
use feature qw(signatures);
|
||||
no warnings qw(experimental::signatures);
|
||||
|
||||
use Carp qw(carp croak);
|
||||
use List::Util ();
|
||||
|
||||
sub new {
|
||||
my ($class, $amount, $description, $attributes) = @_;
|
||||
|
||||
@_ >= 3 or croak "Not enough arguments for RevBank::Cart::Entry->new";
|
||||
$attributes //= {};
|
||||
|
||||
sub new($class, $amount, $description, $attributes = {}) {
|
||||
$amount = RevBank::Amount->parse_string($amount) if not ref $amount;
|
||||
|
||||
my $self = {
|
||||
|
|
@ -26,9 +24,7 @@ sub new {
|
|||
return bless $self, $class;
|
||||
}
|
||||
|
||||
sub add_contra {
|
||||
my ($self, $user, $amount, $description) = @_;
|
||||
|
||||
sub add_contra($self, $user, $amount, $description) {
|
||||
$amount = RevBank::Amount->parse_string($amount) if not ref $amount;
|
||||
|
||||
$description =~ s/\$you/$self->{user}/g if defined $self->{user};
|
||||
|
|
@ -42,26 +38,20 @@ sub add_contra {
|
|||
$self->attribute('changed', 1);
|
||||
}
|
||||
|
||||
sub has_attribute {
|
||||
my ($self, $key) = @_;
|
||||
|
||||
sub has_attribute($self, $key) {
|
||||
return (
|
||||
exists $self->{attributes}->{$key}
|
||||
and defined $self->{attributes}->{$key}
|
||||
);
|
||||
}
|
||||
|
||||
sub attribute {
|
||||
my ($self, $key, $new) = @_;
|
||||
|
||||
sub attribute($self, $key, $new = undef) {
|
||||
my $ref = \$self->{attributes}->{$key};
|
||||
$$ref = $new if @_ > 2;
|
||||
return $$ref;
|
||||
}
|
||||
|
||||
sub quantity {
|
||||
my ($self, $new) = @_;
|
||||
|
||||
sub quantity($self, $new = undef) {
|
||||
my $ref = \$self->{quantity};
|
||||
if (defined $new) {
|
||||
$new >= 0 or croak "Quantity must be positive";
|
||||
|
|
@ -72,22 +62,16 @@ sub quantity {
|
|||
return $$ref;
|
||||
}
|
||||
|
||||
sub multiplied {
|
||||
my ($self) = @_;
|
||||
|
||||
sub multiplied($self) {
|
||||
return $self->{quantity} != 1;
|
||||
}
|
||||
|
||||
sub contras {
|
||||
my ($self) = @_;
|
||||
|
||||
sub contras($self) {
|
||||
# Shallow copy suffices for now, because there is no depth.
|
||||
return map +{ %$_ }, @{ $self->{contras} };
|
||||
}
|
||||
|
||||
sub as_printable {
|
||||
my ($self) = @_;
|
||||
|
||||
sub as_printable($self) {
|
||||
$self->sanity_check;
|
||||
|
||||
my @s;
|
||||
|
|
@ -113,9 +97,7 @@ sub as_printable {
|
|||
return @s;
|
||||
}
|
||||
|
||||
sub as_loggable {
|
||||
my ($self) = @_;
|
||||
|
||||
sub as_loggable($self) {
|
||||
croak "Loggable called before set_user" if not defined $self->{user};
|
||||
$self->sanity_check;
|
||||
|
||||
|
|
@ -143,9 +125,7 @@ sub as_loggable {
|
|||
return @s;
|
||||
}
|
||||
|
||||
sub user {
|
||||
my ($self, $new) = @_;
|
||||
|
||||
sub user($self, $new = undef) {
|
||||
if (defined $new) {
|
||||
croak "User can only be set once" if defined $self->{user};
|
||||
|
||||
|
|
@ -156,9 +136,7 @@ sub user {
|
|||
return $self->{user};
|
||||
}
|
||||
|
||||
sub sanity_check {
|
||||
my ($self) = @_;
|
||||
|
||||
sub sanity_check($self) {
|
||||
# Turnover and journals are implicit contras, so (for now) a zero sum is
|
||||
# not required. However, in a transaction with contras, one should at least
|
||||
# not try to issue money that does not exist.
|
||||
|
|
|
|||
|
|
@ -1,5 +1,10 @@
|
|||
package RevBank::Global;
|
||||
use strict;
|
||||
|
||||
use v5.28;
|
||||
use warnings;
|
||||
use feature qw(signatures);
|
||||
no warnings qw(experimental::signatures);
|
||||
|
||||
use POSIX qw(strftime);
|
||||
use RevBank::Amount;
|
||||
|
||||
|
|
@ -14,8 +19,7 @@ sub import {
|
|||
*{"$caller\::NEXT"} = sub () { \4 };
|
||||
*{"$caller\::DONE"} = sub () { \5 };
|
||||
*{"$caller\::parse_user"} = \&RevBank::Users::parse_user;
|
||||
*{"$caller\::parse_amount"} = sub {
|
||||
my ($amount) = @_;
|
||||
*{"$caller\::parse_amount"} = sub ($amount) {
|
||||
defined $amount or return undef;
|
||||
length $amount or return undef;
|
||||
|
||||
|
|
@ -32,7 +36,7 @@ sub import {
|
|||
*{"$caller\::say"} = sub {
|
||||
print @_, "\n";
|
||||
};
|
||||
*{"$caller\::now"} = sub {
|
||||
*{"$caller\::now"} = sub () {
|
||||
return strftime '%Y-%m-%d_%H:%M:%S', localtime;
|
||||
};
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,10 @@
|
|||
package RevBank::Messages;
|
||||
|
||||
use v5.28;
|
||||
use warnings;
|
||||
use feature qw(signatures);
|
||||
no warnings qw(experimental::signatures);
|
||||
|
||||
use RevBank::Global;
|
||||
use base 'RevBank::Plugin';
|
||||
|
||||
|
|
@ -16,13 +22,11 @@ sub hook_startup {
|
|||
say "\e[0m\n\n\nWelcome to the RevBank Shell, version $::VERSION\n";
|
||||
}
|
||||
|
||||
sub hook_plugin_fail {
|
||||
my ($class, $plugin, $error) = @_;
|
||||
sub hook_plugin_fail($class, $plugin, $error, @) {
|
||||
warn "Plugin '$plugin' failed: $error\n";
|
||||
}
|
||||
|
||||
sub hook_cart_changed {
|
||||
my ($class, $cart) = @_;
|
||||
sub hook_cart_changed($class, $cart, @) {
|
||||
$cart->size or return;
|
||||
say "Pending:";
|
||||
$cart->display;
|
||||
|
|
@ -35,23 +39,19 @@ sub hook_cart_changed {
|
|||
}
|
||||
}
|
||||
|
||||
sub hook_abort {
|
||||
my ($class, $cart) = @_;
|
||||
sub hook_abort($class, $cart, @) {
|
||||
say "\e[1;4mABORTING TRANSACTION.\e[0m";
|
||||
}
|
||||
|
||||
sub hook_invalid_input {
|
||||
my ($class, $cart, $word) = @_;
|
||||
sub hook_invalid_input($class, $cart, $word, @) {
|
||||
say "$word: No such product, user, or command.";
|
||||
}
|
||||
|
||||
sub hook_reject {
|
||||
my ($class, $plugin, $reason, $abort) = @_;
|
||||
sub hook_reject($class, $plugin, $reason, $abort, @) {
|
||||
say $abort ? $reason : "$reason Enter 'abort' to abort.";
|
||||
}
|
||||
|
||||
sub hook_user_balance {
|
||||
my ($class, $username, $old, $delta, $new) = @_;
|
||||
sub hook_user_balance($class, $username, $old, $delta, $new, @) {
|
||||
my $sign = $delta->cents >= 0 ? '+' : '-';
|
||||
my $rood = $new->cents < 0 ? '31;' : '';
|
||||
my $abs = $delta->abs;
|
||||
|
|
@ -61,8 +61,7 @@ sub hook_user_balance {
|
|||
printf "New balance for $username: $old $sign $abs = \e[${rood}1m$new\e[0m$warn\n",
|
||||
}
|
||||
|
||||
sub hook_user_created {
|
||||
my ($class, $username) = @_;
|
||||
sub hook_user_created($class, $username, @) {
|
||||
say "New account '$username' created.";
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,16 @@
|
|||
package RevBank::Plugin;
|
||||
use strict;
|
||||
|
||||
use v5.28;
|
||||
use warnings;
|
||||
use feature qw(signatures);
|
||||
no warnings qw(experimental::signatures);
|
||||
|
||||
require RevBank::Global;
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
sub new($class) {
|
||||
return bless { }, $class;
|
||||
}
|
||||
sub command {
|
||||
sub command($self, $cart, $command, @) {
|
||||
return RevBank::Global::NEXT();
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,10 @@
|
|||
package RevBank::Plugins;
|
||||
use strict;
|
||||
|
||||
use v5.28;
|
||||
use warnings;
|
||||
use feature qw(signatures);
|
||||
no warnings qw(experimental::signatures);
|
||||
|
||||
use RevBank::Eval;
|
||||
use RevBank::Plugin;
|
||||
use RevBank::Global;
|
||||
|
|
@ -8,17 +13,16 @@ our @EXPORT = qw(call_hooks load_plugins);
|
|||
|
||||
my @plugins;
|
||||
|
||||
sub _read_file {
|
||||
local (@ARGV) = @_;
|
||||
sub _read_file($fn) {
|
||||
local @ARGV = ($fn);
|
||||
readline *ARGV;
|
||||
}
|
||||
|
||||
sub call_hooks {
|
||||
my $hook = shift;
|
||||
sub call_hooks($hook, @args) {
|
||||
my $method = "hook_$hook";
|
||||
for my $class (@plugins) {
|
||||
if ($class->can($method)) {
|
||||
my ($rv, $message) = $class->$method(@_);
|
||||
my ($rv, $message) = $class->$method(@args);
|
||||
|
||||
if (defined $rv and ref $rv) {
|
||||
main::abort($message) if $rv == ABORT;
|
||||
|
|
@ -28,12 +32,12 @@ sub call_hooks {
|
|||
}
|
||||
};
|
||||
|
||||
sub register {
|
||||
call_hooks("register", $_) for @_;
|
||||
push @plugins, @_;
|
||||
sub register(@new_plugins) {
|
||||
call_hooks("register", $_) for @new_plugins;
|
||||
push @plugins, @new_plugins;
|
||||
}
|
||||
|
||||
sub load {
|
||||
sub load($class) {
|
||||
my @config = _read_file('revbank.plugins');
|
||||
chomp @config;
|
||||
s/#.*//g for @config;
|
||||
|
|
@ -48,12 +52,13 @@ sub load {
|
|||
}
|
||||
RevBank::Eval::clean_eval(qq[
|
||||
use strict;
|
||||
use feature qw(signatures);
|
||||
no warnings 'experimental::signatures';
|
||||
package $package;
|
||||
BEGIN { RevBank::Global->import; }
|
||||
our \@ISA = qw(RevBank::Plugin);
|
||||
our \%ATTR;
|
||||
sub MODIFY_CODE_ATTRIBUTES {
|
||||
my (\$class, \$sub, \@attrs) = \@_;
|
||||
sub MODIFY_CODE_ATTRIBUTES(\$class, \$sub, \@attrs) {
|
||||
\$ATTR{ \$sub } = "\@attrs";
|
||||
return;
|
||||
}
|
||||
|
|
@ -79,7 +84,7 @@ sub load {
|
|||
}
|
||||
}
|
||||
|
||||
sub new {
|
||||
sub new($class) {
|
||||
return map $_->new, @plugins;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -45,12 +45,12 @@ There is no protection against infinite loops. Be careful!
|
|||
because that's canonicalised.
|
||||
|
||||
Don't do this:
|
||||
$cart->add($u, $a, "Bad example");
|
||||
$entry->add_contra($u, $a, "Bad example");
|
||||
|
||||
But do this:
|
||||
$u = parse_user($u) or return REJECT, "$u: No such user.";
|
||||
$a = parse_amount($a) or return REJECT, "$a: Invalid amount.";
|
||||
$cart->add($u, $a, 'Good, except that $a is special in Perl :)');
|
||||
$entry->add_contra($u, $a, 'Good, except that $a is special in Perl :)');
|
||||
|
||||
There are two kinds of plugin methods: input methods and hooks. A plugin may
|
||||
define one C<command> input method, and can have any number of hooks.
|
||||
|
|
@ -118,31 +118,34 @@ Hooks are called as class methods. The return value MUST be either C<ABORT>,
|
|||
which causes the ongoing transaction to be aborted, or a non-reference, which
|
||||
will be ignored.
|
||||
|
||||
Hooks SHOULD have a dummy C<@> parameter at the end of their signatures,
|
||||
so they don't break when more information is added
|
||||
|
||||
The following hooks are available, with their respective arguments:
|
||||
|
||||
=over 10
|
||||
|
||||
=item hook_register $class, $plugin
|
||||
=item hook_register($class, $plugin, @)
|
||||
|
||||
Called when a new plugin is registered.
|
||||
|
||||
=item hook_abort $class, $cart
|
||||
=item hook_abort($class, $cart, @)
|
||||
|
||||
Called when a transaction is being aborted, right before the shopping cart is
|
||||
emptied.
|
||||
|
||||
=item hook_prompt $class, $cart, $prompt
|
||||
=item hook_prompt($class, $cart, $prompt, @)
|
||||
|
||||
Called just before the user is prompted for input interactively. The prompt
|
||||
MAY be altered by the plugin.
|
||||
|
||||
=item hook_input $class, $cart, $input, $split_input
|
||||
=item hook_input($class, $cart, $input, $split_input, @)
|
||||
|
||||
Called when user input was given. C<$split_input> is a boolean that is true
|
||||
if the input will be split on whitespace, rather than treated as a whole.
|
||||
The input MAY be altered by the plugin.
|
||||
|
||||
=item hook_add $class, $cart, $user, $item
|
||||
=item hook_add($class, $cart, $user, $item, @)
|
||||
|
||||
Called when something is added to the cart. Of course, like in C<< $cart->add
|
||||
>>, C<$user> will be undef if the product is added for the current user.
|
||||
|
|
@ -153,32 +156,32 @@ item going into the cart!
|
|||
|
||||
Be careful to avoid infinite loops if you add new stuff.
|
||||
|
||||
=item hook_checkout $class, $cart, $user, $transaction_id
|
||||
=item hook_checkout($class, $cart, $user, $transaction_id, @)
|
||||
|
||||
Called when the transaction is finalized, before accounts are updated.
|
||||
|
||||
=item hook_checkout_done $class, $cart, $user, $transaction_id
|
||||
=item hook_checkout_done($class, $cart, $user, $transaction_id, @)
|
||||
|
||||
Called when the transaction is finalized, after accounts were updated.
|
||||
|
||||
=item hook_reject $class, $plugin, $reason, $abort
|
||||
=item hook_reject($class, $plugin, $reason, $abort, @)
|
||||
|
||||
Called when input is rejected by a plugin. C<$abort> is true when the
|
||||
transaction will be aborted because of the rejection.
|
||||
|
||||
=item hook_invalid_input $class, $cart, $word
|
||||
=item hook_invalid_input($class, $cart, $word, @)
|
||||
|
||||
Called when input was not recognised by any of the plugins.
|
||||
|
||||
=item hook_plugin_fail $class, $plugin, $error
|
||||
=item hook_plugin_fail($class, $plugin, $error, @)
|
||||
|
||||
Called when a plugin fails.
|
||||
|
||||
=item hook_user_created $class, $username
|
||||
=item hook_user_created($class, $username, @)
|
||||
|
||||
Called when a new user account was created.
|
||||
|
||||
=item hook_user_balance $class, $username, $old, $delta, $new, $transaction_id
|
||||
=item hook_user_balance($class, $username, $old, $delta, $new, $transaction_id, @)
|
||||
|
||||
Called when a user account is updated.
|
||||
|
||||
|
|
@ -189,7 +192,7 @@ C<RevBank::Messages>. Such a hack might look like:
|
|||
|
||||
undef &RevBank::Messages::hook_abort;
|
||||
|
||||
sub hook_abort {
|
||||
sub hook_abort($class, $cart, @) {
|
||||
print "This message is much better!\n"
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,16 @@
|
|||
package RevBank::Users;
|
||||
use strict;
|
||||
|
||||
use v5.28;
|
||||
use warnings;
|
||||
use feature qw(signatures);
|
||||
no warnings qw(experimental::signatures);
|
||||
|
||||
use RevBank::Global;
|
||||
use RevBank::Plugins;
|
||||
|
||||
my $filename = "revbank.accounts";
|
||||
|
||||
sub _read {
|
||||
sub _read() {
|
||||
my @users;
|
||||
open my $fh, $filename or die $!;
|
||||
/\S/ and push @users, [split " "] while readline $fh;
|
||||
|
|
@ -13,22 +18,19 @@ sub _read {
|
|||
return { map { lc($_->[0]) => $_ } @users };
|
||||
}
|
||||
|
||||
sub names {
|
||||
sub names() {
|
||||
return map $_->[0], values %{ _read() };
|
||||
}
|
||||
|
||||
sub balance {
|
||||
my ($name) = @_;
|
||||
return _read()->{ lc $name }->[1];
|
||||
sub balance($username) {
|
||||
return _read()->{ lc $username }->[1];
|
||||
}
|
||||
|
||||
sub since {
|
||||
my ($name) = @_;
|
||||
return _read()->{ lc $name }->[3];
|
||||
sub since($username) {
|
||||
return _read()->{ lc $username }->[3];
|
||||
}
|
||||
|
||||
sub create {
|
||||
my ($username) = @_;
|
||||
sub create($username) {
|
||||
open my $fh, '>>', $filename or die $!;
|
||||
my $now = now();
|
||||
print {$fh} "$username 0.00 $now\n" or die $!;
|
||||
|
|
@ -36,8 +38,7 @@ sub create {
|
|||
RevBank::Plugins::call_hooks("user_created", $username);
|
||||
}
|
||||
|
||||
sub update {
|
||||
my ($username, $delta, $transaction_id) = @_;
|
||||
sub update($username, $delta, $transaction_id) {
|
||||
open my $in, 'revbank.accounts' or die $!;
|
||||
open my $out, ">.revbank.$$" or die $!;
|
||||
my $old;
|
||||
|
|
@ -75,8 +76,7 @@ sub update {
|
|||
);
|
||||
}
|
||||
|
||||
sub parse_user {
|
||||
my ($username) = @_;
|
||||
sub parse_user($username) {
|
||||
my $users = _read();
|
||||
return undef if not exists $users->{ lc $username };
|
||||
return $users->{ lc $username }->[0];
|
||||
|
|
|
|||
|
|
@ -2,9 +2,7 @@
|
|||
|
||||
HELP "adduser <name>" => "Create an account";
|
||||
|
||||
sub command :Tab(adduser) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(adduser) ($self, $cart, $command, @) {
|
||||
$command eq 'adduser' or return NEXT;
|
||||
|
||||
if ($cart->size) {
|
||||
|
|
@ -14,9 +12,7 @@ sub command :Tab(adduser) {
|
|||
return "Name for the new account", \&username;
|
||||
}
|
||||
|
||||
sub username {
|
||||
my ($self, $cart, $name) = @_;
|
||||
|
||||
sub username($self, $cart, $name, @) {
|
||||
return REJECT, "Sorry, whitespace is not allowed."
|
||||
if $name =~ /\s/;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,8 +5,7 @@
|
|||
undef;
|
||||
};
|
||||
|
||||
sub hook_abort {
|
||||
my ($self, $cart, $reason) = @_;
|
||||
sub hook_abort($class, $cart, $reason, @) {
|
||||
return if not $reason or not @$reason;
|
||||
return if "@$reason" eq '^C';
|
||||
|
||||
|
|
|
|||
|
|
@ -5,8 +5,6 @@
|
|||
# Don't just edit this plugin. Instead, COPY this file and add yours to
|
||||
# revbank.plugins
|
||||
|
||||
sub hook_beep {
|
||||
my ($class) = @_;
|
||||
|
||||
sub hook_beep($class, @) {
|
||||
print "\a";
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,17 +4,13 @@
|
|||
|
||||
HELP "deposit <amount>" => "Deposit into an account";
|
||||
|
||||
sub command :Tab(deposit) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(deposit) ($self, $cart, $command, @) {
|
||||
$command eq 'deposit' or return NEXT;
|
||||
|
||||
return "Amount to deposit into your account", \&amount;
|
||||
}
|
||||
|
||||
sub amount :Tab(13.37,42) {
|
||||
my ($self, $cart, $amount) = @_;
|
||||
|
||||
sub amount :Tab(13.37,42) ($self, $cart, $amount, @) {
|
||||
$self->{amount} = parse_amount($amount)
|
||||
or return REJECT, "Invalid amount";
|
||||
|
||||
|
|
@ -27,9 +23,7 @@ sub amount :Tab(13.37,42) {
|
|||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub how :Tab(&how_tab) {
|
||||
my ($self, $cart, $input) = @_;
|
||||
|
||||
sub how :Tab(&how_tab) ($self, $cart, $input, @) {
|
||||
my %methods = %{ $self->{deposit_methods} };
|
||||
|
||||
my $how = $self->{how} = $methods{$input}
|
||||
|
|
@ -45,14 +39,11 @@ sub how :Tab(&how_tab) {
|
|||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub how_tab {
|
||||
my ($self) = @_;
|
||||
sub how_tab($self, @) {
|
||||
return keys %{ $self->{deposit_methods} };
|
||||
}
|
||||
|
||||
sub how_prompt {
|
||||
my ($self, $cart, $input) = @_;
|
||||
|
||||
sub how_prompt($self, $cart, $input, @) {
|
||||
my $how = $self->{how};
|
||||
|
||||
push @{ $how->{answers} }, $input;
|
||||
|
|
|
|||
|
|
@ -23,9 +23,7 @@ use List::Util qw(sum);
|
|||
my $iban = "NL99ABCD1234567890";
|
||||
my $beneficiary = "Account Name";
|
||||
|
||||
sub hook_checkout {
|
||||
my ($class, $cart, $user, $transaction_id) = @_;
|
||||
|
||||
sub hook_checkout($class, $cart, $user, $transaction_id, @) {
|
||||
my @entries = $cart->entries("is_deposit");
|
||||
|
||||
my $amount = sum map $_->{amount}, grep $_->attribute('method') eq 'iban', @entries;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
#!perl
|
||||
|
||||
sub hook_deposit_methods {
|
||||
my ($class, $message, $hash) = @_;
|
||||
|
||||
sub hook_deposit_methods($class, $message, $hash, @) {
|
||||
$$message = <<"END";
|
||||
|
||||
Please type one of the following:
|
||||
|
|
|
|||
|
|
@ -4,9 +4,7 @@ HELP "dinnerbonus" => "Add fee for cooking supplies";
|
|||
|
||||
my $bonus = 1.00;
|
||||
|
||||
sub command :Tab(kookbonus,dinnerbonus) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(kookbonus,dinnerbonus) ($self, $cart, $command, @) {
|
||||
my @users = map $_->{user}, map $_->contras, $cart->entries('is_take');
|
||||
|
||||
(@users and $command eq 'kookpotje') # common mistake promoted to feature
|
||||
|
|
|
|||
16
plugins/give
16
plugins/give
|
|
@ -2,35 +2,27 @@
|
|||
|
||||
HELP "give <account> <amount> [<reason>]" => "Transfer money to user's account";
|
||||
|
||||
sub command :Tab(give) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(give) ($self, $cart, $command, @) {
|
||||
return NEXT if $command ne 'give';
|
||||
|
||||
return "Beneficiary", \&beneficiary;
|
||||
}
|
||||
|
||||
sub beneficiary :Tab(USERS) {
|
||||
my ($self, $cart, $input) = @_;
|
||||
|
||||
sub beneficiary :Tab(USERS) ($self, $cart, $input, @) {
|
||||
$self->{beneficiary} = parse_user($input)
|
||||
or return REJECT, "$input: No such user.";
|
||||
|
||||
return "Amount to give to $self->{beneficiary}", \&amount;
|
||||
}
|
||||
|
||||
sub amount {
|
||||
my ($self, $cart, $input) = @_;
|
||||
|
||||
sub amount($self, $cart, $input, @) {
|
||||
$self->{amount} = parse_amount($input)
|
||||
or return REJECT, "$input: Invalid amount.";
|
||||
|
||||
return "Why are you giving $self->{amount} to $self->{beneficiary}, or enter your username to end", \&reason;
|
||||
}
|
||||
|
||||
sub reason :Tab(whatevah) {
|
||||
my ($self, $cart, $input) = @_;
|
||||
|
||||
sub reason :Tab(whatevah) ($self, $cart, $input, @) {
|
||||
my $beneficiary = $self->{beneficiary};
|
||||
my $amount = $self->{amount};
|
||||
|
||||
|
|
|
|||
|
|
@ -2,9 +2,7 @@
|
|||
|
||||
HELP "grandtotal" => "Summary of all accounts";
|
||||
|
||||
sub command :Tab(grandtotal) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(grandtotal) ($self, $cart, $command, @) {
|
||||
return NEXT if $command ne 'grandtotal';
|
||||
|
||||
my $pos = 0;
|
||||
|
|
|
|||
|
|
@ -8,9 +8,7 @@ my $bold = "\e[1m";
|
|||
my $underline = "\e[4m";
|
||||
my $off = "\e[0m";
|
||||
|
||||
sub command :Tab(help,wtf,omgwtfbbq) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(help,wtf,omgwtfbbq) ($self, $cart, $command, @) {
|
||||
return NEXT if $command !~ /^(?:help|wtf|omgwtfbbq)$/;
|
||||
|
||||
# GNU less(1) and more(1) are a bad choice to present to total newbies who
|
||||
|
|
|
|||
37
plugins/idle
37
plugins/idle
|
|
@ -2,28 +2,27 @@
|
|||
|
||||
my $timeout = 10;
|
||||
|
||||
sub hook_prompt_idle {
|
||||
my ($class, $cart, $plugin, $seconds, $readline) = @_;
|
||||
if ($seconds >= $timeout and $cart->size and not $plugin) {
|
||||
call_hooks("beep");
|
||||
sub hook_prompt_idle($class, $cart, $plugin, $seconds, $readline, @) {
|
||||
return unless $seconds >= $timeout and $cart->size and not $plugin;
|
||||
|
||||
return if $seconds > $timeout; # text only once
|
||||
call_hooks("beep");
|
||||
|
||||
my $text = $readline->copy_text;
|
||||
my $point = $readline->{point};
|
||||
return if $seconds > $timeout; # text only once
|
||||
|
||||
$readline->save_prompt;
|
||||
$readline->replace_line("");
|
||||
$readline->redisplay;
|
||||
my $text = $readline->copy_text;
|
||||
my $point = $readline->{point};
|
||||
|
||||
my $help = $cart->entries('refuse_checkout')
|
||||
? "Enter 'abort' to abort."
|
||||
: "Enter username to pay/finish or 'abort' to abort.";
|
||||
print "\e[33;2;1mTransaction incomplete.\e[0m $help\n";
|
||||
$readline->save_prompt;
|
||||
$readline->replace_line("");
|
||||
$readline->redisplay;
|
||||
|
||||
$readline->restore_prompt;
|
||||
$readline->replace_line($text);
|
||||
$readline->{point} = $point;
|
||||
$readline->redisplay;
|
||||
}
|
||||
my $help = $cart->entries('refuse_checkout')
|
||||
? "Enter 'abort' to abort."
|
||||
: "Enter username to pay/finish or 'abort' to abort.";
|
||||
print "\e[33;2;1mTransaction incomplete.\e[0m $help\n";
|
||||
|
||||
$readline->restore_prompt;
|
||||
$readline->replace_line($text);
|
||||
$readline->{point} = $point;
|
||||
$readline->redisplay;
|
||||
}
|
||||
|
|
|
|||
27
plugins/log
27
plugins/log
|
|
@ -9,48 +9,41 @@ sub _log {
|
|||
}
|
||||
|
||||
my %buffer;
|
||||
sub hook_abort {
|
||||
sub hook_abort(@) {
|
||||
_log("ABORT");
|
||||
}
|
||||
sub hook_prompt {
|
||||
my ($class, $cart, $prompt) = @_;
|
||||
sub hook_prompt($class, $cart, $prompt, @) {
|
||||
$buffer{prompt} = $prompt;
|
||||
}
|
||||
sub hook_input {
|
||||
my ($class, $cart, $input, $split_input) = @_;
|
||||
|
||||
sub hook_input($class, $cart, $input, $split_input, @) {
|
||||
$input //= "(UNDEF)";
|
||||
_log("PROMPT $buffer{prompt} >> $input");
|
||||
}
|
||||
|
||||
sub hook_reject {
|
||||
my ($class, $plugin, $reason, $abort) = @_;
|
||||
sub hook_reject($class, $plugin, $reason, $abort, @) {
|
||||
_log("REJECT [$plugin] $reason");
|
||||
}
|
||||
|
||||
sub hook_retry {
|
||||
my ($class, $plugin, $reason, $abort) = @_;
|
||||
sub hook_retry($class, $plugin, $reason, $abort, @) {
|
||||
_log("RETRY [$plugin] $reason");
|
||||
}
|
||||
|
||||
sub hook_user_created {
|
||||
my ($class, $username) = @_;
|
||||
sub hook_user_created($class, $username, @) {
|
||||
_log("NEWUSER $username");
|
||||
}
|
||||
|
||||
sub hook_user_balance {
|
||||
my ($class, $user, $old, $delta, $new, $transaction_id) = @_;
|
||||
sub hook_user_balance($class, $user, $old, $delta, $new, $transaction_id, @) {
|
||||
my $lost = $delta < 0 ? "lost" : "got";
|
||||
$delta = $delta->abs;
|
||||
$_ = $_->string("+") for $old, $new;
|
||||
_log("BALANCE $transaction_id $user had $old, $lost $delta, now has $new");
|
||||
}
|
||||
|
||||
sub hook_checkout {
|
||||
my ($class, $cart, $username, $transaction_id) = @_;
|
||||
sub hook_checkout($class, $cart, $username, $transaction_id, @) {
|
||||
_log("CHECKOUT $transaction_id $_") for map $_->as_loggable, $cart->entries;
|
||||
}
|
||||
|
||||
sub hook_register {
|
||||
my ($class, $plugin) = @_;
|
||||
sub hook_register($class, $plugin, @) {
|
||||
_log("REGISTER $plugin");
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ HELP "market" => "Edit market list";
|
|||
|
||||
my $filename = 'revbank.market';
|
||||
|
||||
sub _read_market {
|
||||
sub _read_market() {
|
||||
open my $fh, '<', $filename or die "$filename: $!";
|
||||
my %market;
|
||||
while (readline $fh) {
|
||||
|
|
@ -22,9 +22,7 @@ sub _read_market {
|
|||
return \%market;
|
||||
}
|
||||
|
||||
sub command :Tab(market,&tab) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(market,&tab) ($self, $cart, $command, @) {
|
||||
if ($command eq 'market') {
|
||||
system $ENV{EDITOR} || 'vi', $filename;
|
||||
return ACCEPT;
|
||||
|
|
|
|||
|
|
@ -9,23 +9,20 @@ HELP "pfand" => "Pfand zurueck";
|
|||
# The file format for 'revbank.pfand' is simply two whitespace separated
|
||||
# columns: product id and pfand amount.
|
||||
|
||||
sub _read_pfand {
|
||||
sub _read_pfand() {
|
||||
open my $fh, 'revbank.pfand' or die $!;
|
||||
return {
|
||||
map { split " " } grep /\S/, grep !/^\s*#/, readline $fh
|
||||
};
|
||||
}
|
||||
|
||||
sub command :Tab(pfand) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(pfand) ($self, $cart, $command, @) {
|
||||
return NEXT if $command ne 'pfand';
|
||||
|
||||
return "Pfand zurueck fuer", \&product;
|
||||
}
|
||||
|
||||
sub product :Tab(&tab) {
|
||||
my ($self, $cart, $product) = @_;
|
||||
sub product :Tab(&tab) ($self, $cart, $product, @) {
|
||||
my $pfand = parse_amount(_read_pfand->{ $product })
|
||||
or return REJECT, "Invalid pfand amount for $product";
|
||||
|
||||
|
|
@ -41,8 +38,7 @@ sub tab {
|
|||
return keys %{ _read_pfand() };
|
||||
}
|
||||
|
||||
sub hook_add_entry {
|
||||
my ($class, $cart, $entry) = @_;
|
||||
sub hook_add_entry ($class, $cart, $entry, @) {
|
||||
return if $entry->has_attribute('is_return');
|
||||
return if not $entry->has_attribute('product_id');
|
||||
|
||||
|
|
|
|||
|
|
@ -6,9 +6,7 @@ my $limit = 200;
|
|||
my $err_limit = "Repetition is limited at $limit items.";
|
||||
my $err_pfand = "Plugins 'pfand' and 'repeat' cannot be combined.";
|
||||
|
||||
sub command {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command($self, $cart, $command, @) {
|
||||
return ABORT, $err_pfand if $cart->entries('is_pfand');
|
||||
|
||||
my ($post) = $command =~ /^\+(\d+)?$/
|
||||
|
|
@ -30,9 +28,7 @@ sub command {
|
|||
return "Add to previous product", \&add;
|
||||
}
|
||||
|
||||
sub add {
|
||||
my ($self, $cart, $arg) = @_;
|
||||
|
||||
sub add($self, $cart, $arg, @) {
|
||||
$arg =~ /^\d+$/ and $arg > 0
|
||||
or return REJECT, "Invalid value.";
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ HELP "edit" => "Edit product list";
|
|||
|
||||
my $filename = 'revbank.products';
|
||||
|
||||
sub _read_products {
|
||||
sub _read_products() {
|
||||
open my $fh, '<', $filename or die "$filename: $!";
|
||||
my %products;
|
||||
while (readline $fh) {
|
||||
|
|
@ -22,9 +22,7 @@ sub _read_products {
|
|||
return \%products;
|
||||
}
|
||||
|
||||
sub command :Tab(edit,&tab) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(edit,&tab) ($self, $cart, $command, @) {
|
||||
if ($command eq 'edit') {
|
||||
system $ENV{EDITOR} || 'vi', $filename;
|
||||
return ACCEPT;
|
||||
|
|
|
|||
|
|
@ -10,9 +10,7 @@ my $err_postfix = "Addition/substraction is only supported the other way around.
|
|||
my $limit = 200;
|
||||
my $err_limit = "Repetition is limited at $limit items.";
|
||||
|
||||
sub command {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command($self, $cart, $command, @) {
|
||||
return ABORT, $err_pfand if $cart->entries('is_pfand');
|
||||
|
||||
my ($lhs, $op, $rhs) = $command =~ /^(\d+)?([x*+-])(\d+)?$/
|
||||
|
|
@ -86,9 +84,7 @@ sub command {
|
|||
return "Multiply previous product by", \&repeat;
|
||||
}
|
||||
|
||||
sub repeat {
|
||||
my ($self, $cart, $arg) = @_;
|
||||
|
||||
sub repeat($self, $cart, $arg, @) {
|
||||
$arg =~ /^\d+$/ and $arg > 0
|
||||
or return REJECT, "Invalid value.";
|
||||
|
||||
|
|
@ -98,9 +94,7 @@ sub repeat {
|
|||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub plusminus {
|
||||
my ($self, $cart, $arg) = @_;
|
||||
|
||||
sub plusminus($self, $cart, $arg, @) {
|
||||
$arg =~ /^\d+$/ and $arg > 0
|
||||
or return REJECT, "Invalid value.";
|
||||
|
||||
|
|
@ -119,8 +113,7 @@ sub plusminus {
|
|||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub hook_added_entry {
|
||||
my ($self, $cart, $entry) = @_;
|
||||
sub hook_added_entry($class, $cart, $entry, @) {
|
||||
$cart->size >= 2 or return;
|
||||
|
||||
my @entries = $cart->entries;
|
||||
|
|
|
|||
|
|
@ -2,9 +2,7 @@
|
|||
|
||||
HELP "restart" => "Attempt to restart the RevBank shell";
|
||||
|
||||
sub command :Tab(restart) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(restart) ($self, $cart, $command, @) {
|
||||
return NEXT if $command ne 'restart';
|
||||
|
||||
no warnings;
|
||||
|
|
@ -15,9 +13,7 @@ sub command :Tab(restart) {
|
|||
return ABORT, "exec() failed. You'll have to restart revbank yourself :P";
|
||||
}
|
||||
|
||||
sub hook_input {
|
||||
my ($self, $cart, $input, $split_input) = @_;
|
||||
|
||||
sub hook_input($class, $cart, $input, $split_input, @) {
|
||||
return if defined $input;
|
||||
|
||||
no warnings;
|
||||
|
|
|
|||
|
|
@ -7,17 +7,13 @@
|
|||
|
||||
|
||||
|
||||
sub command :Tab(barcode) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(barcode) ($self, $cart, $command, @) {
|
||||
return NEXT if $command ne "barcode";
|
||||
|
||||
return "Barcode data", \&data;
|
||||
}
|
||||
|
||||
sub data {
|
||||
my ($self, $cart, $input) = @_;
|
||||
|
||||
sub data($self, $cart, $input, @) {
|
||||
$cart->add(
|
||||
-0.07,
|
||||
"Barcode <$input>",
|
||||
|
|
@ -27,9 +23,7 @@ sub data {
|
|||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub hook_checkout {
|
||||
my ($class, $cart, $username, $transaction_id) = @_;
|
||||
|
||||
sub hook_checkout($class, $cart, $username, $transaction_id, @) {
|
||||
my @barcodes;
|
||||
for my $entry ($cart->entries('is_barcode')) {
|
||||
push @barcodes, ($entry->attribute('barcode_data')) x $entry->quantity;
|
||||
|
|
|
|||
|
|
@ -7,9 +7,7 @@ my %bounties = (
|
|||
4 => [ 15, "Bedankt voor 't poetsen van alle tafels" ],
|
||||
);
|
||||
|
||||
sub command :Tab(BOUNTY1,BOUNTY2,BOUNTY3,BOUNTY4) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(BOUNTY1,BOUNTY2,BOUNTY3,BOUNTY4) ($self, $cart, $command, @) {
|
||||
if ($command =~ /BOUNTY(\d+)/) {
|
||||
$cart->add(+$bounties{$1}[0], $bounties{$1}[1]);
|
||||
return ACCEPT;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#!perl
|
||||
|
||||
sub hook_user_balance {
|
||||
my ($class, $username, $old, $delta, $new, $transaction_id) = @_;
|
||||
sub hook_user_balance($class, $username, $old, $delta, $new, $transaction_id, @) {
|
||||
my $msg = "$transaction_id ($username)";
|
||||
$msg =~ s/[^\x20-\x7E]//g;
|
||||
$msg =~ s/'//g;
|
||||
|
|
|
|||
|
|
@ -5,8 +5,7 @@ use JSON;
|
|||
my $ua = LWP::UserAgent->new(agent => "revbank");
|
||||
my $backend_url = "https://deposit.revspace.nl/mollie.php";
|
||||
|
||||
sub backend_call {
|
||||
my ($hash) = @_;
|
||||
sub backend_call($hash) {
|
||||
#$hash->{test} = 1; # use mollie test environment
|
||||
|
||||
my $response = $ua->post($backend_url, $hash);
|
||||
|
|
@ -20,9 +19,7 @@ sub backend_call {
|
|||
return $result;
|
||||
}
|
||||
|
||||
sub command {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command($self, $cart, $command, @) {
|
||||
# currently 10 characters after the underscore, but it's not documented.
|
||||
my ($id) = $command =~ /^(tr_[A-Za-z0-9]{10,12})$/ or return NEXT;
|
||||
|
||||
|
|
@ -46,8 +43,7 @@ sub command {
|
|||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub hook_abort {
|
||||
my ($class, $cart, $reason) = @_;
|
||||
sub hook_abort($class, $cart, $reason, @) {
|
||||
# Opportunistic; ignore failures. Can't do anything about it anyway.
|
||||
|
||||
my @ids = map $_->attribute('mollie_id'), $cart->entries('mollie_id');
|
||||
|
|
@ -55,8 +51,7 @@ sub hook_abort {
|
|||
for @ids;
|
||||
}
|
||||
|
||||
sub hook_checkout {
|
||||
my ($class, $cart, $user, $transaction_id) = @_;
|
||||
sub hook_checkout($class, $cart, $user, $transaction_id, @) {
|
||||
# Opportunistic; ignore failures. Can't do anything about it anyway.
|
||||
|
||||
my @ids = map $_->attribute('mollie_id'), $cart->entries('mollie_id');
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@
|
|||
|
||||
use Net::MQTT::Simple "mosquitto.space.revspace.nl";
|
||||
|
||||
sub hook_checkout {
|
||||
my ($class, $cart, $user, $transaction_id) = @_;
|
||||
sub hook_checkout($class, $cart, $user, $transaction_id, @) {
|
||||
my $filename = "revbank.sales";
|
||||
my @entries = $cart->entries('product_id') or return;
|
||||
my %already_retained;
|
||||
|
|
|
|||
|
|
@ -2,17 +2,15 @@
|
|||
|
||||
use POSIX qw(strftime);
|
||||
|
||||
sub _box {
|
||||
sub _box(@lines) {
|
||||
print(
|
||||
"#" x 79, "\n",
|
||||
(map { sprintf("## %-73s ##\n", $_) } @_),
|
||||
(map { sprintf("## %-73s ##\n", $_) } @lines),
|
||||
"#" x 79, "\n"
|
||||
);
|
||||
}
|
||||
|
||||
sub hook_checkout_done {
|
||||
my ($class, $cart, $user, $transaction_id) = @_;
|
||||
|
||||
sub hook_checkout_done($class, $cart, $user, $transaction_id, @) {
|
||||
defined $user or return; # hacks like 'undo' don't have an acting user
|
||||
|
||||
my $balance = RevBank::Users::balance($user) or return;
|
||||
|
|
|
|||
|
|
@ -4,14 +4,11 @@ use List::Util ();
|
|||
|
||||
HELP "split <account>..." => "Split the bill with others";
|
||||
|
||||
sub _select_split {
|
||||
my ($cart) = @_;
|
||||
sub _select_split($cart) {
|
||||
grep $_->{amount} < 0, $cart->entries
|
||||
}
|
||||
|
||||
sub command :Tab(take,steal,split) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(take,steal,split) ($self, $cart, $command, @) {
|
||||
$command eq 'split' or return NEXT;
|
||||
|
||||
$self->{users} = [];
|
||||
|
|
@ -25,9 +22,7 @@ sub command :Tab(take,steal,split) {
|
|||
return "User to take from (not yourself)", \&arg;
|
||||
}
|
||||
|
||||
sub arg :Tab(USERS) {
|
||||
my ($self, $cart, $arg) = @_;
|
||||
|
||||
sub arg :Tab(USERS) ($self, $cart, $arg, @) {
|
||||
my $users = $self->{users};
|
||||
|
||||
if (@$users and $arg eq $self->{split_finish}) {
|
||||
|
|
|
|||
|
|
@ -2,9 +2,7 @@
|
|||
|
||||
HELP "cash" => "Checkout without a user account";
|
||||
|
||||
sub command :Tab(cash) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(cash) ($self, $cart, $command, @) {
|
||||
return NEXT if $command ne 'cash';
|
||||
|
||||
call_hooks("checkout", $cart, 'cash', 0); # Fake checkout
|
||||
|
|
@ -13,9 +11,7 @@ sub command :Tab(cash) {
|
|||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub hook_checkout {
|
||||
my ($class, $cart, $user, $transaction_id) = @_;
|
||||
|
||||
sub hook_checkout($class, $cart, $user, $transaction_id, @) {
|
||||
# Hack42 for some reason used the dutch word in their revbank1 hack.
|
||||
my $filename = -e("revbank.voorraad")
|
||||
? "revbank.voorraad"
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
#!perl
|
||||
|
||||
sub command :Tab(tail) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(tail) ($self, $cart, $command, @) = @_;
|
||||
return NEXT if $command ne 'tail';
|
||||
|
||||
my $n = (`tput lines 2>/dev/null` || 13) - 3;
|
||||
|
|
|
|||
13
plugins/take
13
plugins/take
|
|
@ -2,9 +2,7 @@
|
|||
|
||||
HELP "take <account>... <amount> <reason>" => "Transfer money from them to you";
|
||||
|
||||
sub command :Tab(take,steal) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(take,steal) ($self, $cart, $command, @) {
|
||||
$command eq 'take' or $command eq 'steal'
|
||||
or return NEXT;
|
||||
|
||||
|
|
@ -13,9 +11,7 @@ sub command :Tab(take,steal) {
|
|||
return "User to take from", \&arg;
|
||||
}
|
||||
|
||||
sub arg :Tab(USERS) {
|
||||
my ($self, $cart, $arg) = @_;
|
||||
|
||||
sub arg :Tab(USERS) ($self, $cart, $arg, @) {
|
||||
my @users = @{ $self->{users} };
|
||||
my $amount = parse_amount($arg);
|
||||
|
||||
|
|
@ -46,9 +42,8 @@ sub arg :Tab(USERS) {
|
|||
return "User to take from, or total amount to finish", \&arg;
|
||||
}
|
||||
|
||||
sub reason :Tab(bbq,NOABORT) { # finish
|
||||
my ($self, $cart, $reason) = @_;
|
||||
|
||||
# finish
|
||||
sub reason :Tab(bbq,NOABORT) ($self, $cart, $reason, @) {
|
||||
return REJECT, "'$reason' is a username, not a description :)."
|
||||
if parse_user($reason);
|
||||
return REJECT, "'$reason' is an amount, not a description :)."
|
||||
|
|
|
|||
12
plugins/undo
12
plugins/undo
|
|
@ -4,9 +4,7 @@ HELP "undo <transactionID>" => "Undo a transaction";
|
|||
|
||||
my $filename = ".revbank.undo";
|
||||
|
||||
sub command :Tab(undo) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(undo) ($self, $cart, $command, @) {
|
||||
$command eq 'undo' or return NEXT;
|
||||
|
||||
$cart->size and return ABORT, "Undo is not available mid-transaction.";
|
||||
|
|
@ -14,9 +12,7 @@ sub command :Tab(undo) {
|
|||
return "Transaction ID", \&undo;
|
||||
}
|
||||
|
||||
sub undo {
|
||||
my ($self, $cart, $tid) = @_;
|
||||
|
||||
sub undo($self, $cart, $tid, @) {
|
||||
open my $in, '<', $filename or die "$filename: $!";
|
||||
open my $out, '>', "$filename.$$" or die "$filename.$$: $!";
|
||||
my $description = "Undo $tid";
|
||||
|
|
@ -47,9 +43,7 @@ sub undo {
|
|||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub hook_user_balance {
|
||||
my ($class, $username, $old, $delta, $new, $transaction_id) = @_;
|
||||
|
||||
sub hook_user_balance($class, $username, $old, $delta, $new, $transaction_id, @) {
|
||||
open my $fh, '>>', $filename or die "$filename: $!";
|
||||
print {$fh} join " ", $transaction_id, $username, -$delta, now(), "\n";
|
||||
close $fh or die "$filename: $!";
|
||||
|
|
|
|||
|
|
@ -2,16 +2,14 @@
|
|||
|
||||
HELP "unlisted" => "Buy unlisted product (manual entry)";
|
||||
|
||||
sub command :Tab(unlisted,donate) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
sub command :Tab(unlisted,donate) ($self, $cart, $command, @) {
|
||||
$command eq 'unlisted' or $command eq 'donate' or return NEXT;
|
||||
$self->{command} = $command;
|
||||
|
||||
return "Amount to deduct from your account", \&amount;
|
||||
}
|
||||
|
||||
sub amount {
|
||||
my ($self, $cart, $arg) = @_;
|
||||
sub amount($self, $cart, $arg, @) {
|
||||
$self->{amount} = parse_amount($arg) or return REJECT, "Invalid amount.";
|
||||
|
||||
if ($self->{command} eq 'donate') {
|
||||
|
|
@ -22,8 +20,7 @@ sub amount {
|
|||
return "Please provide a short description", \&description;
|
||||
}
|
||||
|
||||
sub description {
|
||||
my ($self, $cart, $desc) = @_;
|
||||
sub description($self, $cart, $desc, @) {
|
||||
$cart->add(-$self->{amount}, $desc);
|
||||
return ACCEPT;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#!perl
|
||||
|
||||
sub command {
|
||||
my ($self, $cart, $command) = @_;
|
||||
sub command($self, $cart, $command, @) {
|
||||
if ($command =~ m[^https?://]) {
|
||||
print "This is not a browser...";
|
||||
return ACCEPT;
|
||||
|
|
|
|||
|
|
@ -4,9 +4,7 @@ HELP "<account>" => "[Pay with your account and] show balance";
|
|||
HELP "list" => "List accounts and balances";
|
||||
HELP "shame" => "Display Hall of Shame (negative balances)";
|
||||
|
||||
sub command :Tab(list,ls,shame,USERS) {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command :Tab(list,ls,shame,USERS) ($self, $cart, $command, @) {
|
||||
return $self->list if $command eq 'list';
|
||||
return $self->list if $command eq 'ls';
|
||||
return $self->shame if $command eq 'shame';
|
||||
|
|
@ -21,9 +19,7 @@ sub command :Tab(list,ls,shame,USERS) {
|
|||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub hook_checkout {
|
||||
my ($class, $cart, $user, $transaction_id) = @_;
|
||||
|
||||
sub hook_checkout($class, $cart, $user, $transaction_id, @) {
|
||||
if ($cart->changed) {
|
||||
say "Done:";
|
||||
$cart->display;
|
||||
|
|
@ -31,26 +27,24 @@ sub hook_checkout {
|
|||
say "Transaction ID: $transaction_id";
|
||||
}
|
||||
|
||||
sub list {
|
||||
sub list($self) {
|
||||
system "sort -f revbank.accounts | grep -v ^# | perl -pe's/( -[\\d.]+)/\\e[31;1m\$1\\e[0m/' | more";
|
||||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub shame {
|
||||
sub shame($self) {
|
||||
system "sort -k2 -n revbank.accounts | grep -v ^# | grep -- ' -' | perl -pe's/( -[\\d.]+)/\\e[31;1m\$1\\e[0m/' | more";
|
||||
return ACCEPT;
|
||||
}
|
||||
|
||||
sub recent {
|
||||
my ($n, $u) = @_;
|
||||
sub _recent($n, $u) {
|
||||
$n += 0;
|
||||
print "Last $n transactions for $u:\n";
|
||||
system "perl -lane'lc(\$F[3]) eq lc(qq[\Q$u\E]) or next; s/CHECKOUT\\s+\\S+\\s+\\S+\\s+// or next; s/ #// or next; s/_/ /; print' .revbank.log | tail -n$n";
|
||||
}
|
||||
|
||||
sub balance {
|
||||
my ($self, $u) = @_;
|
||||
recent(10, $u);
|
||||
sub balance($self, $u) {
|
||||
_recent(10, $u);
|
||||
printf "Balance for $u is \e[1m%+.2f\e[0m\n", RevBank::Users::balance($u);
|
||||
say "NB: Products/amounts/commands FIRST, username LAST.";
|
||||
return ABORT;
|
||||
|
|
|
|||
|
|
@ -3,9 +3,7 @@
|
|||
sub command { print "@_\n"; NEXT }
|
||||
|
||||
|
||||
sub hook_user_balance {
|
||||
my ($class, $username, $old, $delta, $new) = @_;
|
||||
|
||||
sub hook_user_balance($class, $username, $old, $delta, $new, @) {
|
||||
print "c: $class\n";
|
||||
print "u: $username\n";
|
||||
print "o: $old\n";
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
|
||||
use Time::HiRes qw(sleep);
|
||||
|
||||
sub _read_warnings {
|
||||
sub _read_warnings() {
|
||||
open my $fh, 'revbank.warnings' or die $!;
|
||||
return map {
|
||||
my ($regex, $products, $text) = m[^
|
||||
|
|
@ -29,8 +29,7 @@ sub _read_warnings {
|
|||
} grep /\S/, grep !/^\s*#/, readline $fh;
|
||||
}
|
||||
|
||||
sub hook_add_entry {
|
||||
my ($class, $cart, $entry) = @_;
|
||||
sub hook_add_entry($class, $cart, $entry, @) {
|
||||
return if not $entry->has_attribute('product_id'); # skip unlisted, deposit, give, take
|
||||
|
||||
my @warnings = map {
|
||||
|
|
|
|||
|
|
@ -2,9 +2,7 @@
|
|||
|
||||
HELP "<amount>" => "Withdraw or enter price manually";
|
||||
|
||||
sub command {
|
||||
my ($self, $cart, $command) = @_;
|
||||
|
||||
sub command($self, $cart, $command, @) {
|
||||
my $amount = parse_amount($command);
|
||||
defined $amount or return NEXT;
|
||||
|
||||
|
|
|
|||
12
revbank
12
revbank
|
|
@ -1,6 +1,10 @@
|
|||
#!/usr/bin/perl -w
|
||||
#!/usr/bin/perl
|
||||
|
||||
use v5.28;
|
||||
use warnings;
|
||||
use feature qw(signatures);
|
||||
no warnings "experimental::signatures";
|
||||
|
||||
use strict;
|
||||
use attributes;
|
||||
use IO::Select;
|
||||
use List::Util ();
|
||||
|
|
@ -45,9 +49,7 @@ $select->add(\*STDIN);
|
|||
|
||||
my $cart = RevBank::Cart->new;
|
||||
|
||||
sub prompt {
|
||||
my ($prompt, $plugins, $completions) = @_;
|
||||
|
||||
sub prompt($prompt, $plugins, $completions) {
|
||||
if ($prompt) {
|
||||
$prompt =~ s/$/:/ if $prompt !~ /[?>]$/;
|
||||
$prompt .= " ";
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue