cwd is no longer in @INC in new perl versions

lib/RevBank/Cart.pm

@@ -0,0 +1,136 @@
+package RevBank::Cart;
+use strict;
+use Carp ();
+use List::Util ();
+use RevBank::Global;
+
+# Some code is written with the assumption that the cart will only grow or
+# be emptied. Changing existing stuff or removing items is probably not a
+# good idea, and may lead to inconsistency.
+
+sub new {
+    my ($class) = @_;
+    return bless { }, $class;
+}
+
+sub add {
+    my ($self, $user, $amount, $description, $data) = @_;
+    $data ||= {};
+    my $item = {
+        %$data,  # Internal stuff, not logged or printed.
+        amount => $amount,
+        description => $description,
+    };
+    RevBank::Plugins::call_hooks("add", $self, $user, $item);
+    $user ||= '$you';
+    push @{ $self->{ $user } }, $item;
+}
+
+sub delete {
+    my ($self, $user, $index) = @_;
+    splice @{ $self->{ $user } }, $index, 1, ();
+}
+
+sub empty {
+    my ($self) = @_;
+    %$self = ();
+}
+
+sub _dump_item {
+    my ($prefix, $user, $amount, $description) = @_;
+    return sprintf(
+        "%s%-12s %4s EUR %5.2f  %s",
+        $prefix,
+        $user,
+        ($amount > 0 ? 'GAIN' : $amount < 0 ? 'LOSE' : ''),
+        abs($amount),
+        $description
+    );
+}
+
+sub as_strings {
+    my ($self, $prefix) = @_;
+    $prefix ||= '    ';
+
+    my @s;
+
+    for my $user (sort keys %$self) {
+        my @items = @{ $self->{$user} };
+        my $sum = List::Util::sum(map $_->{amount}, @items);
+
+        push @s, _dump_item($prefix, $user, $_->{amount}, "# $_->{description}")
+            for @items;
+        push @s, _dump_item($prefix, $user, $sum, "TOTAL")
+            if @items > 1;
+    }
+
+    return @s;
+}
+
+sub display {
+    my ($self, $prefix) = @_;
+    say $_ for $self->as_strings($prefix);
+}
+
+sub size {
+    my ($self) = @_;
+    return List::Util::sum(map scalar @{ $self->{$_} }, keys %$self) || 0;
+}
+
+sub _set_user {
+    my ($self, $user) = @_;
+
+    exists $self->{'$you'}
+        or Carp::croak("Error: no cart items for shell user");
+
+    $self->{$user} ||= [];
+
+    push @{ $self->{$user} }, @{ delete $self->{'$you'} };
+
+    for (values %$self) {
+        $_->{description} =~ s/\$you\b/$user/g for @$_;
+    }
+}
+
+sub checkout {
+    my ($self, $user) = @_;
+
+    $self->_set_user($user) if $user;
+
+    exists $self->{'$you'} and die "Incomplete transaction; user not set.";
+
+    my $transaction_id = time() - 1300000000;
+    RevBank::Plugins::call_hooks("checkout", $self, $user, $transaction_id);
+
+    for my $account (keys %$self) {
+        my $sum = List::Util::sum(map $_->{amount}, @{ $self->{$account} });
+        RevBank::Users::update($account, $sum, $transaction_id);
+    }
+
+    $self->empty;
+
+    sleep 1;  # Ensure new timestamp/id for new transaction
+}
+
+sub select_items {
+    my ($self, $key) = @_;
+
+    my @matches;
+    for my $user (keys %$self) {
+        for my $item (@{ $self->{$user} }) {
+            push @matches, { user => $user, %$item }
+                if @_ == 1  # No key or match given: match everything
+                or @_ == 2 and exists $item->{ $key }   # Just a key
+        }
+    }
+
+    return @matches;
+}
+
+sub is_multi_user {
+    my ($self) = @_;
+    return keys(%$self) > 1;
+}
+
+1;
+

lib/RevBank/Eval.pm

@@ -0,0 +1,13 @@
+package RevBank::Eval;
+
+# This function is used so strings can be eval'ed in a clean lexical
+# environment.
+
+sub clean_eval { eval shift }
+
+# No, it's not scary. We're using string eval to load plugins, just as it would
+# be used to load modules. As we're not executing user input, this is really
+# NOT a security bug.
+
+1;
+

lib/RevBank/Global.pm

@@ -0,0 +1,87 @@
+package RevBank::Global;
+use strict;
+use POSIX qw(strftime);
+
+sub import {
+    require RevBank::Plugins;
+    require RevBank::Users;
+    no strict 'refs';
+    my $caller = caller;
+    *{"$caller\::ACCEPT"} = sub () { \1 };
+    *{"$caller\::ABORT"}  = sub () { \2 };
+    *{"$caller\::REJECT"} = sub () { \3 };
+    *{"$caller\::NEXT"}   = sub () { \4 };
+    *{"$caller\::DONE"}   = sub () { \5 };
+    *{"$caller\::parse_user"} = \&RevBank::Users::parse_user;
+    *{"$caller\::parse_amount"} = sub {
+        my ($amount) = @_;
+        defined $amount or return undef;
+        length  $amount or return undef;
+        $amount =~ /^(-)?[0-9]*(?:[,.][0-9]{1,2})?$/ or return undef;
+        if ($1) {
+            die "For our sanity, no negative amounts, please :).\n";
+        }
+        $amount =~ s/,/./g;
+        if ($amount > 999) {
+            die "That's way too much money, or an unknown barcode.\n";
+        }
+        return 0 + $amount;
+    };
+    *{"$caller\::call_hooks"} = \&RevBank::Plugins::call_hooks;
+    *{"$caller\::say"} = sub {
+        print @_, "\n";
+    };
+    *{"$caller\::now"} = sub {
+        return strftime '%Y-%m-%d_%H:%M:%S', localtime;
+    };
+
+}
+
+1;
+__END__
+
+=head1 NAME
+
+RevBank::Global - Constants and utility functions
+
+=head1 SYNOPSIS
+
+    use RevBank::Global;
+
+=head1 DESCRIPTION
+
+This module unconditionally exports the following symbols into the calling
+namespace:
+
+=head2 ACCEPT, ABORT, REJECT, NEXT, DONE
+
+Return codes for plugins. See L<RevBank::Plugins>.
+
+=head2 say
+
+Print with newline, in case your Perl version doesn't already have a C<say>.
+
+=head2 call_hooks($hook, @arguments)
+
+See C<call_hooks> in L<RevBank::Plugins>.
+
+=head2 parse_amount($amount)
+
+Returns the amount given if it is well formed, undef if it was not. Dies if
+the given amount exceeds certain boundaries.
+
+Commas are changed to periods so C<3,50> and C<3.50> both result in C<3.5>.
+
+=head2 parse_user($username)
+
+See C<parse_user> in L<RevBank::Users>.
+
+Returns the canonical username, or undef if the account does not exist.
+
+=head1 AUTHOR
+
+Juerd Waalboer <#####@juerd.nl>
+
+=head1 LICENSE
+
+Pick your favourite OSI license.

lib/RevBank/Messages.pm

@@ -0,0 +1,60 @@
+package RevBank::Messages;
+use RevBank::Global;
+use base 'RevBank::Plugin';
+
+# Don't edit this file just to change the messages. Instead, RTFM and define
+# your own hooks.
+
+BEGIN {
+    RevBank::Plugins::register("RevBank::Messages");
+}
+
+sub command { return NEXT; }
+sub id { 'built in messages' }
+
+sub hook_startup {
+    say "\e[0m\n\n\nWelcome to the RevBank Shell, version $::VERSION\n";
+}
+
+sub hook_plugin_fail {
+    my ($class, $plugin, $error) = @_;
+    warn "Plugin '$plugin' failed: $error\n";
+}
+
+sub hook_cart_changed {
+    my ($class, $cart) = @_;
+    $cart->size or return;
+    $cart->display("    ");
+    say "Enter username to pay/finish or 'abort' to abort.\n";
+}
+
+sub hook_abort {
+    my ($class, $cart) = @_;
+    say "\e[1;4mABORTING TRANSACTION.\e[0m";
+}
+
+sub hook_invalid_input {
+    my ($class, $cart, $word) = @_;
+    say "$word: No such product, user, or command.";
+}
+
+sub hook_reject {
+    my ($class, $plugin, $reason, $abort) = @_;
+    say $abort ? $reason : "$reason Enter 'abort' to abort.";
+}
+
+sub hook_user_balance {
+    my ($class, $username, $old, $delta, $new) = @_;
+    my $sign = $delta >= 0 ? '+' : '-';
+    my $rood = $new < 0 ? '31;' : '';
+    printf "New balance for %s: %+.2f %s %.2f = \e[${rood}1m%+.2f\e[0m %s\n",
+        $username, $old, $sign, abs($delta), $new,
+        ($new < -13.37 ? "\e[5;1m(!!)\e[0m" : "");
+}
+
+sub hook_user_created {
+    my ($class, $username) = @_;
+    say "New account '$username' created.";
+}
+
+1;

lib/RevBank/Plugin.pm

@@ -0,0 +1,20 @@
+package RevBank::Plugin;
+use strict;
+
+sub new {
+    my ($class) = @_;
+    return bless { }, $class;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+RevBank::Plugin - Base class for RevBank plugins
+
+=head1 DESCRIPTION
+
+Documentation on writing plugins is at L<RevBank::Plugins>.

lib/RevBank/Plugins.pm

@@ -0,0 +1,289 @@
+package RevBank::Plugins;
+use strict;
+use RevBank::Eval;
+use RevBank::Plugin;
+use Exporter;
+our @EXPORT = qw(call_hooks load_plugins);
+
+my @plugins;
+
+sub _read_file {
+    local (@ARGV) = @_;
+    readline *ARGV;
+}
+
+sub call_hooks {
+    my $hook = shift;
+    my $method = "hook_$hook";
+    for my $class (@plugins) {
+         $class->$method(@_) if $class->can($method);
+    }
+};
+
+sub register {
+    call_hooks("register", $_) for @_;
+    push @plugins, @_;
+}
+
+sub load {
+    my @config = _read_file('revbank.plugins');
+    chomp @config;
+    s/#.*//g for @config;
+    @config = map /(\S+)/, grep /\S/, @config;
+
+    for my $name (@config) {
+        my $fn = "plugins/$name";
+        my $package = "RevBank::Plugin::$name";
+        if (not -e $fn) {
+            warn "$fn does not exist; skipping plugin.\n";
+            next;
+        }
+        RevBank::Eval::clean_eval(qq[
+            use strict;
+            package $package;
+            BEGIN { RevBank::Global->import; }
+            our \@ISA = qw(RevBank::Plugin);
+            our \%ATTR;
+            sub MODIFY_CODE_ATTRIBUTES {
+                my (\$class, \$sub, \@attrs) = \@_;
+                \$ATTR{ \$sub } = "\@attrs";
+                return;
+            }
+            sub FETCH_CODE_ATTRIBUTES {
+                return \$ATTR{ +pop };
+            }
+            sub HELP {
+                \$::HELP{ +shift } = +pop;
+            }
+            sub id { '$name' }
+        ] . "\n#line 1 $fn\n" . join "", _read_file($fn));
+
+        if ($@) {
+            call_hooks("plugin_fail", $name, "Compile error: $@");
+            next;
+        }
+        if (not $package->can("command")) {
+            warn "Plugin $name does not have a 'command' method; skipping.\n";
+            next;
+        }
+
+        register $package;
+    }
+}
+
+sub new {
+    return map $_->new, @plugins;
+}
+
+1;
+__END__
+=head1 NAME
+
+RevBank::Plugins - Plugin mechanism for RevBank
+
+=head1 DESCRIPTION
+
+RevBank itself consists of a simple command line interface and a really brain
+dead shopping cart. All transactions, even deposits and withdrawals, are
+handled by plugins.
+
+Plugins are defined in the C<revbank.plugins> file. Each plugin is a Perl
+source file in the C<plugins> directory. Plugins are always iterated over in
+the order they were defined in.
+
+=head2 Methods
+
+=head3 RevBank::Plugins::load
+
+Reads the C<revbank.plugins> file and load the plugins.
+
+=head3 RevBank::Plugins->new
+
+Returns a B<list> of fresh plugin instances.
+
+=head3 RevBank::Plugins::register($package)
+
+Registers a plugin.
+
+=head3 RevBank::Plugins::call_hooks($hook, @arguments)
+
+Calls the given hook in each of the plugins. Non-standard hooks, called only
+by plugins, SHOULD be prefixed with the name of the plugin, and an underscore.
+For example, a plugin called C<cow> can call a hook called C<cow_moo> (which
+calls the C<hook_cow_moo> methods).
+
+There is no protection against infinite loops. Be careful!
+
+=head1 WRITING PLUGINS
+
+    *** CAUTION ***
+    It is the responsibility of the PLUGINS to verify and normalize all
+    input. Behaviour for bad input is UNDEFINED. Weird things could
+    happen. Always use parse_user() and parse_amount() and test the
+    outcome for defined()ness. Use the result of the parse_*() functions
+    because that's canonicalised.
+
+    Don't do this:
+        $cart->add($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 :)');
+
+There are two kinds of plugin methods: input methods and hooks. A plugin MUST
+define one C<command> input method (but it MAY be a no-op), and can have any
+number of hooks.
+
+=head2 Input methods
+
+Whenever a command is given in the 'outer' loop of revbank, the C<command>
+method of the plugins is called until one of the plugins returns either
+C<ACCEPT> or C<DONE>. An input method receives three arguments: the plugin
+object, the shopping cart, and the given input string. The plugin object
+(please call it C<$self>) is temporary but persists as long as your plugin
+keeps control. It can be used as a scratchpad for carrying over values from
+one method call to the next.
+
+A command method MUST return with one of the following statements:
+
+=over 10
+
+=item return NEXT;
+
+The plugin declines handling of the given command, and revbank should proceed
+with the next one.
+
+Input methods other than C<command> MUST NOT return C<NEXT>.
+
+=item return REJECT, "Reason";
+
+The plugin decides that the input should be rejected for the given reason.
+RevBank will either query the user again, or (if there is any remaining input
+in the buffer) abort the transaction to avoid confusion.
+
+=item return ABORT, "Reason";
+
+=item return ABORT;
+
+The plugin decides that the transaction should be aborted.
+
+=item return ACCEPT;
+
+The plugin has finished processing the command. No other plugins will be called.
+
+=item return "Prompt", $method;
+
+The plugin requires arguments for the command, which will be taken from the
+input buffer if extra input was given, or else, requested interactively.
+
+The given method, which can be a reference or the name of the method, will be
+called with the given input.
+
+The literal input string C<abort> is a hard coded special case, and will
+never reach the plugin's input methods.
+
+=back
+
+=head2 Hooks
+
+Hooks are called at specific points in the processing flow, and MAY introspect
+the shopping cart. They SHOULD NOT manipulate the shopping cart, but this option
+is provided anyway, to allow for interesting hacks. If you do manipulate the
+cart, re-evaluate your assumptions when upgrading!
+
+Hooks SHOULD NOT prompt for input or execute programs that do so.
+
+A plugin that exists only for its hooks, MUST still provide a C<command> method.
+The suggested implementation for a no-op C<command> method is:
+
+    sub command {
+        return NEXT;
+    }
+
+Hooks are called as class methods. The return value is ignored. Hooks MUST NOT
+interfere with the transaction flow (e.g. abort it).
+
+The following hooks are available, with their respective arguments:
+
+=over 10
+
+=item hook_register $class, $plugin
+
+Called when a new plugin is registered.
+
+=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
+
+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
+
+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
+
+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.
+
+C<$item> is a reference to a hash with the keys C<amount>, C<description> and
+the metadata given in the C<add> call. Changing the values changes the actual
+item going into the cart!
+
+Be careful to avoid infinite loops if you add new stuff.
+
+=item hook_checkout $class, $cart, $user, $transaction_id
+
+Called when the transaction is finalized.
+
+=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
+
+Called when input was not recognised by any of the plugins.
+
+=item hook_plugin_fail $class, $plugin, $error
+
+Called when a plugin fails.
+
+=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
+
+Called when a user account is updated.
+
+=back
+
+Default messages can be silenced by overriding the hooks in
+C<RevBank::Messages>. Such a hack might look like:
+
+    undef &RevBank::Messages::hook_abort;
+
+    sub hook_abort {
+        print "This message is much better!\n"
+    }
+
+=head2 Utility functions
+
+Several global utility functions are available. See L<RevBank::Global>
+
+=head1 AUTHOR
+
+Juerd Waalboer <#####@juerd.nl>
+
+=head1 LICENSE
+
+Pick your favorite OSI license.
+

lib/RevBank/Users.pm

@@ -0,0 +1,70 @@
+package RevBank::Users;
+use strict;
+use RevBank::Global;
+use RevBank::Plugins;
+
+my $filename = "revbank.accounts";
+
+sub _read {
+    my @users;
+    open my $fh, $filename or die $!;
+    /\S/ and push @users, [split " "] while readline $fh;
+    close $fh;
+    return { map { lc($_->[0]) => $_ } @users };
+}
+
+sub names {
+    return map $_->[0], values %{ _read() };
+}
+
+sub balance {
+    my ($name) = @_;
+    return _read()->{ lc $name }->[1];
+}
+
+sub create {
+    my ($username) = @_;
+    open my $fh, '>>', $filename or die $!;
+    my $now = now();
+    print {$fh} "$username 0.00 $now\n" or die $!;
+    close $fh or die $!;
+    RevBank::Plugins::call_hooks("user_created", $username);
+}
+
+sub update {
+    my ($username, $delta, $transaction_id) = @_;
+    open my $in,  'revbank.accounts' or die $!;
+    open my $out, ">.revbank.$$" or die $!;
+    my $old;
+    my $new;
+    while (defined (my $line = readline $in)) {
+        my @a = split " ", $line;
+        if (lc $a[0] eq lc $username) {
+            $old = $a[1];
+            $new = $old + $delta;
+            printf {$out} "%-16s %+9.2f %s",
+                $username, $new, now() or die $!;
+            print {$out} "\n" or die $!;
+        } else {
+            print {$out} $line or die $!;
+        }
+    }
+    close $out or die $!;
+    close $in;
+    rename ".revbank.$$", "revbank.accounts" or die $!;
+
+    RevBank::Plugins::call_hooks(
+        "user_balance", $username, $old, $delta, $new, $transaction_id
+    );
+}
+
+sub parse_user {
+    my ($username) = @_;
+    my $users = _read();
+    return undef if not exists $users->{ lc $username };
+    return $users->{ lc $username }->[0];
+}
+
+1;
+
+