Compare commits

..

No commits in common. "master" and "nofloat" have entirely different histories.

111 changed files with 1209 additions and 5807 deletions

View file

@ -1,78 +0,0 @@
## Installing RevBank
1. Install the dependencies:
```
Debian: apt install libterm-readline-gnu-perl libcurses-ui-perl
Generic: cpan Term::ReadLine::Gnu Curses::UI
```
2. Clone the repository, run `./revbank` :)
## Configuring RevBank
`revbank` uses data files from the _working directory_ from which it runs. You
can use that to your advantage, if you don't want to change anything in your
git working tree - in that case, copy `revbank.*` to the intended working
directory, and symlink `plugins`. But you can also just change the files and
deal with merge conflicts later, if you prefer.
**RevBank just works out of the box** if you're in a hurry, but there's a lot you
could customize.
### Pick a transaction ID scheme
If you skip this step, RevBank will use a large timestamp as a safe fallback.
You can use any string that Perl can increment with the ++ operator:
```sh
# Simple, recommended:
echo 1 > .revbank.nextid
# or
echo 00001 > .revbank.nextid
# or
echo AAAA > .revbank.nextid
```
This should be done only once. RevBank will increment the number. If you do
wish to start a new sequence, you should clear `.revbank.undo` first if there
is any chance that the sequences will overlap.
(Note: letters in transaction IDs are supported, but may not be compatible with
local laws or external accounting software.)
### Other configuration
- `revbank.plugins`: enable or disable plugins here.
- `revbank.accounts`: if you're migrating from another system, you can add the
existing account balances here. Only the first two columns are mandatory
(account name and balance). Editing the accounts file when revbank is in
active use is not recommended because you might overwrite the effect of the
latest transactions, but you can maybe get away with it if you're fast
enough.
- `revbank.products`: list your products here; the first column is a comma
separated (no space after the comma!) list of product codes. Only the
description makes it into the logs so make it sufficiently unique.
- `plugins/deposit_methods`: if you want to enable this plugin (which is highly
recommended!), at least change the bank account number. When customizing
plugins, you can either copy the file and use your own, or edit the existing
file and deal with merge conflicts later. Either way you'll have to pay
attention to changes when upgrading.
After changing `revbank.plugins` or any of the actual plugin files, you'll need
to restart `revbank`. This is done with the `restart` command, unless the
corresponding plugin was disabled. No restart is required after editing
`revbank.products`, `revbank.market`, or `revbank.accounts`.
If your terminal is unable to beep, e.g. if it's Linux console on a Raspberry
Pi, copy the `beep_terminal` plugin to a new file, and figure out another way
to play a sound or make a light flash. This is optional, but in general it's
useful to have something that alerts users to the mistakes they make. An
audible bell works better than a visual effect, but why not both?
### Cash box
If you want RevBank to indicate how much money it thinks the cash box should
contain after every cash transaction, you'll probably want to enable the
plugins `deposit_methods`, `cash`, and `skim`.

View file

@ -1,3 +0,0 @@
Pick your favourite OSI approved license :)
http://www.opensource.org/licenses/alphabetical

View file

@ -1,51 +1,24 @@
# revbank - Banking for hackerspace visitors
## Installing RevBank
## Upgrading
For new installations, refer to [INSTALLING.md](INSTALLING.md).
When upgrading from a previous version, please refer to the file `UPGRADING.md`
because there might be incompatible changes that require your attention.
## Upgrading RevBank
## Installing
When upgrading from a previous version, please refer to the file
[UPGRADING.md](UPGRADING.md) because there might be incompatible changes that
require your attention.
1. Install the Perl module Term::ReadLine::Gnu
## Using RevBank (for end users)
```
Debian: apt install libterm-readline-gnu-perl
Generic: cpan Term::ReadLine::Gnu
```
Type `help`.
2. Clone the repository, run revbank :)
### Exiting revbank
Exiting is not supported because it's designed to run continuously on its main
terminal. But if you run it from a shell, you can probably stop it using ctrl+Z
and then kill the process (e.g. `kill %1`). RevBank does not keep any files
open, so it's safe to kill when idle.
## Documentation
End-user documentation is provided through the `help` command. For RevSpace
visitors, some additional end-user documentation is available in Dutch at
https://revspace.nl/RevBank.
RevBank can be used without RTFM, but some documentation is provided to
describe the inner workings in more detail:
- [RevBank](lib/RevBank.pod) - technical overview
- [RevBank::Amount](lib/RevBank/Amount.pod) - fixed decimal numbers
- [RevBank::FileIO](lib/RevBank/FileIO.pod) - reading and writing files
- [RevBank::Global](lib/RevBank/Global.pod) - constants and utility functions
- [RevBank::Plugins](lib/RevBank/Plugins.pod) - writing plugins
- [RevBank::Products](lib/RevBank/Products.pod) - revbank.products file format
- [RevBank::TextEditor](lib/RevBank/TextEditor.pod) - internal pager and editor
- [RevBank::Users](lib/RevBank/Users.pod) - user accounts and special accounts
The plugins are mostly undocumented, but some have useful hints in the source
files, and some have actual documentation:
- [statiegeld](plugins/statiegeld.pod)
- [statiegeld\_tokens](plugins/statiegeld_tokens.pod)
- [vat](plugins/vat.pod)
> Note: internal links between POD files are all broken in GitHub's rendering,
> because GitHub wrongly assumes that every Perl package lives on CPAN.
## Exiting revbank
Exiting is not supported because it's desigend to run continuously. But if you
run it from a shell, you can probably stop it using ctrl+Z and then kill the
process (e.g. `kill %1`). RevBank does not keep any files open, so it's safe
to kill when idle.

View file

@ -1,562 +1,3 @@
# Upgrade procedure
1. Stop any running `revbank` instances, or at least make sure nobody will be
using RevBank during the upgrade.
2. **Make a backup** of your RevBank data and code repo(s).
3. Read this file :) to see if you need to change anything. Check your current
version and read everything pertaining to newer versions, from oldest to newest (top).
4. Use `git pull --rebase` in the right directory. Don't ignore its output,
because you may need to manually resolve merge conflicts.
5. (Re)start `revbank`. If the old version was still running, use the `restart`
command before issuing any other commands.
The standard deprecation cycle is 2 years. **It is recommended that you upgrade
RevBank at least once a year.**
While you're at it, upgrade the rest of your system too. RevBank currently
supports Perl versions down to 5.32 (2020), which is in Debian 11 "bullseye"
(oldstable). Once Debian 13 "trixie" is released as stable (expected in 2025)
and 12 "bookworm" becomes the new oldstable, RevBank will begin to require Perl
5.36 (2022).
# (2024-12-26) RevBank 8.0.0
Another breaking change, another major version upgrade due to semantic versioning!
## Breaking change:
This is very unlikely to affect anyone, but still: `percent` addons (like
discounts) applied by `read_products` now have the calculated price in
`->{price}`, and the percent amount was moved to `->{percent}`, which was
previously just a boolean.
This change has had no deprecation cycle because I don't think anyone would be
using this in custom code. But if you did use this feature in a custom plugin
(wow, I really want to know all about it!), just change `price` to `percent`
where appropriate.
## Non-breaking changes:
* `RevBank::Plugins::products::read_products` was moved to
`RevBank::Products::read_products`, but the old symbol still works.
* `read_products` gained some additional features, such as price tag
calculations. Top-level products now have `->{tag_price}`, `->{hidden_fees}`,
and `->{total_price}` in addition to the existing base price which is still
in `->{price}`.
* Because `read_products` is now in a module, you can `use RevBank::Products;`
in your own scripts so you don't have to write your own parser for
`revbank.products` anymore. (Don't forget to `use lib "path/to/lib";` first!)
The calculated tag prices are not displayed anywhere in RevBank, but meant for
an upcoming feature which is to generate images for electronic price tags. To
exclude addon prices from the price tag (as is customary with
statiegeld/pfand/deposits), add the new `#OPAQUE` hashtag to the respective
addon lines in `revbank.products`.
## Deprecation announcement
* Support for the old file format for `revbank.products` will be removed in
2026. The new format was introduced in 6.0.0 in January 2024, but the old
format still works (and it gives a lot of warnings if you use it). See below
for how to update your products file.
* The plugin `deprecated_raw` will be removed after February 2025. This plugin
warns tells users to use `withdraw` or `unlisted` instead of a raw amount,
after support for that was dropped in 3.3 in June 2022.
# (2024-11-17) RevBank 7.1.0
The new plugin `nomoney` is enabled by default. For rationale, see
https://forum.revspace.nl/t/inkoopacties-via-revbank/469.
Whether this constitutes a breaking change is debatable, and it wasn't added to
this file until 2025-03-06. It's a new feature, but the feature is to disallow
some transactions which used to be allowed. (Specifically, it denies
transactions if the user has insufficient balance; by default only for
give/take/withdraw, but the list of affected plugins can be customized.)
# (2024-10-18) RevBank 7.0.0
Support for unbalanced entries has been removed, ensuring a pure double-entry
bookkeeping system. Grep your log for the string `UNBALANCED` if you're not
sure that all your custom plugins are already well-behaved. Note that since
unbalanced transactions are no longer supported, transactions from before that
change can't be reverted with `undo`.
There are no other changes in this version.
Since all transactions are now balanced, the sum of all the balances is
`revbank.accounts` will remain fixed forever. It is recommended to make that
sum equal to `0.00` (only once) by adding a dummy account which acts a
retroactive opening balance:
```sh
perl -Ilib -MRevBank::Amount -lane'$sum += RevBank::Amount->parse_string($F[1])
}{ printf "-deposits/balance %s\n", -$sum if $sum;' revbank.accounts >> revbank.accounts
```
From that point forward, the sum of all the values in the second column of the
`revbank.accounts` file should forever be 0.00; if it's not, either someone
tampered with the file or there is data corruption, and the cause should be
investigated and corrected.
```sh
perl -Ilib -MRevBank::Amount -lane'$sum += RevBank::Amount->parse_string($F[1])
}{ print $sum' revbank.accounts
```
# (2024-01-20) RevBank 6.0.0
Note that the changes to `revbank.products` do NOT apply to `revbank.market`
and other files.
## Update your `revbank.products` file
TL;DR: Product descriptions now need `"quotes"` around them.
This version comes with breaking changes to the `revbank.products` syntax, to
expand the capabilities of the file in a more future-proof way. Bitlair
(Hackerspace Amersfoort) has requested a way to add metadata to products for
automation, which together with recent other additions to the format, made
clear a more structured approach was needed.
The line format for the products file is now like the input format of the
command line interface. This means that if product descriptions contain spaces,
as they typically do, quotes are needed around them. You can pick between
`"double"` and `'single'` quotes. Any backslashes and quotes within the same
kind of quotes need escaping by adding a `\` in front, e.g. `\"` and `\\`.
```
# Old format:
product_id 0.42 Can't think of a good description +addon1 +addon2
# New format, recommended style:
product_id 0.42 "Can't think of a good description" +addon1 +addon2
# Automatically generated? You may wish to quote all fields:
"product_id" "0.42" "Can't think of a good description" "+addon1" "+addon2"
# Escaping also works:
product_id 0.42 Can\'t\ think\ of\ a\ good\ description +addon1 +addon2
```
To convert your `revbank.products` file to the recommended style automatically,
you could use:
```sh
# The following is one command. It was obviously not optimized for readability :)
perl -i.backupv6 -ple'unless (/^\s*#/ or /^\s*$/) {
my ($pre, $desc) = /(^\s*\S+\s+\S+\s*)(.*)/; $pre .= " " if $pre !~ /\s$/;
my @a; unshift @a, $1 while $desc =~ s/\s\+(\S+)$//;
$desc =~ s/([\"\\])/\\$1/g; $_ = "$pre\"$desc\"";
for my $a (@a) { $_ .= " +$a" }
}' revbank.products
```
Note that this will leave commented lines unchanged! If those contain disabled
products, you'll have to add the quotes yourself.
## New feature: hashtags in `revbank.products`
After the description field, you can add hashtag fields. These begin with `#`
and may take the form of a lone `#hashtag`, or they may be used as a
`#key=value` pair. The hashtags can be read by plugins. Out of the box, they
currently do nothing.
```
8711327538481 0.80 "Ola Liuk" #ah=wi162664 #q=8
8712100340666 0.45 "Ola Raket" #ah=wi209562 #q=12
5000112659184,5000112658873 0.95 "Coca-Cola Cola Zero Sugar (33 cl)" #sligro +sb
# equivalent:
"8711327538481" "0.80" "Ola Liuk" "#ah=wi162664" "#q=8"
```
See https://github.com/bitlair/revbank-inflatinator/ for a possible use of adding metadata.
# (2023-12-26) RevBank 5.0.0
This version comes with breaking changes to the command line syntax, to shield
overconfident users of the interface for advanced users from several classes of
common mistakes, and to add support for quoted and escaped strings to this
interface.
Basically, you can now use `;` to separate multiple commands on a single line
of input, and in some cases this is mandatory.
## Limited set of characters allowed in usernames and product IDs
Historically, RevBank has allowed almost every character as a valid character,
because it wasn't known if these would show up in barcodes. In more than 13
years of real world use, though, it seems that barcodes and usernames with
"special" characters are incredibly uncommon.
Since `' " \ ;` now have special meanings, they are no longer supported in
product IDs. In theory, they could be quoted or escaped, but barcode scanners
don't know that. Existing users with those characters in their names can
continue to use their accounts by quoting or escaping them.
New usernames must now only contain the characters from the set
`A-Z a-z 0-9 _ - + / ^ * [] {}` and the first character must not be any of
`- + / ^ *`.
## Update scripts that run revbank commands
When providing multiple commands on a single line, RevBank now requires a
separating `;` after commands that finalize transactions, and after commands
that take arguments.
End-users are guided interactively to deal with the change, but automated
commands require changing. Specifically, add a `;` between a multi-word command
and the final username (e.g. `give *lasercutter 10; xyzzy`) and in between
transactions.
## Update your custom plugins
* The undocumented feature `ROLLBACK_UNDO` is gone. Use `return ABORT` in a
function called `hook_undo` instead.
* Plugins are now evaluated with an implicit `use v5.32;` which enables many
new Perl features and disables some old ones. Specifically, the old-style
"indirect object notation" is disabled, which means that `new Foo(...)`
should be rewritten as `Foo->new(...)`.
* `$cart->checkout` now throws an exception if there is unprocessed input in
the queue (the user can use `;` if it was intentional). There were always
reasons a checkout could fail, but now it is much more likely. Things that
should only happen if the checkout succeeds, should be put *after* the call,
or in a hook.
# (2023-11-05) RevBank 4.2.0
Accounts that begin with `*` are now special: like hidden accounts, they do not
count towards the grand total, but unlike hidden accouns, they can be used as
normal user accounts too.
The intended application is for liabilities accounts that are also used
directly for revenues and expenses.
They can be used with or without the `*` prefix, e.g. the account
`*lasercutter` can also be used as `lasercutter`. Such accounts cannot be
created from within the software: to create a user-accessible special account,
you need to edit `revbank.accounts` manually.
When upgrading, check that no accounts beginning with `*` already exist.
# (2023-09-20) RevBank 4.0.0
## You must pick a transaction ID style
Transaction IDs are now sequential for better auditability. In previous
versions, they were timestamps (unix time minus 1.3e9).
Because of this change, you must restart *every* running RevBank instance or
else the transaction IDs will no longer be monotonic between processes, which
would be bad.
You should choose which transaction IDs you want, and write your choice to a
file called `.revbank.nextid`.
### Option 1: continue with large IDs but increment by 1 from now on
**If you don't write a `.revbank.nextid` file,** RevBank will create one for
you, but you might not like it. It will generate one more timestamp based ID
and then increment that for subsequent transactions. This has the advantage of
not having the one-time break of monotonicity, but you will be stuck with the
long IDs and they will no longer convey time information.
### Option 2: beginning a new sequence
Anything that works with Perl's `++` operator will work, and that gives a few
options. If you want to start over with transaction ID **1**, write that to the
file:
```sh
echo 1 > .revbank.nextid
```
You can also use padding zeroes if you like. They will safely overflow to use
an extra digit after all-nines is reached:
```sh
echo 00001 > .revbank.nextid
```
(You can also use alphanumeric IDs, but I'm not sure if you should.)
Or, if you still have all the logs from since you started using RevBank, you
can pretend RevBank has always had simple incremental transaction IDs and use
the number of distinct transaction IDs from the log file as the basis for the
next ID:
```sh
# This is my personal preference
perl -lane'BEGIN { $max = time() - 1.3e9 }
/^\d+$/ and $_ > 0 and $_ < $max and $x{$_}++ for @F[1, 2];
}{ print 1 + keys %x' .revbank.log > .revbank.nextid
# Note: use multiple filenames (e.g. .revbank.log*) if you rotate log files
# (like when you have yearly logs).
```
This is safe because the timestamp based IDs were huge and are unlikely to
overlap at least the next few decades.
### Option 3: keeping the legacy transaction ID scheme (for now)
Finally, for those who really don't want to change the scheme now, the old
system can be retained by writing the special-cased value `LEGACY`. This
feature will be supported at least until 2024-01-01, but might be removed after
if nobody tries to convince me otherwise.
```sh
echo LEGACY > .revbank.nextid
```
## Update `revbank.plugins`
There are a few new plugins that you may wish to enable. Some have been around
longer than RevBank 3.9, but haven't been mentioned in UPGRADING.md before.
### `vat`
Automatically calculate and set aside VAT ("BTW" in Dutch) on generated
revenue. You will probably not need this. Before enabling this plugin, read the
documentation in `plugins/vat.pod` first.
### `regex_gtin`
To support GS1 Digital Links and other GS1 barcodes. The DL are a new way for
QR codes that contain product IDs and other metadata while also being usable
for promotional stuff. At least one popular brand of soft drinks is already
using them. There's a huge standard that describes these codes, but basically,
they're URLs with /01/ and a 14-digit product ID in them. Enabling this plugin
is probably useful and harmless; add it to `revbank.plugins` *after* plugins
that deal with product IDs like `products` and `market`.
### `regex_angel`
Replaces custom SHA2017/MCH2022 angel badge hacks. Add after `users` in
`revbank.plugins` after removing your custom plugin for `angel-` barcodes.
### `adduser_note`
Add *before* `adduser` in `revbank.plugins`. This will inform new users that
RevBank is insecure by design and what implications that can have. Enabling
this plugin is recommended.
### `statiegeld` and `statiegeld_tokens`
Charge and refund container deposit return ("statiegeld" in Dutch). Read the
documentation in `plugins/statiegeld.pod` and `plugins/statiegeld_tokens.pod`
for instructions.
### `cash_drawer`
If you have an electronic cash drawer, copy or change this plugin and add code
to trigger it whenever something is done that involves cash.
## Deprecation note
RevBank has supported "doubly entry bookkeeping" since version 3.4 last year.
For backwards compatibility with custom plugins, support for unbalanced
transactions was retained.
Support for unbalanced transactions will be removed after 2024-06-10, after a
period of 2 years after the introduction of balanced transactions. If you're
using custom plugins, grep your log file for the text "UNBALANCED ENTRY" to see
if changes are needed.
# (2023-08-21) RevBank 3.9
A tiny change that could break things: the shebang was changed from
`#!/usr/bin/perl` to the more modern `#!/usr/bin/env perl`.
In the unlikely event that your system has multiple perl executables in the
search path of `PATH`, this change could mean that revbank now uses a different
perl, in which case you may have to reinstall the required Perl libraries.
Background: NixOS doesn't follow the previously uni(x)versal convention that,
when Perl is available, an executable exists at `/usr/bin/perl`. The only
stable paths that NixOS provides for shebangs are `#!/bin/sh` or
`#!/usr/bin/env`. There were always pros and cons to switching the shebang to
`env` (e.g. for use with perlbrew), but learning about Nix has tipped the
scales for me. (The performance penalty is not relevant for RevBank.)
# (2023-02-12) RevBank 3.8
## Update your `revbank.plugins`
Deduplication is moved from individual plugins to a plugin that does that. If
you want to keep deduplication of cart items, and you probably do want that,
add `deduplicate` to `revbank.plugins` just below `repeat`.
The deprecation warning was moved from the `withdraw` plugin to a new plugin
called `deprecated_raw`. If you're upgrading from an older versions and some of
your users have been around since before the withdraw/unlisted split, you may
want to keep the deprecation warning. But for new RevBank installations it does
not make sense. To keep providing these warnings to users that enter raw
amounts, add `deprecated_raw` to the very end of `revbank.plugins`.
# (2022-12-25) RevBank 3.6
## Update your `revbank.plugins`
The `edit` command is now in its own plugin, so that it can be disabled (this
has been requested several times). To keep the ability to edit the products
list from within RevBank, add `edit` to `revbank.plugins`.
## Check your `revbank.products`
> Added 2024-01-20 v6.0.0: if you're upgrading to v6.0.0 from a version before
> v3.6, instead of following these instructions, you can just add quotes to the
> descriptions (when using the perl oneliner from the v6.0.0 upgrade
> instructions, check if any `+something` that got placed outside of the quotes
> should have been within the quotes.)
~~There's new syntax for `revbank.products`: addons. Check that your lines don't
have `+foo` at the end, where `foo` can be anything.~~
~~Also check that you don't have any product ids that start with `+`; those can
no longer be entered as this syntax now has special semantics.~~
~~So these don't work as before:~~
example_id 1.00 Example product +something
+something 1.00 Product id that starts with plus
example,+alias 1.00 Alias that starts with plus
~~These will keep working as they were:~~
example_id1 1.00 Example product+something
example_id2 1.00 Example product + something
more_stuff 1.00 Example product with +something but not at the end
bbq 1.00 3+ pieces of meat
## New features in `products` plugin
There are several new features that you may wish to take advantage of. By
combining the new features, powerful things can be done that previously
required custom plugins.
The syntax for `revbank.products` has become complex. Please refer to the new
documentation in [products.pod](plugins/products.pod) for details.
### Negative prices (add money to account)
Support for non-positive prices was requested several times over the years and
has now finally been implemented.
It's now possible to have a product with a negative amount, which when "bought"
will cause the user to receive money instead of spending it.
### Product addons
It is now possible to add products to products, which is done by specifying
`+foo` at the end of a product description, where `foo` is the id of another
product. This can be used for surcharges and discounts, or for bundles of
products that can also be bought individually.
### Explicit contra accounts
By default, products sold via the `products` plugin, are accounted on the
`+sales/products` contra account. This can now be overridden by specifying
`@accountname` after the price in `revbank.products`. For example,
`1.00@+sales/products/specificcategory`. While this will mess up your tidy
columns, you may be able to get rid of a bunch of custom plugins now.
When the specified contra account is a regular account (does not start with `+`
or `-`), this works similar to the `market` plugin, but without any commission
for the organization.
## Pfand plugin: gone
The `pfand` plugin, that was originally written as a proof-of-concept demo, has
been removed without deprecation cycle. To my knowledge, nobody uses this
plugin. If you did use it, just grab the old version from git. Please let me
know about your usecase!
The introduction of beverage container deposits in The Netherlands has
triggered reevaluation, and several things about that plugin were wrong,
including the condescending comments that bottle deposits for small bottles
would be crazy or wouldn't make sense in a self-service environment. RevBank
was too limited to support it properly, but I think current RevBank fulfills
all requirements for making a better, proper pfand plugin.
## Perl warnings are now enabled for plugins
If you get Perl warnings from a plugin, and don't want to fix the issues with
the code (or disagree with the warning), just add "no warnings;" to the top of
the plugin file. However, the warnings are often indicative of suboptimal code
that is ground for improvement!
Most warnings will be about unitialized (undefined) values. Some guidance for
Perl newbies: you can test whether something is defined with `if
(defined($foo)) { ... }`, or provide a default value with `$foo // "example
default value"`.
# (2022-08-30) RevBank 3.5
RevBank now has a simple built-in text editor for products and market;
rationale in lib/RevBank/TextArea.pod.
This comes with a new dependency, the perl module Curses::UI (debian:
libcurses-ui-perl).
# (2022-06-11) RevBank 3.4
RevBank now has built-in hidden accounts and balanced transactions
(double-entry bookkeeping). These accounts will be made automatically, and
hidden from the user interface.
## Update external scripts
If you have scripts that parse `.revbank.log` or `revbank.products`, you may
want to ignore all accounts that start with `-` or `+`.
## User account names that are now invalid
In the hopefully very unlikely event that you have existing user accounts that
start with `-` or `+`, those will have to be renamed manually, as such accounts
are no longer accessible.
## Updating custom plugins (optional for now)
For your custom plugins, you may want to add `->add_contra` calls to every
`$cart->add` call that does not already have them. Unbalanced transactions will
probably be deprecated in a future version.
## New feature: cashbox tracking
The new `cash` plugin will display messages about how much the cash box should
hold, whenever someone withdraws or does a cash deposit. For that to make
sense, this requires the `deposit_methods` plugin to be enabled, and to have
a `"cash"` deposit method.
When adding the `cash` plugin in `revbank.plugins`, make sure it is listed
_before_ `stock` if you have that one too. And you probably want to enable
the `skim` plugin too, which introduces the (hidden) commands `skim` and
`unskim` which can be used to keep the cash box data synchronised when someone
(probably a board member) skims it.
# (2022-06-04) RevBank 3.3
Raw amounts without a command are no longer supported. There was already an
explicit command for unlisted products, `unlisted`, and for withdrawals there
is now the new command `withdraw`. An explanatory message guides users who
use the old style towards the new commands.
This change makes it possible for treasurers to more accurately deduce the
intention of a revbank transaction.
When upgrading, make sure the `unlisted` plugin is installed in
`revbank.plugins`. Without it, the instruction text presented when someone
enters an amount is wrong and the functionality for paying for unlisted
products is lost.
# (2021-12-02) RevBank 3.2
## Update your custom plugins!

Binary file not shown.

Before

Width:  |  Height:  |  Size: 308 B

Binary file not shown.

Before

Width:  |  Height:  |  Size: 302 B

Binary file not shown.

Before

Width:  |  Height:  |  Size: 308 B

Binary file not shown.

Before

Width:  |  Height:  |  Size: 607 B

Binary file not shown.

Before

Width:  |  Height:  |  Size: 607 B

View file

@ -1,97 +0,0 @@
Copyright (c) 2010 Dimitar Toshkov Zhekov,
with Reserved Font Name "Terminus Font".
Copyright (c) 2011-2023 Tilman Blumenbach,
with Reserved Font Name "Terminus (TTF)".
This Font Software is licensed under the SIL Open Font License, Version 1.1.
This license is copied below, and is also available with a FAQ at:
http://scripts.sil.org/OFL
-----------------------------------------------------------
SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
-----------------------------------------------------------
PREAMBLE
The goals of the Open Font License (OFL) are to stimulate worldwide
development of collaborative font projects, to support the font creation
efforts of academic and linguistic communities, and to provide a free and
open framework in which fonts may be shared and improved in partnership
with others.
The OFL allows the licensed fonts to be used, studied, modified and
redistributed freely as long as they are not sold by themselves. The
fonts, including any derivative works, can be bundled, embedded,
redistributed and/or sold with any software provided that any reserved
names are not used by derivative works. The fonts and derivatives,
however, cannot be released under any other type of license. The
requirement for fonts to remain under this license does not apply
to any document created using the fonts or their derivatives.
DEFINITIONS
"Font Software" refers to the set of files released by the Copyright
Holder(s) under this license and clearly marked as such. This may
include source files, build scripts and documentation.
"Reserved Font Name" refers to any names specified as such after the
copyright statement(s).
"Original Version" refers to the collection of Font Software components as
distributed by the Copyright Holder(s).
"Modified Version" refers to any derivative made by adding to, deleting,
or substituting -- in part or in whole -- any of the components of the
Original Version, by changing formats or by porting the Font Software to a
new environment.
"Author" refers to any designer, engineer, programmer, technical
writer or other person who contributed to the Font Software.
PERMISSION & CONDITIONS
Permission is hereby granted, free of charge, to any person obtaining
a copy of the Font Software, to use, study, copy, merge, embed, modify,
redistribute, and sell modified and unmodified copies of the Font
Software, subject to the following conditions:
1) Neither the Font Software nor any of its individual components,
in Original or Modified Versions, may be sold by itself.
2) Original or Modified Versions of the Font Software may be bundled,
redistributed and/or sold with any software, provided that each copy
contains the above copyright notice and this license. These can be
included either as stand-alone text files, human-readable headers or
in the appropriate machine-readable metadata fields within text or
binary files as long as those fields can be easily viewed by the user.
3) No Modified Version of the Font Software may use the Reserved Font
Name(s) unless explicit written permission is granted by the corresponding
Copyright Holder. This restriction only applies to the primary font name as
presented to the users.
4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
Software shall not be used to promote, endorse or advertise any
Modified Version, except to acknowledge the contribution(s) of the
Copyright Holder(s) and the Author(s) or with their explicit written
permission.
5) The Font Software, modified or unmodified, in part or in whole,
must be distributed entirely under this license, and must not be
distributed under any other license. The requirement for fonts to
remain under this license does not apply to any document created
using the Font Software.
TERMINATION
This license becomes null and void if any of the above conditions are
not met.
DISCLAIMER
THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE
COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
OTHER DEALINGS IN THE FONT SOFTWARE.

View file

@ -1,272 +0,0 @@
#!/usr/bin/perl
use v5.36;
use autodie;
use FindBin;
use lib "$FindBin::Bin/../lib";
use RevBank::Products;
use Imager;
use Imager::Fill;
use Imager::Font::Wrap;
use LWP::Simple qw($ua);
use JSON::XS ();
my $json = JSON::XS->new;
$ua->timeout(2);
my $resources = "$FindBin::Bin/oepl_resources";
my $outdir = "./oepl_images";
my $ap = 'http://10.42.42.123';
eval { mkdir $outdir };
sub slurp ($fn) { local (@ARGV) = $fn; local $/ = wantarray ? "\n" : undef; <> }
sub spurt ($fn, @data) { open my $fh, '>', $fn; print $fh @data; }
sub post ($uri, $kv) {
for (my $i = 0; $i < @$kv; $i += 2) {
if ($kv->[$i] eq "file") {
$kv->[$i + 1] = [ $kv->[$i + 1], "filename.jpg", Content_Type => "image/jpeg" ];
last;
}
}
my $response = $ua->post("$ap/$uri", Content_Type => 'form-data', Content => $kv);
warn $response->content if not $response->is_success;
return $response->is_success;
}
sub draw ($product, $hwtype, $force) {
my $sub = main->can("draw_hwtype_$hwtype") or do {
warn "Unsupported hwtype ($hwtype)";
return undef;
};
$product->{_fn} = $product->{id} =~ s/([^A-Za-z0-9_])/sprintf("%%%02x", ord $1)/ger;
my $image = $sub->($product);
my $fn = "$outdir/$product->{_fn}\_$hwtype.jpg";
my $old = -e $fn ? slurp($fn) : "";
$image->write(
data => \my $new,
type => "jpeg",
jpegquality => 100, # no underscore
jpeg_optimize => 1,
jpeg_sample => "1x1", # 1x1 = 4:4:4
) or die $image->errstr;
if ($force or $new ne $old) {
spurt $fn, $new if $new ne $old;
return $fn;
}
return undef;
}
sub get_dbitem($mac) {
my $response = $ua->get("$ap/get_db?mac=$mac");
my $hash = eval { $json->decode($response->content) } || { tags => [] };
my $tags = $hash->{tags};
if (@$tags != 1) {
my $status = $response->status_line;
warn "Can't get info for $mac (HTTP $status); new tag not ready yet?\n";
return {};
}
return $tags->[0];
}
sub comma($str) {
"$str" =~ s/\./,/gr =~ s/0/O/gr;
}
sub aztec($product) {
my $fn = "$outdir/$product->{_fn}_aztec.png";
if (not -e $fn) {
system qw(zint --barcode 92 --vers 3 --scale 1 --filetype PNG --nobackground --whitesp 0 --vwhitesp 0), "--data" => $product->{id}, "--output" => $fn;
}
return Imager->new->read(file => $fn) if -e $fn;
}
sub _draw_hwtype_3_4 ($product, $xsize, $ysize, $fontsize, $lineheight) {
# Same design for hwtype 3 and hwtype 4, but on hwtype 4, with larger font.
my @colors = (
my $white = Imager::Color->new(255,255,255),
my $black = Imager::Color->new(0,0,0),
my $red = Imager::Color->new(255,0,0),
);
my $font = Imager::Font->new(file => "$resources/TerminusTTF-Bold-4.49.3.ttf", aa => 0);
# Terminus sizes: 12 14 16 18 20 22 24 28 32
my $is_erase = $product->{id} eq "_ERASE_";
my $is_promo = $product->{tags}{promo};
my $fg = $is_promo ? $white : $black;
my $bg = $is_promo || $is_erase ? $red : $white;
my $image = Imager->new(xsize => $xsize, ysize => $ysize);
$image->setcolors(colors => \@colors);
$image->box(filled => 1, color => $bg);
return $image if $is_erase;
my $addon_text;
my $addon_highlight = 0;
for my $addon (@{ $product->{addons} }) {
next if $addon->{tags}{OPAQUE};
my $d = $addon->{description};
$addon_text = ($addon->{price} < 0) ? $d : "+ $d";
$addon_highlight = 1 if $addon->{price} < 0;
last;
}
my $text = $product->{description};
my (undef, undef, undef, $bottom) = Imager::Font::Wrap->wrap_text(
image => $image,
font => $font,
string => $text,
color => $fg,
justify => "center",
x => 0,
y => 0,
size => $fontsize,
height => ($addon_text ? 3 : 2) * $lineheight,
);
$addon_text and Imager::Font::Wrap->wrap_text(
image => $image,
font => $font,
string => $addon_text,
color => ($addon_highlight ? ($is_promo ? $black : $red) : $fg),
justify => "center",
x => 0,
y => $bottom,
size => $fontsize,
height => (3 * $lineheight) - $bottom,
);
my $xmargin = 6;
my $ymargin = 2;
my $has_discount = $product->{tag_price} < $product->{price};
my $price = sub {
return $image->align_string(
x => $xsize - 1 - $xmargin,
y => $ysize - 1 - $ymargin,
valign => 'bottom',
halign => 'right',
string => comma($product->{tag_price}),
utf8 => 1,
color => ($has_discount ? $white : $white),
font => $font,
aa => 0,
size => 32,
);
};
my @bounds = $price->();
my @box = ($bounds[0] - $xmargin, $bounds[1] - $ymargin, $bounds[2] + $xmargin, $bounds[3] + $ymargin);
$image->box(box => \@box, fill => { solid => ($has_discount ? $red : $black) });
$price->();
if (my $unit = $product->{tags}{ml} ? "ml" : $product->{tags}{g} ? "g" : undef) {
my $X = $unit eq "ml" ? "L" : $unit eq "g" ? "kg" : die;
my $perX = sprintf "%.02f", $product->{tag_price}->float * 1000 / $product->{tags}{$unit};
@bounds = $image->align_string(
x => $box[2],
y => $box[1],
valign => 'bottom',
halign => 'right',
string => comma("$product->{tags}{$unit} $unit $perX/$X"),
utf8 => 1,
color => $fg,
font => $font,
aa => 0,
size => 12,
);
}
# There's place for only 1 but looping over all is easier :)
# Intended purpose is statiegeld logos.
for my $addon (@{ $product->{addons} }) {
my $fn = "$resources/$addon->{id}.png";
-e $fn or next;
my $statiegeld = Imager->new->read(file => $fn);
$image->compose(src => $statiegeld, tx => 63, ty => $ysize - 48 - 1);
}
if (my $aztec = aztec $product) {
$image->compose(src => $aztec, tx => 1, ty => $ysize - 46 - 1);
}
return $image;
}
sub draw_hwtype_3 ($product) {
_draw_hwtype_3_4($product, 212, 104, 18, 18);
}
sub draw_hwtype_4 ($product) {
_draw_hwtype_3_4($product, 296, 152, 28, 30);
}
my @lines = slurp ".revbank.oepl";
my %new_hwtype;
my $products = read_products;
$products->{_NOTFOUND_} = {
id => "_NOTFOUND_",
description => "(product unavailable)",
price => "999.99",
tag_price => "999.99",
};
my $fix_mode = @ARGV && $ARGV[0] eq 'fix';
shift if $fix_mode;
my $erase_mode = !$fix_mode && @ARGV && $ARGV[0] eq 'erase';
shift if $erase_mode;
die "Usage: $0 erase <mac>...\n" if $erase_mode and not @ARGV;
my %fns;
for my $line (@lines) {
my ($mac, $product_id, $hwtype) = split " ", $line;
$mac and $mac =~ /^[0-F]{12,16}$/ or next;
$product_id or next;
(grep { $_ eq $product_id or $_ eq $mac } @ARGV) or next if @ARGV;
my $product = $erase_mode
? { id => "_ERASE_", description => $mac }
: $products->{$product_id} || $products->{_NOTFOUND_};
my $needs_fixing = 0;
if ($fix_mode or not $hwtype) {
my $dbitem = get_dbitem($mac);
next if not %$dbitem;
$hwtype ||= $new_hwtype{$mac} = $dbitem->{hwType};
$needs_fixing = $dbitem->{hash} =~ /^0+$/;
}
my $fn = $fns{$product} ||= draw($product, $hwtype, $needs_fixing || !!@ARGV) or next;
print "Uploading image for $mac ($product->{description}).\n";
post "imgupload" => [ mac => $mac, lut => 1, alias => $product->{description}, file => $fn ];
if ($new_hwtype{$mac}) {
$line =~ s/$/ $new_hwtype{$mac}/;
}
}
if (%new_hwtype) {
spurt ".revbank.oepl", @lines;
}

View file

@ -1,166 +0,0 @@
#!/usr/bin/env perl
=head1 DESCRIPTION
This script translates a RevBank log file to Beancount 2 format, which can then
be used with beancount tools such as the web interface Fava:
perl contrib/revbank-log2beancount.pl > revbank.beancount
fava revbank.beancount
Call this script from the directory that contains C<revbank.accounts> and
C<.revbank.log>. Optionally, a different log file can be given on the command
line, to be used instead of C<.revbank.log>.
=head2 Caveats
This results in an incomplete administration, as RevBank will undoubtedly be
unaware of most expenses, and income through contribution fees. So while the
total numbers (like "net profit") are mostly useless, the numbers for
individual accounts may be insightful, and it provides pretty charts.
RevBank uses datetime with a 1 second resolution, but Beancount 2 only supports
date granularity, so it can't give intradate numbers. The time is recorded as
metadata but otherwise ignored by Beancount; they postings are in the right
order because it's a stable sort, not because the time is taken into account.
Note that compared to a typical Beancount ledger, all amounts will be flipped,
i.e. -42 becomes +42 and +42 becomes -42. This is because RevBank's bookkeeping
is done from the users' perspectives, rather than that of the organization.
Incidentally, the resulting numbers will also make more intuitive sense as
income is now positive and expenses are negative - which is not what a typical
Beancount administration would look like, but would seem more logical to most
lay persons.
Beancount transaction descriptions are attached to the booking, not to its
individual postings, while RevBank has a different description for each
account, again because it works from the perspectives of the users. The
descriptions are converted as string metadata. To view them in Fava, enable
both Metadata and Postings.
Fava beans can be deadly for persons with G6PD deficiency, because the beans
contain vicine, which is toxic to them as vicine oxidises glutathione faster
than these people can regenerate it. The resulting hemolytic anemia due to
premature breakdown of red blood cells can culminate in a fatal hemolytic
crisis. G6PD deficiency is a hereditary enzyme deficiency that is estimated to
affect 5% of Earth's human population.
=cut
use v5.32;
use warnings;
use autodie;
use FindBin qw($RealBin);
use lib "$RealBin/../lib";
use RevBank::Amount;
my %transactions;
my @transaction_ids; # keep order: future revbank might have non-monotonic ids
my %balances;
my $currency = "EUR";
my $first_date = "9999-99-99";
my $fn = shift;
print qq{option "operating_currency" "$currency"\n};
sub rb2bc {
# TODO Rewrite. What a mess.
local $_ = join ":", map ucfirst, split m[/], shift;
s/_/-/g;
s/^-cash$/-cash:Box/; # skimmed would be sub category
return "Expenses:Reimbursed" if $_ eq "-deposits:Reimburse";
return "Assets:\u$_" if /^(?:-cash|-deposits)\b/i and s/^-//;
return "Expenses:\u$_" if /^(?:-expenses)\b/i and s/^-//;
return "Liabilities:Ibuttonborg" if $_ eq "+ibuttonborg";
return "Equity:\u$_" if s/^-//;
return "Income:\u$_" if s/^\+//;
return "Liabilities:$_";
}
open my $fh, $fn || ".revbank.log";
while (defined(my $line = readline $fh)) {
if ($line =~ /CHECKOUT/) {
my ($date, $time, $id, $account, $dir, $qty, $amount, $desc) = $line =~ m[
^(\d\d\d\d-\d\d-\d\d)_(\d\d:\d\d:\d\d) # date_time
\s++ CHECKOUT
\s++ (\S++) # transaction id
\s++ (\S++) # account name
\s++ (GAIN|LOSE|====) # direction
\s++ (\d++) # quantity
\s++ ([\d.]++) # total amount (absolute)
\s++ \#\s(.*) # description
]x or warn;
$first_date = $date if $date lt $first_date;
if (not exists $transactions{$id}) {
$transactions{$id} = { date => $date, time => $time };
push @transaction_ids, $id;
}
push @{ $transactions{$id}{legs} }, {
account => $account,
dir => $dir,
amount => $amount,
desc => $desc,
};
}
elsif ($line =~ /BALANCE/) {
my ($date, $id, $account, $balance) = $line =~ m[
^(\d\d\d\d-\d\d-\d\d)_\S++ # date
\s++ BALANCE
\s++ (\S++) # transaction id
\s++ (\S++) # account name
\s++ had
\s++ ([+-][\d.]++) # account balance before transaction
]x or warn;
# This uses the fact that revbank will *always* emit a BALANCE event
# for every account modified by a CHECKOUT event, and that transactions
# will be in chronological order in the log. That is, the first old
# balance will be the opening balance, regardless of the corresponding
# transaction id.
$balances{$account} //= $balance;
}
}
print "$first_date open Equity:Opening-Balances\n";
print "$first_date open Equity:Undo\n";
# Opening balances for accounts that had transactions
for my $account (sort keys %balances) {
printf "$first_date open %s $currency\n", rb2bc($account);
print qq{$first_date * "Opening balance for $account"\n};
printf(
" %s %s $currency\n",
rb2bc($account),
RevBank::Amount->parse_string($balances{$account})
);
printf " Equity:Opening-Balances\n\n";
}
# Transactions
for my $id (@transaction_ids) {
my $txn = $transactions{$id};
print qq{$txn->{date} * "RevBank-transaction $id"\n};
print qq{ time: "$txn->{time}"\n};
for my $leg (@{ $txn->{legs} }) {
printf(
qq{ %s %s $currency\n description: "%s"\n},
rb2bc($leg->{account}),
($leg->{dir} eq 'GAIN' ? +1 : -1) * RevBank::Amount->parse_string($leg->{amount}),
$leg->{desc} =~ s/\"/\\\"/gr
);
}
print "\n";
}
# TODO: read revbank.accounts and "open" beancount accounts for all accounts
# that didn't have any transactions.

View file

@ -1,81 +0,0 @@
=head1 NAME
RevBank - Pre-paid bar tab for hackerspaces
=head1 DESCRIPTION
=head2 High-level architecture
Since version 2, RevBank is loosely modeled after C<qpsmtpd>, which is an SMTP server in which the core speaks the SMTP protocol, but doesn't do anything with the commands it receives. Actually handling the commands is the responsibility of plugins. Without plugins, the software is useless.
RevBank is interactive and stateful. Global state is provided in the form of a "shopping cart", a L<RevBank::Cart> object, which represents the ongoing, unfinished, transaction. The terms "cart", "unfinished transaction", and "current transaction" generally all refer to the same thing in the context of RevBank.
In addition, RevBank provides the concept of accounts through L<RevBank::Users>. There are user accounts and internal accounts; internal accounts are used as contra accounts for I<double-entry bookkeeping>, and are hidden from the user interface. Accounts only have a name, a balance, and some timestamps; things like transaction histories are provided by plugins.
Notably, the RevBank core does B<not> have any notion of "products". Support for buying products through RevBank is provided by plugins, like the included C<products> and C<market> plugins. It is easy to add another source of products by writing another plugin. A plugin contains arbitrary code and can do anything, including querying external resources.
=head2 Data files
All files are simple text files, generally whitespace and newline separated. While this isn't particularly "cool", there are many tools that work with them, like C<diff> and C<git> and C<vim>. That means a lot of functionality (such as editing a product list) doesn't require any specialized user interfaces. It also makes creating backups trivial.
RevBank uses a single lock file, so you can safely use multiple processes. It doesn't keep any files open, making it safe to just kill C<revbank> at any moment (only the current transaction will be lost) or to edit some files with an external editor (not the files that RevBank writes to, though).
RevBank does currently not behave well with non-ASCII data.
=head2 The input loop
RevBank is a user-interactive CLI, intended for use with a keyboard and a barcode scanner. The barcode scanner is configured as a virtual keyboard device; RevBank doesn't care if the input is given with the barcode scanner or the keyboard, and it is considered a feature that everything that can be typed, can be turned into a scannable barcode, and that any barcode data can be typed instead of scanned.
Most barcode scanners virtually press the I<Enter> key after each scan, and RevBank is made with this in mind: any command parameters are typically presented as follow-up prompts.
For advanced users, a more shell-like interface is provided: a command and its arguments can be given on a single line, separated by spaces. On the top-level prompt (i.e. not in follow-up prompts), the input is whitespace separated, and each of the terms is added to a stack, from which subsequent prompts are fed. At that level, terms can be quoted with C<'single'> or C<"double"> quotes, and C<\> escapes the subsequent character. As long as there are words on the stack, the printing of further prompts is suppressed.
Multiple commands on a single line can be separated with C<;>. This is required after a command that finalizes a transaction (like a bare username after adding products), or between a command that takes arguments and a command that follows it.
There is no syntax for indicating the end of a command in the simple mode. Every command has either a fixed number of arguments (follow-up questions), or its own specialized way to indicate the end of a variable length list.
Similarly, the end of the "list of products" is not indicated by syntax, but by entering a username. Or, more technically correct: every product id is a command, and so is every username. The product id command adds an entry to the cart, the username command finalizes the transaction and empties the cart.
=head3 abort
The string C<abort> is hard-coded and will always abort the current transaction (i.e. reset the global state (cart)). This is intentional as users always need a "way out", and C<abort> is unlikely to be a valid response to any prompt anyway. (The "advanced" input method lets you quote it, like C<"abort">, although that is probably only useful for a print-a-barcode plugin...)
=head2 Plugins
All user input, except C<abort>, is handled by plugins. Without plugins, C<abort> is the only input that does something, and even then, it's just emptying an already empty shopping cart.
Information about writing plugins is provided in L<RevBank::Plugins>.
Commands and hooks can manipulate the cart to delete, add, or modify its entries.
=head3 Commands
For every command given on the top-level prompt of the input loop, the C<command> method of every plugin is queried until a plugin returns C<ACCEPT>, C<REJECT>, or C<ABORT>. All other plugins return C<NEXT> to indicate that the remaining plugins should be tried. A plugin can, however, do something with the input, and still return C<NEXT>. It can even manipulate the input before passing it on to the next plugin.
Plugins are always used in the order specified in the configuration file C<revbank.plugins>, and the order in which they are defined is vital to a correctly functioning RevBank instance. Some, but not all, plugins will detect if other plugins they depend on, are loaded. In general, though, it is up to the administrator to carefully maintain the C<revbank.plugins> list.
There can be overlap between plugins; C<cola> might be a valid product and also a valid username, in which case the user is out of luck if the C<products> plugin is specified before the C<users> plugin: they will not be able to complete a transaction. In practice, this does not present much of a problem, because product ids are typically numerical barcodes. It does happen, however, that there's a clash between a command and a username. A user with a nickname that is exactly equal to a command like C<help> or C<undo> is SOL unless the C<users> plugin is specified early in the list; this is not recommended, because it means that using C<adduser>, anyone can easily cause denial of service.
Commands can request arguments by returning a reference to a function. This is then handled by the main input loop, which will either use words on its stack, or prompt for further input.
There is no way for a command to declare its number of arguments (follow-up questions), which means that it is not possible to interpret RevBank input without executing it. This also means that it is not safe to replay the log file in a different version or configuration (e.g. in lieu of restoring a backup).
=head3 Hooks
All kinds of things in RevBank will "call hooks", which is a fancy way of saying they'll try to call a certain method, for each and every plugin. With commands, the intention is that one plugin will be "the one" to handle the command, but with hooks, I<every> plugin's hook method is called. The only way around that is returning ABORT, which will kill the entire unfinished transaction.
=head1 SECURITY
RevBank is insecure by design. It does not ship with any authentication or authorization mechanism, nor was it designed with such things in mind.
The concept of unsupervised 100% self-service access to a fully stocked refrigerator is in itself insecure. It probably does not scale well to a huge number of people, but it's proven to serve small communities well. It's primarily based on trust, or what's sometimes referred to as the "honor system".
It may be possible to implement some semblance of security with a plugin (and by disabling plugins like C<take>), but that still wouldn't keep anyone from stealing drinks from the fridge. If you can't trust your users, RevBank is probably not the right tool for the job. And if you are in these unfortunate circumstances, you should really reconsider that unsupervised access to the fridge.
This said, RevBank does come with a C<log> plugin, which enables external auditing of its use. With every balance change, the old and new balances are recorded. The log file is also very useful to investigate user mistakes.
Hardware can fail, software can fail, and users can fail. Make backups. Make lots of backups. Maybe once an hour, or even after every transaction. Don't just synchronize, but keep the old versions too.
=head1 AUTHOR
Juerd Waalboer

View file

@ -1,10 +1,7 @@
package RevBank::Amount;
use v5.32;
use v5.28;
use warnings;
use experimental 'isa'; # stable since v5.36
use experimental 'signatures'; # stable since v5.36
use experimental qw(signatures);
use Carp qw(carp croak);
use Scalar::Util;
use POSIX qw(lround);
@ -13,7 +10,7 @@ our $C = __PACKAGE__;
sub _coerce {
for (@_) {
unless ($_ isa $C) {
unless (ref and UNIVERSAL::isa($_, $C)) {
croak "Unsupported operation on $C with " . ref if ref;
croak "Unsupported operation on $C with undef" if not defined;
@ -75,14 +72,12 @@ sub new_from_float($class, $num) {
}
sub parse_string($class, $str) {
defined $str and $str =~ /\S/ or return undef;
$str =~ /\S/ or return undef;
my ($neg, $int, $cents)
= $str =~ /^\s*(?:\+|(-)?)([0-9]+)?(?:[,.]([0-9]{1,2}))?\s*$/
or return undef;
defined $int or defined $cents or return undef;
$int //= 0;
$cents //= 0;
$cents *= 10 if length($cents) == 1; # 4.2 -> 4.20
@ -118,7 +113,7 @@ sub string_flipped($self, $sep = " ") {
return sprintf(
"%s%s%d.%02d",
$$self > 0 ? "+" : "",
$$self > 0 ? $sep : "",
$sep,
abs($$self) / 100,
abs($$self) % 100,
);

View file

@ -4,8 +4,6 @@ RevBank::Amount - Fixed point 2-decimal numeric values that DWYM
=head1 SYNOPSIS
$amount = parse_amount("1.23"); # in plugins, best to use this
$amount = RevBank::Amount->new(30); # 0.30
$amount = RevBank::Amount->parse_string("0.30"); # 0.30
@ -53,16 +51,6 @@ do that), strange things can happen. Also, "-0.00" is annoying...
Note: this class does not play nice with other classes that use operator
overloading.
=head2 Functions
=head3 parse_amount
Provided by RevBank::Global, and available in plugins. Unlike the
method C<< RevBank::Amount->parse_string >>, the function C<parse_amount> will
not allow negative numbers, which is typically a good idea to maintain sanity.
When writing plugins, you should strongly consider providing two different
commands instead of allowing negative numbers.
=head2 Constructors
=head3 new
@ -111,6 +99,6 @@ $amount + 1.001 >> won't work because 0.001 has too many digits after
the decimal point.
When working with values that aren't safe, hard-coded literals, always
turn them into RevBank::Amount objects first, which takes care of the
turn them into RevBank::Amount objects first, which takes care of te
necessary rounding: C<< $amount + RevBank::Amount->new_from_float(1.001)
>>.

View file

@ -1,59 +1,50 @@
package RevBank::Cart;
use v5.32;
use warnings;
use experimental 'signatures'; # stable since v5.36
use strict;
use Carp ();
use List::Util ();
use RevBank::Global;
use RevBank::Users;
use RevBank::FileIO;
use RevBank::Cart::Entry;
{
package RevBank::Cart::CheckoutProhibited;
sub new($class, $reason) { return bless \$reason, $class; }
sub reason($self) { return $$self; }
}
sub new($class) {
sub new {
my ($class) = @_;
return bless { entries => [] }, $class;
}
sub add_entry($self, $entry) {
sub add_entry {
my ($self, $entry) = @_;
$self->_call_old_hooks("add", $entry);
RevBank::Plugins::call_hooks("add_entry", $self, $entry);
push @{ $self->{entries} }, $entry;
$self->{changed}++;
$self->select($entry);
$self->_call_old_hooks("added", $entry);
RevBank::Plugins::call_hooks("added_entry", $self, $entry);
return $entry;
}
sub add($self, $amount, $description, $data = {}) {
ref $data or Carp::croak "Non-hash data argument";
sub add {
# Deprecated interface: ->add($user, ...)
if (defined $_[3] and not ref $_[3]) {
return shift->old_add(@_);
}
# ->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 select($self, $entry) {
return $self->{selected_entry} = $entry;
}
sub delete {
Carp::croak("\$cart->delete(\$user, \$index) is no longer supported") if @_ > 2;
sub selected($self) {
return undef if not @{ $self->{entries} };
for my $entry (@{ $self->{entries} }) {
return $entry if $entry == $self->{selected_entry};
}
return $self->select( $self->{entries}->[-1] );
}
sub delete($self, $entry) {
my ($self, $entry) = @_;
my $entries = $self->{entries};
my $oldnum = @$entries;
@ -63,125 +54,152 @@ sub delete($self, $entry) {
return $oldnum - @$entries;
}
sub empty($self) {
sub empty {
my ($self) = @_;
$self->{entries} = [];
$self->{changed}++;
}
sub display($self, $prefix = "") {
sub display {
my ($self, $prefix) = @_;
$prefix //= "";
say "$prefix$_" for map $_->as_printable, @{ $self->{entries} };
}
sub size($self) {
sub size {
my ($self) = @_;
return scalar @{ $self->{entries} };
}
sub prohibit_checkout($self, $bool, $reason) {
if ($bool) {
$self->{prohibited} = $reason;
} else {
delete $self->{prohibited};
sub checkout {
my ($self, $user) = @_;
if ($self->entries('refuse_checkout')) {
warn "Refusing to finalize deficient transaction.\n";
$self->display;
return;
}
}
sub deltas($self, $user) {
my %deltas = ($user => RevBank::Amount->new(0));
my $entries = $self->{entries};
for my $entry (@{ $self->{entries} }) {
my %deltas;
for my $entry (@$entries) {
$entry->user($user);
$deltas{$entry->{user}} //= RevBank::Amount->new(0);
$deltas{$_->{user}} += $_->{amount} * $entry->quantity
for $entry, $entry->contras;
}
return \%deltas;
my $transaction_id = time() - 1300000000;
RevBank::Plugins::call_hooks("checkout", $self, $user, $transaction_id);
for my $account (keys %deltas) {
RevBank::Users::update($account, $deltas{$account}, $transaction_id)
if $deltas{$account} != 0;
}
RevBank::Plugins::call_hooks("checkout_done", $self, $user, $transaction_id);
$self->empty;
sleep 1; # Ensure new timestamp/id for new transaction
return 1;
}
sub entries {
my ($self, $attribute) = @_;
sub checkout($self, $user) {
if ($self->{prohibited}) {
die RevBank::Cart::CheckoutProhibited->new(
"Cannot complete transaction: $self->{prohibited}"
);
}
if ($self->entries('refuse_checkout')) {
$self->display;
die "Refusing to finalize deficient transaction";
}
$user = RevBank::Users::assert_user($user);
my $entries = $self->{entries};
for my $entry (@$entries) {
$entry->sanity_check;
$entry->user($user);
}
RevBank::FileIO::with_lock {
my $fn = ".revbank.nextid";
my $transaction_id = eval { RevBank::FileIO::slurp($fn) };
my $legacy_id = 0;
if (defined $transaction_id) {
chomp $transaction_id;
if ($transaction_id eq "LEGACY") {
$legacy_id = 1;
$transaction_id = time() - 1300000000;;
}
} else {
warn "Could not read $fn; using timestamp as first transaction ID.\n";
$transaction_id = time() - 1300000000;
}
RevBank::Plugins::call_hooks("checkout_prepare", $self, $user, $transaction_id)
or die "Refusing to finalize after failed checkout_prepare";
for my $entry (@$entries) {
$entry->sanity_check;
$entry->user($user) if not $entry->user;
}
RevBank::FileIO::spurt($fn, ++(my $next_id = $transaction_id)) unless $legacy_id;
RevBank::Plugins::call_hooks("checkout", $self, $user, $transaction_id);
my $deltas = $self->deltas($user);
for my $account (reverse sort keys %$deltas) {
# The reverse sort is a lazy way to make the "-" accounts come last,
# which looks nicer with the "cash" plugin.
RevBank::Users::update($account, $deltas->{$account}, $transaction_id)
if $deltas->{$account} != 0;
}
RevBank::Plugins::call_hooks("checkout_done", $self, $user, $transaction_id);
sleep 1; # look busy
$self->empty;
};
}
sub entries($self, $attribute = undef) {
my @entries = @{ $self->{entries} };
return grep $_->has_attribute($attribute), @entries if defined $attribute;
return @entries;
}
sub changed($self, $keep = 0) {
sub changed {
my ($self) = @_;
my $changed = 0;
for my $entry ($self->entries('changed')) {
$entry->attribute('changed', undef) unless $keep;
$entry->attribute('changed', undef);
$changed = 1;
}
$changed = 1 if $self->{changed};
delete $self->{changed} unless $keep;
$changed = 1 if delete $self->{changed};
return $changed;
}
sub sum($self) {
sub sum {
my ($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;

View file

@ -1,22 +1,16 @@
use strict;
package RevBank::Cart::Entry;
use v5.32;
use warnings;
use experimental 'signatures'; # stable since v5.36
use Carp qw(carp croak);
use RevBank::Users;
use List::Util ();
use Scalar::Util ();
# Workaround for @_ in signatured subs being experimental and controversial
my $NONE = \do { my $dummy };
sub _arg_provided($a) {
return 1 if not ref $a;
return Scalar::Util::refaddr($a) != Scalar::Util::refaddr($NONE)
}
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,146 +20,104 @@ sub new($class, $amount, $description, $attributes = {}) {
attributes => { %$attributes },
user => undef,
contras => [],
caller => List::Util::first(sub { !/^RevBank::Cart/ }, map { (caller $_)[3] } 1..10)
|| (caller 1)[3],
highlight => 1,
caller => (caller 1)[3],
};
return bless $self, $class;
}
sub add_contra($self, $user, $amount, $description, $display = undef) {
# $display should be given for either ALL or NONE of the contras,
# with the exception of contras with $amount == 0.00;
sub add_contra {
my ($self, $user, $amount, $description) = @_;
$amount = RevBank::Amount->parse_string($amount) if not ref $amount;
$user = RevBank::Users::assert_user($user);
$description =~ s/\$you/$self->{user}/g if defined $self->{user};
push @{ $self->{contras} }, {
user => $user,
amount => $amount, # should usually have opposite sign (+/-)
description => $description, # contra user's perspective
display => $display, # interactive user's perspective
highlight => 1,
description => $description,
};
$self->attribute('changed', 1);
return $self; # for method chaining
}
sub has_attribute($self, $key) {
sub has_attribute {
my ($self, $key) = @_;
return (
exists $self->{attributes}->{$key}
and defined $self->{attributes}->{$key}
);
}
sub attribute($self, $key, $new = $NONE) {
sub attribute {
my ($self, $key, $new) = @_;
my $ref = \$self->{attributes}->{$key};
$$ref = $new if _arg_provided($new);
$$ref = $new if @_ > 2;
return $$ref;
}
sub amount($self, $new = undef) {
my $ref = \$self->{amount};
if (defined $new) {
$new = RevBank::Amount->parse_string($new) if not ref $new;
$$ref = $new;
$self->attribute('changed', 1);
$self->{highlight_amount} = 1;
}
sub quantity {
my ($self, $new) = @_;
return $$ref;
}
sub quantity($self, $new = undef) {
my $ref = \$self->{quantity};
if (defined $new) {
$new >= 0 or croak "Quantity must be positive";
$$ref = $new;
$self->attribute('changed', 1);
$self->{highlight_quantity} = 1;
}
return $$ref;
}
sub multiplied($self) {
sub multiplied {
my ($self) = @_;
return $self->{quantity} != 1;
}
sub contras($self) {
sub contras {
my ($self) = @_;
# Shallow copy suffices for now, because there is no depth.
return map +{ %$_ }, @{ $self->{contras} };
}
sub delete_contras($self) {
$self->{contras} = [];
}
sub as_printable {
my ($self) = @_;
my $HI = "\e[37;1m";
my $LO = "\e[2m";
my $END = "\e[0m";
$self->sanity_check;
sub as_printable($self) {
my @s;
push @s, $self->{quantity} . "x {" if $self->multiplied;
# Normally, the implied sign is "+", and an "-" is only added for negative
# numbers. Here, the implied sign is "-", and a "+" is only added for
# positive numbers.
my $q = $self->{quantity};
push @s, sprintf "%s%-4s%s" . "%s%8s%s" . " " . "%s%s%s",
($self->{highlight} || $self->{highlight_quantity} ? $HI : $LO),
($q > 1 || $self->{highlight_quantity} ? "${q}x" : ""),
($self->{highlight} ? "" : $END),
push @s, sprintf " %6s %s", $self->{amount}->string_flipped, $self->{description};
($self->{highlight} || $self->{highlight_amount} ? $HI : $LO),
$self->{amount}->string_flipped,
($self->{highlight} ? "" : $END),
($self->{highlight} ? $HI : $LO),
$self->{description},
$END;
for my $c (@{ $self->{contras} }) {
my $description;
my $amount = $self->{amount};
my $hidden = RevBank::Users::is_hidden($c->{user});
my $fromto = $c->{amount}->cents < 0 ? "<-" : "->";
$fromto .= " $c->{user}";
if ($c->{display}) {
$description =
$hidden
? ($ENV{REVBANK_DEBUG} ? "($fromto:) $c->{display}" : $c->{display})
: "$fromto: $c->{display}";
$amount *= -1;
} elsif ($hidden) {
next unless $ENV{REVBANK_DEBUG};
$description = "($fromto: $c->{description})";
} else {
$description = $fromto;
}
for my $c ($self->contras) {
push @s, sprintf(
"%s%15s %s%s",
($self->{highlight} || $c->{highlight} ? $HI : $LO),
($self->{amount} > 0 ? $c->{amount}->string_flipped("") : $c->{amount}->string),
$description,
$END,
" %9s %s %s",
$c->{amount}->abs->string,
($c->{amount}->cents > 0 ? "->" : "<-"),
$c->{user}
);
delete $c->{highlight};
}
delete $self->@{qw(highlight highlight_quantity highlight_amount)};
push @s, "}" if $self->multiplied;
return @s;
}
sub as_loggable($self) {
sub as_loggable {
my ($self) = @_;
croak "Loggable called before set_user" if not defined $self->{user};
$self->sanity_check;
my $quantity = $self->{quantity};
@ -176,14 +128,14 @@ sub as_loggable($self) {
my $description =
$quantity == 1
? $_->{description}
: sprintf("%s [%sx %s]", $_->{description}, $quantity, $_->{amount}->abs);
: sprintf("%s [%sx %s]", $_->{description}, $quantity, abs($_->{amount}));
push @s, sprintf(
"%-12s %4s %3d %6s # %s",
"%-12s %4s %3d %5s # %s",
$_->{user},
($total->cents > 0 ? 'GAIN' : $total->cents < 0 ? 'LOSE' : '===='),
($total > 0 ? 'GAIN' : $total < 0 ? 'LOSE' : ''),
$quantity,
$total->abs,
abs($total),
$description
);
}
@ -191,7 +143,9 @@ sub as_loggable($self) {
return @s;
}
sub user($self, $new = undef) {
sub user {
my ($self, $new) = @_;
if (defined $new) {
croak "User can only be set once" if defined $self->{user};
@ -202,29 +156,31 @@ sub user($self, $new = undef) {
return $self->{user};
}
sub sanity_check($self) {
my @contras = $self->contras;
sub sanity_check {
my ($self) = @_;
my $sum = RevBank::Amount->new(
List::Util::sum(map $_->{amount}->cents, $self, @contras)
);
# 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.
if ($sum != 0) {
local $ENV{REVBANK_DEBUG} = 1;
my $message = join("\n",
return 1 if $self->{FORCE};
my @contras = $self->contras or return 1;
my $sum = List::Util::sum(map $_->{amount}->cents, $self, @contras);
if ($sum > 0) {
$self->{FORCE} = 1;
croak join("\n",
"BUG! (probably in $self->{caller})",
"Unbalanced transactions are not possible in double-entry bookkeeping.",
"This adds up to creating money that does not exist:",
$self->as_printable,
(
!@contras
? "Use \$entry->add_contra to balance the transaction."
: abs($sum) == 2 * abs($self->{amount})
? "Contras for positive value should be negative values and vice versa."
$sum == 2 * $self->{amount}->cents
? "Hint: contras for positive value should be negative values."
: ()
),
sprintf("Cowardly refusing to create $sum out of thin air")
);
RevBank::Plugins::call_hooks("log_error", "UNBALANCED ENTRY $message");
croak $message;
}
return 1;

View file

@ -1,122 +0,0 @@
package RevBank::FileIO;
use v5.32;
use warnings;
use experimental 'signatures'; # stable since v5.36
use autodie;
use Fcntl qw(:flock);
use Carp qw(croak);
use Time::HiRes qw(sleep);
my $tempfn = ".revbank.$$";
my $lockfn = ".revbank.global-lock";
my $lockfh;
my $lockcount = 0;
sub get_lock() {
if (defined $lockfh) {
die "Fatal inconsistency" if $lockcount < 1;
return ++$lockcount;
}
die "Fatal inconsistency" if $lockcount;
open $lockfh, ">", $lockfn;
my $attempt = 1;
my $debug = !!$ENV{REVBANK_DEBUG};
FLOCK: {
if (flock $lockfh, LOCK_EX | LOCK_NB) {
syswrite $lockfh, $$;
return ++$lockcount;
}
if (($attempt % 50) == 0 or $debug) {
warn "Another revbank instance has the global lock. Waiting for it to finish...\n"
}
sleep .1;
$attempt++;
redo FLOCK;
}
croak "Could not acquire lock on $lockfn; file access failed";
}
sub release_lock() {
if (not defined $lockfh) {
die "Fatal inconsistency" if $lockcount;
return;
}
die "Fatal inconsistency" if $lockcount < 1;
if (--$lockcount == 0) {
flock $lockfh, LOCK_UN;
close $lockfh;
undef $lockfh;
}
}
sub release_all_locks() {
release_lock while $lockcount;
}
sub with_lock :prototype(&) ($code) {
my $skip = $ENV{REVBANK_SKIP_LOCK};
get_lock unless $skip;
my @rv;
my $rv;
my $list_context = wantarray;
eval {
@rv = $code->() if $list_context;
$rv = $code->() if not $list_context;
};
release_lock unless $skip;
croak $@ =~ s/\.?\n$/, rethrown/r if $@;
return @rv if $list_context;
return $rv if not $list_context;
}
sub slurp($fn) {
return with_lock {
local $/ = wantarray ? "\n" : undef;
open my $fh, "<", $fn;
return readline $fh;
}
}
sub spurt($fn, @data) {
return with_lock {
open my $out, ">", $tempfn;
print $out @data;
close $out;
rename $tempfn, $fn;
};
}
sub append($fn, @data) {
return with_lock {
open my $out, ">>", $fn;
print $out @data;
close $out;
};
}
sub rewrite($fn, $sub) {
return with_lock {
open my $in, "<", $fn;
open my $out, ">", $tempfn;
while (defined(my $line = readline $in)) {
local $_ = $line;
my $new = $sub->($line);
print $out $new if defined $new;
}
close $out;
close $in;
rename $tempfn, $fn;
};
}
1;

View file

@ -1,96 +0,0 @@
=head1 NAME
RevBank::FileIO - Line-based text file manipulation with advisory locking
=head1 SYNOPSIS
with_lock {
...
};
my $data = slurp $filename;
my @lines = slurp $filename;
spurt $filename, @data;
append $filename, @data;
rewrite $filename, sub($line) {
return $line; # return changed or unchanged line
return undef; # exclude line from file
};
=head1 DESCRIPTION
This package implements very simple locking to protect against filesystem
based race conditions when running multiple instances of revbank on the same
data files.
These race conditions are probably exceptionally rare and very hard to trigger
in real-world conditions, because file system access is very fast due to
caching and buffering by the kernel. RevBank was used for over a decade without
any known problem due such a race condition, before locking was finally
added.
No attempt was made to optimize for performance, and all locks are global and
exclusive.
Will wait for the global lock for as long as it takes, printing a message every
few seconds to keep the user informed.
=head2 Functions
=head3 with_lock BLOCK
Gets the lock, executes the block, releases the lock again. Returns whatever
the block returned.
Use this instead of C<get_lock> to prevent forgetting to release the lock.
=head3 get_lock
Acquires the lock if it is not already held. Keeps extra virtual locks (by
virtue of a simple counter) if the global lock is already held by the current
process.
Calling this function directly is discouraged. Use C<with_lock> instead.
=head3 release_lock
Decreases the number of virtual locks, releasing the real lock if none are
left.
Calling this function directly is discouraged. Use C<with_lock> instead.
=head1 slurp($filename)
Returns the entire contents of the file. In list context, returns a list of
lines (including the line ending).
=head1 spurt($filename, @data)
=head1 append($filename, @data)
Writes to a file. No separators or delimiters are added to the provided data,
so in general you will want to pass either the entire contents as a single
string, or a list of lines that already have line endings.
=head1 rewrite($filename, sub($line) { ...; return $line; })
Rewrites the existing text file. The provided subroutine is called for each
line, and must return everything that should be written back. The sub can
return undef to essentially skip (remove) a line.
=head2 CAVEATS
=over 2
=item * A lock file is used, so external processes should not depend on the
individual files being flocked.
=item * Using a text editor while revbank is running and changing files will
still mess things up.
=item * The locking mechanism provides a lock per process; different parts
(e.g. plugins) of the same process can still simultaneously do things, so keep
to the pattern of always closing files before returning control or forking.
=back

View file

@ -1,67 +1,30 @@
package RevBank::Global;
use v5.32;
use warnings;
use experimental 'signatures'; # stable since v5.36
use strict;
use POSIX qw(strftime);
use RevBank::Amount;
use RevBank::FileIO;
{
package RevBank::Exception::RejectInput;
sub new($class, $reason) { return bless \$reason, $class; }
sub reason($self) { return $$self; }
}
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\::REDO"} = sub () { \6 };
*{"$caller\::slurp"} = \&RevBank::FileIO::slurp;
*{"$caller\::spurt"} = \&RevBank::FileIO::spurt;
*{"$caller\::rewrite"} = \&RevBank::FileIO::rewrite;
*{"$caller\::append"} = \&RevBank::FileIO::append;
*{"$caller\::with_lock"} = \&RevBank::FileIO::with_lock;
*{"$caller\::parse_user"} = \&RevBank::Users::parse_user;
*{"$caller\::parse_amount"} = sub ($amount) {
*{"$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;
my @split = grep /\S/, split /([+-])/, $amount;
my $posneg = 1;
$amount = RevBank::Amount->new(0);
for my $token (@split) {
if ($token eq '-') {
$posneg = $posneg == -1 ? 1 : -1;
} elsif ($token eq '+') {
$posneg ||= 1;
} else {
$posneg or return undef; # two terms in a row
my $term = RevBank::Amount->parse_string($token) // return undef;
$amount += $posneg * $term;
$posneg = 0;
}
}
$posneg and return undef; # last token must be term
$amount = RevBank::Amount->parse_string($amount) // return undef;
if ($amount->cents < 0) {
die RevBank::Exception::RejectInput->new(
"For our sanity, no negative amounts, please :)."
);
die "For our sanity, no negative amounts, please :).\n";
}
if ($amount->cents > 99900) {
die RevBank::Exception::RejectInput->new(
"That's way too much money."
);
die "That's way too much money, or an unknown barcode.\n";
}
return $amount;
};
@ -69,12 +32,57 @@ sub import {
*{"$caller\::say"} = sub {
print @_, "\n";
};
*{"$caller\::now"} = sub () {
*{"$caller\::now"} = sub {
return strftime '%Y-%m-%d_%H:%M:%S', localtime;
};
}
__PACKAGE__->import;
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.

View file

@ -1,45 +0,0 @@
=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.

View file

@ -1,9 +1,4 @@
package RevBank::Messages;
use v5.32;
use warnings;
use experimental 'signatures'; # stable since v5.36
use RevBank::Global;
use base 'RevBank::Plugin';
@ -12,10 +7,8 @@ use base 'RevBank::Plugin';
BEGIN {
RevBank::Plugins::register("RevBank::Messages");
*hidden = \&RevBank::Users::is_hidden;
}
sub command { return NEXT; }
sub id { 'built in messages' }
@ -23,64 +16,52 @@ sub hook_startup {
say "\e[0m\n\n\nWelcome to the RevBank Shell, version $::VERSION\n";
}
sub hook_plugin_fail($class, $plugin, $error, @) {
sub hook_plugin_fail {
my ($class, $plugin, $error) = @_;
warn "Plugin '$plugin' failed: $error\n";
}
sub hook_cart_changed($class, $cart, @) {
sub hook_cart_changed {
my ($class, $cart) = @_;
$cart->size or return;
say "Pending:";
$cart->display;
if (not $cart->entries('refuse_checkout')) {
my $sum = $cart->sum;
my $what = $sum->cents > 0 ? "add" : $cart->entries('is_withdrawal') ? "deduct" : "pay";
my $dir = $sum->cents > 0 ? "to" : "from";
my $abs = $sum->abs;
say "Enter username to $what $abs $dir your account; type 'abort' to abort.";
my $sum = $cart->sum;
my $what = $sum > 0 ? "add" : "pay";
my $abs = $sum->abs;
say "Enter username to $what $abs; type 'abort' to abort.";
}
}
sub hook_checkout($class, $cart, $user, $transaction_id, @) {
if ($cart->changed) {
say "Done:";
$cart->display;
}
say "Transaction ID: $transaction_id";
}
sub hook_abort($class, $cart, @) {
sub hook_abort {
my ($class, $cart) = @_;
say "\e[1;4mABORTING TRANSACTION.\e[0m";
}
sub hook_invalid_input($class, $cart, $origword, $lastword, $allwords, @) {
say "$origword: No such product, user, or command.";
my @other = splice @$allwords, 1;
if (@other) {
$other[-1] =~ s/^/ and / if @other > 1;
say "(Also tried as " . join(@other > 2 ? ", " : "", @other) . ".)";
}
sub hook_invalid_input {
my ($class, $cart, $word) = @_;
say "$word: No such product, user, or command.";
}
sub hook_reject($class, $plugin, $reason, $abort, @) {
sub hook_reject {
my ($class, $plugin, $reason, $abort) = @_;
say $abort ? $reason : "$reason Enter 'abort' to abort.";
}
sub hook_user_balance($class, $username, $old, $delta, $new, @) {
return if hidden $username and not $ENV{REVBANK_DEBUG};
my $sign = $delta->cents >= 0 ? '+' : '-';
my $rood = $new->cents < 0 ? '31;' : '';
my $abs = $delta->abs;
my $warn = $new->cents < -1337 ? " \e[5;1m(!!)\e[0m" : "";
sub hook_user_balance {
my ($class, $username, $old, $delta, $new) = @_;
my $sign = $delta >= 0 ? '+' : '-';
my $rood = $new < 0 ? '31;' : '';
my $abs = abs($delta);
my $warn = $new < -13.37 ? " \e[5;1m(!!)\e[0m" : "";
$_ = $_->string("+") for $old, $new;
printf "New balance for $username: $old $sign $abs = \e[${rood}1m$new\e[0m$warn\n",
}
sub hook_user_created($class, $username, @) {
return if hidden $username and not $ENV{REVBANK_DEBUG};
sub hook_user_created {
my ($class, $username) = @_;
say "New account '$username' created.";
}

View file

@ -1,56 +1,11 @@
package RevBank::Plugin;
use strict;
use v5.32;
use warnings;
use experimental 'signatures'; # stable since v5.36
use attributes;
require RevBank::Global;
sub new($class) {
sub new {
my ($class) = @_;
return bless { }, $class;
}
sub command($self, $cart, $command, @) {
return RevBank::Global::NEXT();
}
sub Tab($self, $method) {
my %completions;
my $attr = attributes::get(
ref $method ? $method : $self->can($method)
) or return;
my ($tab) = $attr =~ /Tab \( (.*?) \)/x or return;
for my $keyword (split /\s*,\s*/, $tab) {
if ($keyword =~ /^&(.*)/) {
my $method = $1;
@completions{ $self->$method } = ();
} else {
$completions{ $keyword }++;
}
}
if (delete $completions{USERS}) {
for my $name (RevBank::Users::names()) {
next if RevBank::Users::is_hidden($name);
$completions{ $name }++;
$completions{ $1 }++ if $name =~ /^\*(.*)/;
}
}
return keys %completions;
}
sub AllChars($self, $method) {
my $attr = attributes::get(
ref $method ? $method : $self->can($method)
) or return;
return !!($attr =~ /AllChars/);
}
1;

View file

@ -1,9 +1,5 @@
package RevBank::Plugins;
use v5.32;
use warnings;
use experimental 'signatures'; # stable since v5.36
use strict;
use RevBank::Eval;
use RevBank::Plugin;
use RevBank::Global;
@ -12,41 +8,32 @@ our @EXPORT = qw(call_hooks load_plugins);
my @plugins;
sub _read_file($fn) {
local @ARGV = ($fn);
sub _read_file {
local (@ARGV) = @_;
readline *ARGV;
}
sub call_hooks {
my $hook = shift;
my $method = "hook_$hook";
my $success = 1;
for my $class (@plugins) {
if ($class->can($method)) {
my ($rv, @message) = eval { $class->$method(@_) };
my ($rv, $message) = $class->$method(@_);
if ($@) {
$success = 0;
call_hooks("plugin_fail", $class->id, "$class->$method died: $@");
} elsif (defined $rv and ref $rv) {
main::abort(@message) if $rv == ABORT;
$success = 0;
call_hooks("plugin_fail", $class->id, "$class->$method returned an unsupported value");
if (defined $rv and ref $rv) {
main::abort($message) if $rv == ABORT;
warn "$class->$method returned an unsupported value.\n";
}
}
}
return $success;
};
sub register(@new_plugins) {
call_hooks("register", $_) for @new_plugins;
push @plugins, @new_plugins;
sub register {
call_hooks("register", $_) for @_;
push @plugins, @_;
}
sub load($class) {
sub load {
my @config = _read_file('revbank.plugins');
chomp @config;
s/#.*//g for @config;
@ -61,24 +48,18 @@ sub load($class) {
}
RevBank::Eval::clean_eval(qq[
use strict;
use warnings;
use v5.32;
use experimental 'signatures';
use experimental 'isa';
package $package;
BEGIN { RevBank::Global->import; }
our \@ISA = qw(RevBank::Plugin);
our \%ATTR;
sub MODIFY_CODE_ATTRIBUTES(\$class, \$sub, \@attrs) {
sub MODIFY_CODE_ATTRIBUTES {
my (\$class, \$sub, \@attrs) = \@_;
\$ATTR{ \$sub } = "\@attrs";
return;
}
sub FETCH_CODE_ATTRIBUTES {
return \$ATTR{ +pop };
}
sub HELP1 {
\$::HELP1{ +shift } = +pop;
}
sub HELP {
\$::HELP{ +shift } = +pop;
}
@ -98,7 +79,7 @@ sub load($class) {
}
}
sub new($class) {
sub new {
return map $_->new, @plugins;
}

View file

@ -45,15 +45,16 @@ There is no protection against infinite loops. Be careful!
because that's canonicalised.
Don't do this:
$entry->add_contra($u, $a, "Bad example");
$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.";
$entry->add_contra($u, $a, 'Good, except that $a is special in Perl :)');
$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 may
define one C<command> input method, and can have any number of hooks.
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
@ -114,38 +115,41 @@ cart, re-evaluate your assumptions when upgrading!
Hooks SHOULD NOT prompt for input or execute programs that do so.
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.
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:
Hooks SHOULD have a dummy C<@> parameter at the end of their signatures,
so they don't break when more information is added
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, @)
=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.
@ -156,47 +160,35 @@ item going into the cart!
Be careful to avoid infinite loops if you add new stuff.
=item hook_checkout_prepare($class, $cart, $user, $transaction_id, @)
=item hook_checkout $class, $cart, $user, $transaction_id
Called when the transaction is about to be processed. In this phase, the cart and its entries can still be manipulated. If the hook throws an exception, the transaction is aborted.
Called when the transaction is finalized, before accounts are updated.
=item hook_checkout($class, $cart, $user, $transaction_id, @)
Called when the transaction is finalized, before accounts are updated. The cart and cart entries must not be changed.
=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.
=item hook_products_changed($class, $changes, $mtime, @)
Called after reading a changed products file. C<$changes> is a reference to an array of C<[old, new]> pairs. For new products, C<old> will be undef. For deleted products, C<new> will be undef.
The mtime is the mtime of the products file, not necessarily when the product was changed.
Caveats: Only things that change during runtime cause this hook to be called. When multiple revbank instances are running, each process gets this hook. When the products file is modified externally, the new file is loaded only after user interaction. When a product's primary id changes, it is registered as a deletion and addition, not a change.
=back
Default messages can be silenced by overriding the hooks in
@ -204,7 +196,7 @@ C<RevBank::Messages>. Such a hack might look like:
undef &RevBank::Messages::hook_abort;
sub hook_abort($class, $cart, @) {
sub hook_abort {
print "This message is much better!\n"
}

View file

@ -1,214 +0,0 @@
package RevBank::Products;
use v5.32;
use warnings;
use experimental 'signatures'; # stable since 5.36
use RevBank::Prompt;
use RevBank::Global;
use Exporter qw(import);
our @EXPORT = qw(read_products);
# Note: the parameters are subject to change
sub read_products($filename = "revbank.products", $default_contra = "+sales/products") {
state %caches; # $filename => \%products
state %mtimes; # $filename => mtime
my $mtime = \$mtimes{$filename};
my $cache = $caches{$filename} ||= {};
return $cache if $$mtime and (stat $filename)[9] == $$mtime;
my %products;
my $linenr = 0;
my $warnings = 0;
$$mtime = (stat $filename)[9];
for my $line (slurp $filename) {
$linenr++;
next if $line =~ m[
^\s*\# # comment line
|
^\s*$ # empty line, or only whitespace
]x;
my @split = RevBank::Prompt::split_input($line);
if (not @split or ref $split[0] or grep /\0/, @split) {
warn "Invalid value in $filename line $linenr.\n";
next;
}
my ($ids, $p, $desc, @extra) = @split;
my @addon_ids;
my %tags;
my $compat = 0;
if (@split == 1 and ref $split[0]) {
$compat = 1;
} else {
for (@extra) {
if (/^\+(.*)/) {
push @addon_ids, $1;
} elsif (/^\#(\w+)(=(.*))?/) {
$tags{$1} = $2 ? $3 : 1;
} else {
$compat = 1;
last;
}
}
}
if ($compat) {
$warnings++;
warn "$filename line $linenr: can't parse as new format; assuming old format.\n" if $warnings < 4;
warn "Too many warnings; suppressing the rest. See UPGRADING.md for instructions.\n" if $warnings == 4;
($ids, $p, $desc) = split " ", $line, 3;
@addon_ids = ();
unshift @addon_ids, $1 while $desc =~ s/\s+ \+ (\S+)$//x;
}
my @ids = split /,/, $ids;
$p //= 0;
$desc ||= "(no description)";
my $canonical = join " ", map RevBank::Prompt::reconstruct($_), $ids, $p, $desc, @extra;
my ($price, $contra) = split /\@/, $p, 2;
my $sign = $price =~ s/^-// ? -1 : 1;
my $percent = $price =~ s/%$//;
if ($percent) {
if (grep !/^\+/, @ids) {
warn "Percentage invalid for non-addon at $filename line $linenr.\n";
next;
}
$percent = $sign * (0 + $price);
$price = undef; # calculated later
} else {
$price = eval { parse_amount($price) };
if (not defined $price) {
warn "Invalid price for '$ids[0]' at $filename line $linenr.\n";
next;
}
$price *= $sign;
}
for my $id (@ids) {
warn "Product '$id' redefined at $filename line $linenr (original at line $products{$id}{line}).\n" if exists $products{$id};
# HERE (see .pod)
$products{$id} = {
id => $ids[0],
aliases => [ @ids[1 .. $#ids] ],
is_alias => $id ne $ids[0],
description => $desc,
contra => $contra || $default_contra,
_addon_ids => \@addon_ids,
line => $linenr,
tags => \%tags,
config => $canonical,
percent => $percent,
price => $price, # base price
# The following are calculated below, for top-level products only:
# tag_price => base price + sum of transparent addons
# hidden_fees => sum of opaque addons
# total_price => tag_price + hidden_fees
};
}
}
# Resolve addons
PRODUCT: for my $product (values %products) {
my %ids_seen = ($product->{id} => 1);
my @addon_ids = @{ $product->{_addon_ids} };
while (my $addon_id = shift @addon_ids) {
$addon_id = "+$addon_id" if exists $products{"+$addon_id"};
if ($ids_seen{$addon_id}++) {
warn "Infinite addon loop for '$product->{id}' at $filename line $product->{line}.\n";
next PRODUCT;
}
my $addon = $products{$addon_id};
if (not $addon) {
warn "Addon '$addon_id' does not exist for '$product->{id}' at $filename line $product->{line}.\n";
next PRODUCT;
}
$addon = { %$addon }; # shallow copy to overwrite ->{price} later
push @{ $product->{addons} }, $addon;
push @addon_ids, @{ $addon->{_addon_ids} };
}
}
# Calculate tag and total price
PRODUCT: for my $id (keys %products) {
next if $id =~ /^\+/;
my $product = $products{$id};
my $tag_price = $product->{price} || RevBank::Amount->new(0);
my $hidden = 0;
my @seen = ($product);
for my $addon (@{ $product->{addons} }) {
if ($addon->{percent}) {
my $sum = List::Util::sum map {
$_->{price}
} grep {
$_->{contra} eq $addon->{contra}
} @seen;
$addon->{price} = $addon->{percent} / 100 * $sum;
}
if ($addon->{tags}{OPAQUE}) {
$hidden += $addon->{price};
} else {
$tag_price += $addon->{price};
}
push @seen, $addon;
}
$product->{tag_price} = $tag_price;
$product->{hidden_fees} = $hidden;
$product->{total_price} = $tag_price + $hidden;
}
my @changes;
if (%$cache) {
for my $new (values %products) {
next if $new->{is_alias};
my $id = $new->{id};
my $old = $cache->{$id};
if (not defined $old or $new->{config} ne $old->{config}) {
push @changes, [$old, $new];
}
delete $cache->{$id};
}
for my $p (values %$cache) {
next if $p->{is_alias};
push @changes, [$p, undef];
}
call_hooks("products_changed", \@changes, $$mtime);
}
%$cache = %products;
return \%products;
}
1;

View file

@ -1,185 +0,0 @@
=head1 NAME
RevBank::Products - Product list
=head1 SYNOPISIS
# Comments are lines that begin with a # character.
# Empty lines are ignored.
8710447032756 0.80 "Festini Peer"
4029764001807,clubmate 1.40 "Club-Mate" +pf +half
pf 0.15@+pfand "Pfand NRW-Flasche" #OPAQUE
+half -50% "50% discount \\o/"
123 0.42 "Hashtag example" #tag #tag2=42
=head1 DESCRIPTION
This module implements a products database, based on a text file. It supports
additional fees, discounts, compound products, and optional metadata that can
be read by plugins.
=head2 read_products
The only function of this module is exported by default. It returns a reference
to a hash of products (each represented as a hash), keyed by product id.
The available keys per product are currently not documented; refer to the
C<Products.pm> file after the line that is commented C<# HERE> for a list.
=head1 CONFIGURATION
The configuration for this plugin lives in a text file called
C<revbank.products>.
Whitespace at the beginning or end of a line are ignored. Blank lines are
ignored. Comments are lines that start with C<#> and are also ignored. Note
that a whole line is either a comment or a data line; trailing comments are
not supported and C<#> is a valid character in a product description.
Data lines have whitespace-separated columns:
=head2 Product ids
One or more product ids, separated by commas (no whitespace before or after the
commas). There is no way to have a comma or whitespace in a product id, but
every other printable character is valid.
The first product id on the line is considered canonical, the rest are aliases.
Note: if a product id is the same as another RevBank command (e.g. a username),
the first plugin that accepts the command will "win"; the precedence order is
defined by the C<revbank.plugins> configuration file. However, when a product
id appears multiple times within C<revbank.products>, the I<last> one is used.
Product ids that begin with C<+> can only be used as addons. When entered as
user input, it will be ignored by the C<products> plugin.
=head2 Price
The price of the product. This is the price to be deducted from the user's
account when they check out with this product in the cart. When it is a
negative number, the user will instead have money added to their account when
"buying" this product.
Optionally, the price can be augmented with an C<@> sign and the name of the
contra account. When no contra account is specified, C<+sales/products> is used.
Internal accounts (that start with C<-> or C<+>) are created automatically. A
regular account can also be used, but has to exist before the product can be
used.
(Note on internal accounts because they aren't documented elsewhere: liability
and revenue accounts begin with C<+>, asset and expense accounts begin with
C<->. The C<+> accounts typically grow larger over time, while C<-> accounts
typically go negative. In general, you would use a C<+> account in
C<revbank.products>. User accounts are liability accounts.)
=head2 Description
The description, like other columns, may contain whitespace, but to use
whitespace, either the entire field "needs quotes" around it, or the whitespace
can be escaped with backslashes.
It is suggested to always use quotes around the description.
=head2 Additional fields
=head3 Addons
Addons are products that are added as part of the main product. They are
specified after the description, with a C<+> sign that has whitespace before
it, and no whitespace after it.
When specifying an addon C<+foo>, and no product with the id C<+foo> exists,
the product id C<foo> is used instead. The difference is that a product id
C<+foo> can only be used as an addon for another product, while C<foo> can be
used either as an addon or a manually entered as a standalone product.
example_id 2.20 "Example product" +first +second
+first 1.20 "First thing"
second 0.80 "Second thing"
In this example, the final price of the example product will be 4.20. It is not
possible to buy the first thing separate, but it is possible to buy the second
thing separate.
The addon product must be specified in C<revbank.products>; market products
cannot be used as addons.
When a product has addons, it becomes a compound product. This can be used to
separate a product into individual counter accounts for bookkeeping purposes,
to add a bottle deposit, or to add other additional fees or discounts.
When a compound product has a bare price that isn't 0.00, the bare price is
listed as a component named "Product".
A product can have multiple addons. Addon products themselves can also have
further addons, but circular recursion is not supported.
=head4 Percentage addons
As a special case, an addon's price can be a percentage. In this case, the
price is calculated from the sum of the the product components I<up to that
point> that have I<the same contra account> as the percentage addon.
So, given the following example,
example_id 0.90 "Example product" +some_fee +discount
+some_fee 0.15@+fees "Some fee; might be a bottle deposit"
+discount -50% "Special offer discount!"
only 0.45 is discounted, because the 0.15 has a different contra account. While
complicated, this is probably what you want in most cases. There is currently
no way to apply a discount to the product with all of its addons.
A percentage addon must have a product_id that begins with C<+>.
=head3 Tags
Additional metadata can be given in additional fields that begin with C<#> and
the name of the tag, optionally followed by C<=> and a value to turn it into a
key/value pair. If no value is specified, a value of C<1> is used.
The name of a hashtag must contain only C<A-Z a-z 0-9 _> characters. There must
not be whitespace after the C<#> or around the C<=>.
Like all the fields, the field can be quoted to contain whitespace. Note,
however, that the quotes must be placed around the entire field, not just the
value part.
ht1 0.42 "Just one hashtag" #tag
ht2 0.42 "Two hashtags!" #tag #key=value
ht3 0.42 "Surprising syntax" "#x=spaces in value"
Tags can be accessed by custom plugins.
The following tags are used by RevBank itself:
=over 10
=item C<#OPAQUE>
When used on an addon, the price of the addon will be excluded when calculating
the tag price. The default is to use transparent pricing, i.e. that all
additional fees are included in the tag price. In specific cases, such as
container deposits, the addon price should not be considered part of the
product price, and C<#OPAQUE> can be used.
The tag price is not displayed in the RevBank user interface, but may be used
in generated price tags and price listings.
The sum of a product's opaque prices is available via the key C<hidden_fees>.
=back
By convention, tags that affect internal semantics get uppercase names. It is
suggested that tags used only by plugins get C<lowercase> names.
=head3 Other additional fields
When any field is added after the description, that does not begin with C<+> or
C<#>, RevBank currently assumes it's the old syntax (which is not described in
the current version of this document!), and parses it using the old semantics
while showing a warning.
This compatibility feature will be removed from a future version of RevBank.

View file

@ -1,134 +0,0 @@
package RevBank::Prompt;
use v5.32;
use warnings;
use feature qw(signatures isa);
no warnings "experimental::signatures";
use List::Util qw(uniq);
use Term::ReadLine;
require Term::ReadLine::Gnu; # The other one sucks.
use RevBank::Global;
my %escapes = (a => "\a", r => "\r", n => "\n", t => "\t", 0 => "\0");
my %unescapes = reverse %escapes;
my $unescapes = join "", keys %unescapes;
sub split_input($input) {
$input =~ s/\s+$//;
my @terms;
my $pos = 0;
my $lastpos = 0;
my sub _P($nudge = 0) { $pos = pos($input) + $nudge; }
while (
$input =~ m[
\G \s*+
(?| (') (?{_P -1}) ( (?: \\. | [^\\'] )*+ ) ' (?{_P}) (?=\s|;|$)
| (") (?{_P -1}) ( (?: \\. | [^\\"] )*+ ) " (?{_P}) (?=\s|;|$)
| () ( (?: \\. | [^\\;'"\s] )++ ) (?{_P}) (?=\s|;|$)
| () (;)
)
]xg
) {
push @terms, (
(not $1) && $2 eq ";" ? "\0SEPARATOR"
: (not $1) && $2 eq "abort" ? "\0ABORT"
: $1 && $2 eq "abort" ? "abort"
: $2
);
$lastpos = pos($input) || 0;
$pos ||= $lastpos;
}
# End of string not reached
return \$pos if $lastpos < length($input);
# End of string reached
s[\\(.)]{ $escapes{$1} // $1 }ge for @terms;
return @terms;
}
sub reconstruct($word) {
$word =~ s/([;'"\\])/\\$1/g;
$word =~ s/\0SEPARATOR/;/;
$word =~ s/([$unescapes])/\\$unescapes{$1}/g;
$word = "'$word'" if $word =~ /\s/ or $word eq "abort";
return $word;
}
sub prompt($prompt, $completions = [], $default = "", $pos = 0, $cart = undef, $plugins = []) {
state $readline = Term::ReadLine->new($0);
my $attribs = $readline->Attribs;
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;
$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 $begin = my $time = time;
$attribs->{event_hook} = sub {
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;
main::abort($reason);
}
state $last_pos = 0;
if ($attribs->{point} != $last_pos) {
$begin = time;
$last_pos = $attribs->{point};
}
if (time > $time) {
$time = time;
call_hooks(
"prompt_idle",
$cart,
(@$plugins > 1 ? undef : $plugins->[0]), # >1 plugin = main loop
$time - $begin,
$readline,
);
}
};
$attribs->{startup_hook} = sub {
$attribs->{point} = $pos;
};
$readline->ornaments(0);
my $input = $readline->readline($prompt, $default);
print "\e[0m";
return undef if not defined $input;
$input =~ s/^\s+//; # trim leading whitespace
$input =~ s/\s+$//; # trim trailing whitespace
return $input;
}
1;

View file

@ -1,198 +0,0 @@
package RevBank::TextEditor;
use v5.32;
use warnings;
use experimental 'signatures'; # stable since v5.36
use autodie;
use RevBank::Global;
use Fcntl qw(:flock);
use Carp qw(croak);
use Time::HiRes qw(sleep);
my $tab = 4;
sub _require {
if (not eval { require Curses::UI }) {
my $install = -e "/etc/debian_version"
? "apt install libcurses-ui-perl"
: "cpan Curses::UI";
die "Couldn't load the Perl module Curses::UI.\n" .
"Please install it! (sudo $install)\n";
}
}
sub _find_next($win, $textref) {
my $editor = $win->getobj('editor');
my $find = $win->getobj('find');
my $a = $find->getobj('answer');
my $b = $find->getobj('buttons');
my $q = $a->get;
pos($$textref) = $editor->pos;
my $status = "not found";
my $offset;
if ($$textref =~ /\Q$q/gi) {
$status = "found";
$offset = $+[0];
} else {
$editor->pos(0);
pos($$textref) = 0;
if ($$textref =~ /\Q$q/gi) {
$status = "wrapped";
$offset = $+[0];
}
}
$find->{-title} = ucfirst $status;
if ($status ne "not found") {
$editor->pos($offset);
$editor->{-search_highlight} = $editor->{-ypos};
} else {
$editor->{-search_highlight} = undef;
}
$win->draw;
}
sub _find($win) {
my $editor = $win->getobj('editor');
my $text = $editor->get;
my $find = $win->add(
'find', 'Dialog::Question',
-question => "Search for:",
-buttons => [
{ -label => '[Find next]', -onpress => sub {
_find_next($win, \$text);
} },
{ -label => '[Cancel]', -onpress => sub {
$win->getobj('find')->loose_focus;
$editor->{-search_highlight} = undef;
} },
]
);
my $a = $find->getobj('answer');
my $b = $find->getobj('buttons');
$a->onFocus( sub { shift->pos(999) } );
$a->set_binding(sub {
$b->{-selected} = 0; # [Find next]
$b->focus;
$b->press_button;
$win->draw;
}, Curses::KEY_ENTER());
$find->set_binding(sub {
$b->{-selected} = 1; # [Cancel]
$b->focus;
$b->press_button;
$win->draw;
}, "\cX", "\cC");
$b->set_routine('press-button' => sub { $b->press_button });
$find->modalfocus;
$win->delete('find');
}
sub _editor($title, $origdata, $readonly = 0) {
our $cui ||= Curses::UI->new;
my $win = $cui->add('main', 'Window');
$title = $readonly
? "[$title] Press q to quit"
: "[$title] Ctrl+X: exit Ctrl+F: find Ctrl+C/K/V: copy/cut/paste";
my $editor = $win->add(
'editor', 'TextEditor',
-title => $title,
-text => $origdata,
-border => 1,
-padbottom => 1, # ibm3151/screen lastline corner glitch workaround
-wrapping => 0,
-hscrollbar => 0,
-vscrollbar => 0,
-pos => ($readonly == 2 ? length($origdata) : 0),
#-readonly => !!$readonly # does not support -pos
);
my $return;
if ($readonly) {
$editor->readonly(1); # must be before bindings
$editor->set_binding(sub { $cui->mainloopExit }, "q") if $readonly;
} else {
my @keys = (
[ Curses::KEY_HOME() => 'cursor-scrlinestart' ],
[ Curses::KEY_END() => 'cursor-scrlineend' ],
[ "\cK" => 'delete-line' ], # nano (can't do meta/alt for M-m)
[ "\cU" => 'paste' ], # nano
[ "\c[" => sub { } ],
[ "\cL" => sub { $cui->draw } ],
[ "\c^" => sub { $editor->pos(0) } ],
[ "\c_" => sub { $editor->pos(length($editor->get)) } ],
[ "\cG" => sub { $editor->pos(length($editor->get)) } ],
[ "\cI" => sub { $editor->add_string(" " x ($tab - ($editor->{-xpos} % $tab))) } ],
[ "\cS" => sub { $cui->dialog("Enable flow control :)") } ],
[ "\cQ" => sub {} ],
[ "\cC" => sub { $editor->{-pastebuffer} = $editor->getline_at_ypos($editor->{-ypos}) } ],
[ "\cF" => sub { _find($win) } ],
[ "\cX" => sub {
if ($editor->get ne $origdata) {
my $answer = $cui->dialog(
-message => "Save changes?",
-buttons => [
{ -label => "[Save]", -value => 1 },
{ -label => "[Discard]", -value => 0 },
{ -label => "[Cancel]", -value => -1 },
],
-values => [ 1, 0 ],
);
$return = $editor->get if $answer == 1;
$cui->mainloopExit if $answer >= 0;
} else {
$cui->mainloopExit;
}
} ],
);
$editor->set_binding(reverse @$_) for @keys;
}
$editor->focus();
$cui->mainloop;
$cui->leave_curses;
$cui->delete('main');
return $return;
}
sub edit($filename) {
_require();
open my $fh, ">>", $filename;
flock $fh, LOCK_EX | LOCK_NB
or die "Someone else is alreading editing $filename.\n";
my $save = _editor($filename, scalar slurp $filename);
if (defined $save) {
spurt $filename, $save;
print "$filename updated.\n";
} else {
print "$filename not changed.\n";
}
}
sub pager($title, $data) {
_require();
_editor($title, $data, 1);
}
sub logpager($title, $data) {
_require();
_editor($title, $data, 2);
}
1;

View file

@ -1,37 +0,0 @@
=head1 NAME
RevBank::TextEditor - Basic Lightweight User-friendly TextEditor
=head1 SYNOPSIS
require RevBank::TextEditor;
RevBank::TextEditor::edit($filename);
=head1 DESCRIPTION
BLUT is a built-in text editor based on Curses::UI.
It was made because vim is too hard for unprepared newbies, and nano too,
really: not everyone knows that C<^X> means Ctrl+X, making nano almost as hard
to exit as vim. And of course, none of the really user friendly editors out
there would work well on our old IBM 3151 terminal. (For instance, C<^S> and
C<^Q> are used for software flow control, or as the manual of said terminal
calls it, "pacing".)
And of course, all the editors out there will let you open other files, or even
run shells...
=head2 Functions
=head3 edit($filename)
Runs the editor.
=head2 CAVEATS
=over 2
=item * It's a really dumb editor, and many unsupported presses will end up as
garbage.
=back

View file

@ -1,81 +1,50 @@
package RevBank::Users;
use v5.32;
use warnings;
use experimental 'signatures'; # stable since v5.36
use strict;
use RevBank::Global;
use RevBank::Plugins;
use Carp ();
use List::Util ();
my $filename = "revbank.accounts";
sub _read() {
sub _read {
my @users;
for my $line (slurp $filename) {
$line =~ /\S/ or next;
# Not using RevBank::Prompt::split_input to keep parsing by external
# scripts simple, since so many such scripts exist.
my @split = split " ", $line;
if ($split[1] =~ /^!/) {
# Special case: use rest of the line (see POD).
@split = split " ", $line, 2;
}
push @users, \@split;
}
my %users;
for (@users) {
my $name = lc $_->[0];
exists $users{$name} and die "$filename: duplicate entry '$name'\n";
$users{$name} = $_;
if ($name =~ s/^\*//) {
# user-accessible special account: support without * prefix
exists $users{$name} and die "$filename: duplicate entry '$name'\n";
$users{$name} = $_;
}
}
return \%users;
open my $fh, $filename or die $!;
/\S/ and push @users, [split " "] while readline $fh;
close $fh;
return { map { lc($_->[0]) => $_ } @users };
}
sub names() {
# uniq because *foo causes population of keys '*foo' and 'foo', with
# ->[0] both being 'foo'. However, the keys are lowercase, not canonical.
return List::Util::uniqstr map $_->[0], values %{ _read() };
sub names {
return map $_->[0], values %{ _read() };
}
sub balance($username) {
return RevBank::Amount->parse_string( _read()->{ lc $username }->[1] );
sub balance {
my ($name) = @_;
return _read()->{ lc $name }->[1];
}
sub since($username) {
return _read()->{ lc $username }->[3];
sub since {
my ($name) = @_;
return _read()->{ lc $name }->[3];
}
sub create($username) {
die "Account already exists" if exists _read()->{ lc $username };
sub create {
my ($username) = @_;
open my $fh, '>>', $filename or die $!;
my $now = now();
append $filename, "$username 0.00 $now\n";
print {$fh} "$username 0.00 $now\n" or die $!;
close $fh or die $!;
RevBank::Plugins::call_hooks("user_created", $username);
return $username;
}
sub update($username, $delta, $transaction_id) {
my $account = assert_user($username) or die "No such user ($username)";
my $old = RevBank::Amount->new(0);
my $new = RevBank::Amount->new(0);
rewrite $filename, sub($line) {
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 $account) {
if (lc $a[0] eq lc $username) {
$old = RevBank::Amount->parse_string($a[1]);
die "Fatal error: invalid balance in revbank:accounts:$.\n"
if not defined $old;
@ -83,64 +52,31 @@ sub update($username, $delta, $transaction_id) {
$new = $old + $delta;
my $since = $a[3] // "";
$since = "+\@" . now() if $new > 0 and (!$since or $old <= 0);
$since = "-\@" . now() if $new < 0 and (!$since or $old >= 0);
$since = "0\@" . now() if $new == 0 and (!$since or $old != 0);
my $newc = $new->cents;
my $oldc = $old->cents;
$since = "+\@" . now() if $newc > 0 and (!$since or $oldc <= 0);
$since = "-\@" . now() if $newc < 0 and (!$since or $oldc >= 0);
$since = "0\@" . now() if $newc == 0 and (!$since or $oldc != 0);
return sprintf "%-16s %9s %s %s\n", (
$account, $new->string("+"), now(), $since
);
printf {$out} "%-16s %9s %s %s\n", (
$username, $new, now(), $since
) or die $!;
} else {
return $line;
print {$out} $line or die $!;
}
};
}
close $out or die $!;
close $in;
rename ".revbank.$$", "revbank.accounts" or die $!;
RevBank::Plugins::call_hooks(
"user_balance", $account, $old, $delta, $new, $transaction_id
"user_balance", $username, $old, $delta, $new, $transaction_id
);
}
sub is_hidden($username) {
return $username =~ /^[-+]/;
}
sub is_special($username) {
return $username =~ /^[-+*]/;
}
sub parse_user($username, $allow_invalid = 0) {
return undef if is_hidden($username);
sub parse_user {
my ($username) = @_;
my $users = _read();
my $user = $users->{ lc $username } or return undef;
if ($user->[1] =~ /^!(.*)/) {
warn "$username: Invalid account ($1).\n";
}
$allow_invalid or defined balance($username)
or return undef;
return $user->[0];
}
sub assert_user($username) {
my $users = _read();
my $user = $users->{ lc $username };
if ($user) {
Carp::croak("Account $username can't be used") if not defined balance $username;
return $user->[0];
}
return create $username if is_hidden $username;
Carp::croak("No such user ($username)")
return undef if not exists $users->{ lc $username };
return $users->{ lc $username }->[0];
}
1;

View file

@ -1,162 +0,0 @@
=head1 NAME
RevBank::Users - Banking and bookkeeping accounts
=head1 DESCRIPTION
This package handles all accounts in RevBank. Accounts are called "users" because originally, RevBank only had user accounts. Today, RevBank does doubly-entry bookkeeping and has multiple account types to accommodate that.
This package is where manipulation of C<revbank.accounts> happens.
=head2 Account types
=over 4
=item * User accounts
User accounts are typically made with the C<adduser> command, and almost all interactions with RevBank will involve only user accounts, from the perspective of the user.
=item * Hidden accounts
The name of a hidden account begins with a C<-> or C<+> sign. These accounts are created automatically by plugins to provide the I<double> part in I<doubly-entry bookkeeping>.
Hidden accounts are internal accounts in the sense that they are not displayed and can't be used in the CLI where user accounts can.
There is no technical difference between C<+> and C<->, but it is suggested to use C<-> for accounts that will typically go negative and would be flipped to a positive number to make intuitive sense.
For example, the C<-cash> account will go to C<-4.20> when someone deposits 4.20 into the cash box. It has to be a negative number, to balance the positive number added to the balance of the user. But the cash box will contain 4.20 more than before, even though the number is negative.
Some plugins will use C</> to establish hierarchical account names in hidden accounts, like in C<+sales/products>. To RevBank, C</> is just a regular character, and it has no specific semantics for these hierarchies.
=item * User-accessible special accounts
The name of a user-accessible special account begins with a C<*> sign. A special account can only be created by editing the C<revbank.accounts> file manually. They can be used like user accounts, with or without the C<*> sign, but they do not count towards the grand total of user accounts.
The suggested use for user-accessible special accounts is for creating accounts that are virtual jars. For example, if users pay towards a virtual jar for kitchen equipment when they use the kitchen (like in the C<dinnerbonus> plugin), but are also allowed to use those funds for buying kitchen equipment, a user-accessible special account might be more convenient than having separate revenue and expense accounts, especially because those would typically be hidden accounts.
=back
=head3 Bookkeeping
While RevBank does double-entry bookeeping, it does not use the terms I<credit> and I<debit> anywhere. Everything is just plus or minus. To use the data in bookkeeping software, some translation is required.
There are many systems for bookkeeping. In the accounting equation approach, RevBank's account types would translate as:
=over 4
=item * user accounts
Liabilities accounts
=item * hidden accounts (C<+>)
Revenues/incomes accounts.
=item * hidden accounts (C<->)
Expenses/losses accounts, or assets accounts.
=item * user-accessible special accounts (C<*>)
This one is slightly more complicated, because this depends on your view on accounting. From a pure bookkeeping perspective, this would be a liabilities account because it is technically equivalent to a user account, but it would make sense to book additions as revenue and deductions as expenses.
=back
=head2 Data format
The file C<revbank.accounts> is a text file with one record per line, and whitespace separated fields. The columns are:
=over 4
=item * Account name
The account name can be anything, but cannot contain whitespace. Special accounts begin with C<+>, C<->, or C<*>.
Account names are case preserving, but case insensitive.
Every account name must be unique. A file with duplicate names is not valid and may lead to crashes or undefined behavior. Since C<*foo> can be used as either C<*foo> or C<foo>, it is not allowed to have both C<*foo> and C<foo> in the accounts file.
=item * Balance
The account balance is a number with two decimal digits. Positive numbers may have a C<+> sign. Negative number have a C<-> sign.
If the value in this field is not a valid number, the account is treated as non-existent by most of RevBank, while still being unavailable for C<adduser>.
If the value begins with a C<!> character, the I<rest of the line> is taken as a description of why the account name is not available and printed as a warning when the account name is used.
=item * Last use timestamp
Local datetime of the last update of this account.
=item * Zero-crossing timestamp
Local datetime of the last time the balance went through 0.00. The timestamp is preceded with C<-@>, C<+@>, or C<0@> to indicate the direction of the crossing: C<-@> can be read as "became negative at", etc.
This field is empty for accounts that have not yet been used.
=back
Only the first two columns are mandatory. This makes migrating to RevBank very simple.
=head2 Functions
Usernames are case preserving, but case insensitive. Account name arguments to functions are case insensitive, but return values use the canonical capitalization.
Anything that outputs a username should always run it through C<parse_user> or C<assert_user>.
=head3 names
Returns a list of all account names.
=head3 balance($name)
Returns a RevBank::Amount that represents the balance of the account.
=head3 since($name)
Returns the last used datetime of the account.
=head3 create($name)
Creates an account with that name and a balance of zero. The name must not already exist.
After updating the file, calls the C<user_created> hook with the account name.
=head3 update($name, $delta, $transaction_id)
Given the relative change (C<$delta>), updates the user balance for an account.
After updating the file, calls the C<user_balance> hook with the account name, the old balance, the given delta, the new balance, and the transaction_id.
This function should not be used directly; instead, create a transaction via C<RevBank::Cart> and use C<checkout> to ensure a balanced booking for proper double-entry bookkeeping.
=head3 is_hidden($name)
Returns true if the account is hidden (begins with C<+> or C<->).
=head3 is_special($name)
Returns true if the account is hidden (begins with C<+> or C<->), or user-accessible but special (begins with C<*>).
=head3 parse_user($username)
Returns the canonical account name if the user account exists, or undef if it does not exist.
=head3 assert_user($name)
For a hidden account, returns the canonical account name, creating the account if it did not already exist.
For a non-hidden account, works like parse_user.
=head1 CAVEATS
The identifiers can be confusing and most instances of C<user> should probably be renamed to C<account>.
=head1 AUTHOR
Juerd Waalboer <#####@juerd.nl>
=head1 LICENSE
Pick your favorite OSI license.

View file

@ -1,26 +0,0 @@
#!perl
HELP "3dprint <gram>" => "3D-print filament afrekenen";
use Scalar::Util qw(looks_like_number);
sub command :Tab(3dprint) ($self, $cart, $command, @) {
return NEXT if $command ne '3dprint';
return "Gewicht in gram, inclusief supports en purges", \&gram;
}
sub gram($self, $cart, $input, @) {
looks_like_number($input) and $input == int($input) or return REJECT, "Invalid number!";
my $gram = int($input);
return REJECT, "$input: Invalid amount." if $gram <= 0;
my $beneficiary = "3dprinter";
my $amount = 0.10 + $gram * 0.03;
$cart
->add(-$amount, "Given to $beneficiary ($gram g)")
->add_contra($beneficiary, +$amount, "Received from \$you (${gram} g)");
return ACCEPT;
}

View file

@ -1,10 +1,10 @@
#!perl
use List::Util qw(any);
HELP "adduser <name>" => "Create an account";
HELP1 "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,25 +14,17 @@ sub command :Tab(adduser) ($self, $cart, $command, @) {
return "Name for the new account", \&username;
}
sub username($self, $cart, $name, @) {
return REJECT, "Sorry, only A-Z a-z 0-9 _ - + / ^ * [] {} are allowed."
if $name !~ /^[A-Za-z0-9_\-+\/\^*\[\]{}-]+\z/;
sub username {
my ($self, $cart, $name) = @_;
return REJECT, "Sorry, - + / ^ * are not allowed as the first character."
if $name =~ /^[-+*\/\^]/;
return REJECT, "Sorry, whitespace is not allowed."
if $name =~ /\s/;
return REJECT, "Sorry, that's too numeric to be a user name."
if defined RevBank::Amount->parse_string($name);
return REJECT, "That's too numeric to be a user name."
if defined parse_amount($name);
return REJECT, "That name is not available."
if defined parse_user($name, 1);
for my $plugin (RevBank::Plugins->new) {
my $id = $plugin->id;
return REJECT, "That name would clash with the '$id' plugin."
if any sub { $_ eq $name }, $plugin->Tab('command');
}
return REJECT, "That name already exists."
if defined parse_user($name);
RevBank::Users::create( $name );

View file

@ -1,12 +0,0 @@
sub command($self, $cart, $command, @) {
if ($command eq 'adduser') {
print <<'END';
NOTE: This system is insecure by design. Other users can see your transactions,
or pay using your account. We trust each other not to abuse this power.
END
}
return NEXT;
}

View file

@ -1,11 +1,14 @@
#!perl
sub command { NEXT }
*hook_plugin_fail = *hook_retry = *hook_reject = *hook_invalid_input = sub {
call_hooks('beep');
undef;
};
sub hook_abort($class, $cart, $reason, @) {
sub hook_abort {
my ($self, $cart, $reason) = @_;
return if not $reason or not @$reason;
return if "@$reason" eq '^C';

View file

@ -1,10 +1,14 @@
#!perl
sub command { NEXT }
# So you want a different beep mechanism...
#
# Don't just edit this plugin. Instead, COPY this file and add yours to
# revbank.plugins
sub hook_beep($class, @) {
sub hook_beep {
my ($class) = @_;
print "\a";
}

View file

@ -1,17 +0,0 @@
#!perl
sub command :Tab(bigmoney) {
my ($self, $cart, $command) = @_;
return NEXT if $command ne "bigmoney";
my @list = sort {
(split " ", $b)[1] <=> (split " ", $a)[1]
} grep {
not RevBank::Users::is_hidden($_)
} slurp("revbank.accounts");
print join "", @list[0..9];
return ACCEPT;
}

View file

@ -1,19 +0,0 @@
#!perl
use Cwd ();
sub command { NEXT }
sub hook_checkout_done {
my ($class, $cart, $username, $transaction_id) = @_;
my @cart_printed = map { "\n-> $_" } map { $_->as_printable } $cart->entries;
my $fn = "/tmp/revbank$$.commit";
open my $fh, ">", $fn or warn $!;
print $fh "$username ($transaction_id)\n@cart_printed";
close $fh or warn $!;
my $output = `(cp revbank.accounts revbank.market revbank.products ~/data.git/ && cd ~/data.git/ && git commit -a -F $fn) 2>&1`;
warn "Meh, gitfaal: $output" if $?;
}

View file

@ -1,19 +0,0 @@
#!perl
use Cwd ();
use Net::MQTT::Simple;
my $mqtt = Net::MQTT::Simple->new("mqtt.bitlair.nl");
sub command { NEXT }
sub hook_checkout {
my ($class, $cart, $user, $transaction_id) = @_;
my @entries = $cart->entries('product_id') or return;
for my $entry (@entries) {
$mqtt->publish("bitlair/pos/product" => $entry->{description})
for 1..$entry->quantity;
}
}

View file

@ -1,15 +0,0 @@
#!perl
use IO::Socket::IP;
use Net::MQTT::Simple "mqtt.bitlair.nl";
sub command { NEXT }
sub hook_user_balance {
my ($class, $user, $old, $delta, $new, $transaction_id) = @_;
return if $new >= -13.37;
return if RevBank::Users::is_hidden($user);
publish "bitlair/bank/shame" => "NO MUNNIE?";
}

View file

@ -1,100 +0,0 @@
#!perl
# Use this plugin for cashbox contents tracking. For it to make sense,
# you will also need the "deposit_methods" plugin to let users distinguish
# between cash deposits and other deposit methods.
# This plugin should be loaded *before* the 'stock' plugin in
# the 'revbank.plugins' configuration file.
HELP1 "cash" => "Checkout without a user account";
sub command :Tab(cash) ($self, $cart, $command, @) {
return NEXT if $command ne 'cash';
if ($cart->size) {
return REJECT, "Can't use cash checkout on a deposit transaction."
if $cart->entries('is_deposit');
return REJECT, "Can't use cash checkout on a withdraw transaction."
if $cart->entries('is_withdrawal');
$cart->checkout('-cash');
} else {
call_hooks 'cash';
return "Please count the money to verify. How much is there, exactly?", \&check;
}
return ACCEPT;
}
sub hook_cash($class, @) {
printf "There should currently be (at least) %s in the cash box.\n",
-RevBank::Users::balance("-cash") || "0.00";
}
our $suppress = 0;
sub hook_user_balance($class, $username, $old, $delta, $new, @) {
return if $username ne '-cash' or $delta->cents == 0;
return if $suppress;
# "-" accounts need to be inverted to display the intuitive value.
my $actual_delta = -$delta;
my $actual_new = -$new;
printf "\nProceed to %s %s %s the cash box;\n it should then have (at least) %s%s.\n",
($actual_delta->cents < 0 ? "remove" : "put"),
abs($delta),
($actual_delta->cents < 0 ? "from" : "into"),
$actual_new,
($actual_delta->cents < 0 ? " remaining" : " in it");
}
my $confirm_prompt = "Type 'fix pls' to apply a permanent correction, or 'abort' to abort";
sub check($self, $cart, $arg, @) {
my $should = -RevBank::Users::balance("-cash") || parse_amount(0);
my $have = parse_amount($arg);
return REJECT, "Invalid amount" if not defined $have;
if ($have == $should) {
print "Thank you for checking!\n";
return ACCEPT;
}
my $surplus = $have - $should;
$self->{surplus} = $surplus;
my $what = $surplus < 0 ? "shortage" : "overage";
$self->{what} = $what;
my $abs = abs $surplus;
my $suffix =
$surplus <= -100 ? "??!! WTF?! Really?!"
: $surplus <= -20 ? "! :("
: $surplus <= -10 ? "!"
: $surplus >= +20 ? "?!"
: ".";
my $an = $what =~ /^o/ ? "an" : "a";
print "\nThank you for checking! That's $an $what of $abs$suffix\n";
return $confirm_prompt, \&confirm;
}
sub confirm($self, $cart, $arg, @) {
return $confirm_prompt, \&confirm unless $arg eq "fix pls";
$cart
->add($self->{surplus}, "Cash $self->{what}")
->add_contra("-cash", -$self->{surplus}, "Cash $self->{what}");
local $suppress = 1;
$cart->checkout('-expenses/discrepancies');
printf "\nDiscrepancy recorded; corrected cash box amount is %s.\n",
-RevBank::Users::balance("-cash") || "0.00";
return ACCEPT;
}

View file

@ -1,22 +0,0 @@
sub open_drawer {
warn "The cash_drawer plugin should be changed to actually implement the opening of a cash drawer; stub code executed";
}
sub hook_add_entry($class, $cart, $entry, @) {
$entry->attribute('is_deposit') and $entry->attribute('method') =~ /reimburse|cash/
or $entry->attribute('is_withdrawal')
or return;
open_drawer();
}
sub hook_cash {
open_drawer();
}
sub hook_checkout($class, $cart, $user, $transaction_id, @) {
$user eq '-cash' or return;
open_drawer();
}

View file

@ -1,31 +0,0 @@
#!perl
# Deduplication merges duplicate entries in the cart, e.g.
# 3x cola + 4x cola = 7x cola.
#
# Plugins that support this, set the "deduplicate" attribute to a string key
# that is used to determine which entries are equal. It is the responsibility
# of the plugin that sets this, to ensure that the entries are indeed exactly
# the same, if their deduplicate keys are equal.
#
# The recommended value for the deduplicate attribute is join("/", $plugin_id,
# $unique_id), where $plugin_id can be obtained from $self->id in interactive
# methods or $class->id in hooks. Including the plugin id avoids deduplicating
# across plugins, that are probably not aware of eachothers $unique_id's.
use List::Util qw(sum any);
sub hook_added_entry($class, $cart, $added_entry, @) {
my $key = $added_entry->attribute('deduplicate') or return;
my @dedupe = grep {
$_->attribute('deduplicate') eq $key
} $cart->entries('deduplicate');
@dedupe >= 2 or return;
$dedupe[0]->quantity(sum map { $_->quantity } @dedupe);
$cart->select($dedupe[0]);
$cart->delete($_) for @dedupe[1 .. $#dedupe];
}

View file

@ -2,39 +2,34 @@
# This plugin must at the end in the plugins file.
HELP1 "deposit <amount>" => "Deposit into an account";
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;
my $prompt = "Amount to deposit into your account";
call_hooks("deposit_command", \$prompt, $self->{alternatives} = []);
return $prompt, \&amount;
return "Amount to deposit into your account", \&amount;
}
sub amount :Tab(13.37,42) ($self, $cart, $input, @) {
for my $sub (@{ $self->{alternatives} }) {
my @rv = $sub->(undef, $cart, $input);
return @rv if $rv[0] != NEXT;
}
sub amount :Tab(13.37,42) {
my ($self, $cart, $amount) = @_;
$self->{amount} = my $amount = parse_amount($input)
or return REJECT, "Invalid input.";
$self->{amount} = parse_amount($amount)
or return REJECT, "Invalid amount";
call_hooks("deposit_methods", \my $message, $self->{deposit_methods} = {});
return $message . "How are we receiving this $amount?", \&how
if keys %{ $self->{deposit_methods} };
$cart
->add(+$amount, "Deposit", { is_deposit => 1 })
->add_contra("-deposits/other", -$amount, "Deposited by \$you");
$cart->add(+$self->{amount}, "Deposit", { is_deposit => 1 });
return ACCEPT;
}
sub how :Tab(&how_tab) ($self, $cart, $input, @) {
sub how :Tab(&how_tab) {
my ($self, $cart, $input) = @_;
my %methods = %{ $self->{deposit_methods} };
my $how = $self->{how} = $methods{$input}
@ -46,27 +41,18 @@ sub how :Tab(&how_tab) ($self, $cart, $input, @) {
return shift @{ $how->{prompts} }, \&how_prompt;
}
if ( ($input eq "iban") && ($self->{amount} < 10 || $self->{amount} == 25) ) {
return REJECT, "\n\e[31;1mPlease transfer at least 10 EUR and not 25 or 32 EUR when using iban\e[0m\n\n";
}
my $contra =
$how->{_key} eq 'cash' ? '-cash'
: $how->{_key} eq 'reimburse' ? '-expenses/reimbursed'
: "-deposits/$how->{_key}";
$cart
->add(+$self->{amount}, $how->{description}, { is_deposit => 1, method => $how->{_key} })
->add_contra($contra, -$self->{amount}, "$how->{description} by \$you");
$cart->add(+$self->{amount}, $how->{description}, { is_deposit => 1, method => $how->{_key} });
return ACCEPT;
}
sub how_tab($self, @) {
sub how_tab {
my ($self) = @_;
return keys %{ $self->{deposit_methods} };
}
sub how_prompt($self, $cart, $input, @) {
sub how_prompt {
my ($self, $cart, $input) = @_;
my $how = $self->{how};
push @{ $how->{answers} }, $input;
@ -76,11 +62,7 @@ sub how_prompt($self, $cart, $input, @) {
}
my $desc = sprintf $how->{description}, @{ $how->{answers} };
my $contra = $how->{_key} eq 'cash' ? '-cash' : "-deposits/$how->{_key}";
$cart
->add(+$self->{amount}, $desc, { is_deposit => 1, method => $how->{_key} })
->add_contra($contra, -$self->{amount}, "$desc by \$you");
$cart->add(+$self->{amount}, $desc, { is_deposit => 1, method => $how->{_key} });
return ACCEPT;
}

View file

@ -20,10 +20,14 @@
use IPC::Open2 qw(open2);
use List::Util qw(sum);
my $iban = "NL89RABO0111741386";
my $beneficiary = "Stichting Bitlair";
my $iban = "NL99ABCD1234567890";
my $beneficiary = "Account Name";
sub command { NEXT }
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;
@ -41,7 +45,7 @@ sub hook_checkout($class, $cart, $user, $transaction_id, @) {
"EUR" . $amount, # Amount
"",
"",
"Deposit $user (RB QR)",
"rb $user",
"",
);
close $in;
@ -52,13 +56,11 @@ sub hook_checkout($class, $cart, $user, $transaction_id, @) {
waitpid($pid, 0);
$lines[1] =~ s/$/ Note: Bunq and ING are the only/;
$lines[2] =~ s/$/ Dutch banks that support these/;
$lines[3] =~ s/$/ EPC QR codes. N26 also works./;
$lines[1] =~ s/$/ Note: ASN, Bunq, ING, and SNS are/;
$lines[2] =~ s/$/ the only Dutch banks that support/;
$lines[3] =~ s/$/ these EPC QR codes./;
$lines[5] =~ s/$/ For manual transfers, use this/;
$lines[6] =~ s/$/ IBAN: $iban/;
$lines[7] =~ s/$/ Benificiary: $beneficiary/;
$lines[8] =~ s/$/ Description: Deposit $user/;
print @lines;
}

View file

@ -1,15 +1,18 @@
#!perl
sub hook_deposit_methods($class, $message, $hash, @) {
sub command { NEXT }
sub hook_deposit_methods {
my ($class, $message, $hash) = @_;
$$message = <<"END";
Please type one of the following:
'iban': IBAN transfer (Min 10 EUR / NL89 RABO 0111 7413 86)
'iban': IBAN transfer (NL 69 ABNA 0431 1582 07)
'cash': Cash in the cash box
'reimburse': Reimbursement of expenses agreed upon in advance
Note #1: we require an invoice or receipt with this exact amount!
Note #2: please do not use this plugin for amounts >20 EUR
Note: we require an invoice or receipt with this exact amount!
'other': Provide a manual description
END

View file

@ -1,10 +0,0 @@
#!perl
sub command :Tab(withdraw) ($self, $cart, $command, @) {
if (defined eval { parse_amount($command) }) {
warn "Note: raw amounts for withdrawal or unlisted products are no longer supported.\n\n";
warn "Please use the 'withdraw' command to take money out of your revbank account, or\n";
warn "the 'unlisted' command to pay for an unlisted product.\n\n";
}
return NEXT;
}

View file

@ -4,7 +4,9 @@ HELP "dinnerbonus" => "Add fee for cooking supplies";
my $bonus = 1.00;
sub command :Tab(kookbonus,dinnerbonus) ($self, $cart, $command, @) {
sub command :Tab(kookbonus,dinnerbonus) {
my ($self, $cart, $command) = @_;
my @users = map $_->{user}, map $_->contras, $cart->entries('is_take');
(@users and $command eq 'kookpotje') # common mistake promoted to feature

View file

@ -1,13 +0,0 @@
#!perl
HELP "edit" => "Edit product list";
my $filename = 'revbank.products';
sub command :Tab(edit) ($self, $cart, $command, @) {
$command eq 'edit' or return NEXT;
require RevBank::TextEditor;
RevBank::TextEditor::edit($filename);
return ACCEPT;
}

View file

@ -2,39 +2,46 @@
HELP "give <account> <amount> [<reason>]" => "Transfer money to user's account";
sub command :Tab(give) ($self, $cart, $command, @) {
sub command :Tab(give) {
my ($self, $cart, $command) = @_;
return NEXT if $command ne 'give';
return "Beneficiary", \&beneficiary;
}
sub beneficiary :Tab(USERS) ($self, $cart, $input, @) {
sub beneficiary :Tab(USERS) {
my ($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($self, $cart, $input, @) {
sub amount {
my ($self, $cart, $input) = @_;
$self->{amount} = parse_amount($input)
or return REJECT, "$input: Invalid amount.";
return "Short description ('x' for no message)", \&reason;
return "Why are you giving $self->{amount} to $self->{beneficiary}, or enter your username to end", \&reason;
}
sub reason :Tab(whatevah) ($self, $cart, $input, @) {
return REJECT, "'$input' is a username, not a description :)."
if parse_user($input);
return REJECT, "'$input' is an amount, not a description :)."
if parse_amount($input);
sub reason :Tab(whatevah) {
my ($self, $cart, $input) = @_;
my $beneficiary = $self->{beneficiary};
my $amount = $self->{amount};
my $reason = $input =~ /^x?$/ ? "" : " ($input)";
my $user = parse_user($input);
my $reason = $user ? "" : " ($input)";
$cart
->add(-$amount, "Give to $beneficiary" . $reason)
->add(-$amount, "Given to $beneficiary" . $reason)
->add_contra($beneficiary, +$amount, "Received from \$you" . $reason);
$cart->checkout($user) if $user;
return ACCEPT;
}

View file

@ -2,24 +2,24 @@
HELP "grandtotal" => "Summary of all accounts";
sub command :Tab(grandtotal) ($self, $cart, $command, @) {
sub command :Tab(grandtotal) {
my ($self, $cart, $command) = @_;
return NEXT if $command ne 'grandtotal';
my $pos = 0;
my $neg = 0;
for my $line (slurp 'revbank.accounts') {
my ($username, $balance) = split " ", $line;
next if RevBank::Users::is_special($username);
my $credit = RevBank::Amount->parse_string($balance) or next;
open my $fh, "<", "revbank.accounts";
while (defined(my $line = readline $fh)) {
my $credit = (split " ", $line)[1];
$neg += $credit if $credit < 0;
$pos += $credit if $credit > 0;
}
printf "Total positive: %8s\n", $pos;
printf "Total negative: \e[31;1m%8s\e[0m\n", $neg;
printf "GRAND TOTAL: \e[1m%8s\e[0m\n", $pos + $neg;
printf "Total positive: %8.2f\n", $pos;
printf "Total negative: \e[31;1m%8.2f\e[0m\n", $neg;
printf "GRAND TOTAL: \e[1m%8.2f\e[0m\n", $pos + $neg;
return ACCEPT;
}

View file

@ -1,6 +1,6 @@
#!perl
HELP1 "help2" => "Advanced usage instructions";
HELP "help" => "The stuff you're looking at right now :)";
use List::Util qw(max);
@ -8,17 +8,29 @@ my $bold = "\e[1m";
my $underline = "\e[4m";
my $off = "\e[0m";
sub command :Tab(help,help2,wtf,omgwtfbbq) ($self, $cart, $command, @) {
return NEXT if $command !~ /^(?:help2?|wtf|omgwtfbbq)$/;
sub command :Tab(help,wtf,omgwtfbbq) {
my ($self, $cart, $command) = @_;
my $help2 = $command =~ /help2/;
my $hash = $help2 ? \%::HELP : \%::HELP1;
return NEXT if $command !~ /^(?:help|wtf|omgwtfbbq)$/;
# GNU less(1) and more(1) are a bad choice to present to total newbies who
# might have no interest in learning to use these surprisingly powerful
# tools, so I will not accepting patches to use either of those, or to use
# the PAGER environment variable (because that will typically be set to
# either one of those by default). For example, typing "v" will excute
# vi...
# On the other hand, busybox(1) has a "more" applet that gives the user
# clear instructions and seems mostly harmless too.
my $pipe;
if (open $pipe, "|-", "busybox", "more") {
select $pipe;
}
say "\n${bold}Valid commands:${off}";
my $width = max(map length s/[<>]//rg, keys %$hash);
my $width = max(map length s/[<>]//rg, keys %::HELP);
for my $command (sort keys %$hash) {
for my $command (sort keys %::HELP) {
my $display = $command;
my $length = length $display =~ s/[<>]//rg;
@ -29,19 +41,18 @@ sub command :Tab(help,help2,wtf,omgwtfbbq) ($self, $cart, $command, @) {
# Because of markup codes, a simple %-42s doesn't work.
$display .= " " x ($width - $length);
say sprintf " %s %s", $display, $hash->{$command};
say sprintf " %s %s", $display, $::HELP{$command};
}
my $advanced = $help2
? "${bold}Advanced usage:${off} pass space separated arguments to parameters"
: ""; # Line intentionally left blank
print <<"END";
${bold}Simple usage: ${off} press <Enter> after a command for follow-up prompts
$advanced
${bold}Advanced usage:${off} pass space separated arguments to parameters
Complete each transaction with ${underline}account${off} (i.e. enter your name).
END
select STDOUT;
close $pipe;
return ACCEPT;
}

View file

@ -1,36 +1,31 @@
#!perl
my $timeout = 10;
my $text_displayed = 0;
sub hook_prompt($class, $cart, $prompt, @) {
$text_displayed = 0;
}
sub hook_prompt_idle($class, $cart, $plugin, $seconds, $readline, @) {
return unless $seconds >= $timeout and $cart->size and not $plugin;
call_hooks("beep");
return if $text_displayed;
$text_displayed = 1;
my $text = $readline->copy_text;
my $point = $readline->{point};
$readline->save_prompt;
$readline->replace_line("");
$readline->redisplay;
my $verb = $cart->sum < 0 ? "pay" : "finish";
my $help = $cart->entries('refuse_checkout')
? "Enter 'abort' to abort."
: "Enter username to $verb or 'abort' to abort.";
print "\e[33;4;1mTransaction incomplete.\e[0m $help\n";
$readline->restore_prompt;
$readline->replace_line($text);
$readline->{point} = $point;
$readline->redisplay;
sub command { NEXT }
sub hook_prompt_idle {
my ($class, $cart, $plugin, $seconds, $readline) = @_;
if ($seconds >= $timeout and $cart->size and not $plugin) {
call_hooks("beep");
return if $seconds > $timeout; # text only once
my $text = $readline->copy_text;
my $point = $readline->{point};
$readline->save_prompt;
$readline->replace_line("");
$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;
}
}

View file

@ -1,91 +0,0 @@
#!perl
=head1 CAVEATS
This module requires the Perl module "JSON" to be installed.
Note that cent amounts are emitted as strings, not floats. This is on purpose.
They are, however, in a format that is easy to parse and convert (e.g.
JavaScript "parseFloat").
Note that things may be happening that don't have any JSON output.
Note that if plugins explicitly print to STDOUT, that will break the JSON
output. Regular print (without specified filehandle) will be suppressed.
Note that one command line may result in several separate transactions.
Note that plugins don't know it's non-interactive, and will often emit
RETRY instead of REJECT.
Note that this plugin will always be highly experimental; re-evaluate your
assumptions when upgrading. :)
This plugin is intended to be used together with "revbank -c 'command line'",
but you could try to use it interactively; if you do, please let me know about
your use case.
Set the environment variable REVBANK_JSON to either "array" or "lines" (see
jsonlines.org).
=cut
use JSON;
my $json = JSON->new->utf8->convert_blessed->canonical;
BEGIN {
if ($ENV{REVBANK_JSON} and $ENV{REVBANK_JSON} =~ /^(?:array|lines)$/) {
my $array = $ENV{REVBANK_JSON} eq "array";
# Suppress normal print output
open my $null, ">", "/dev/null";
select $null;
print STDOUT "[\n" if $array;
my $count = 0;
*_log = sub($hash) {
# JSON does not allow trailing commas, argh
print STDOUT ",\n" if $array and $count++;
print STDOUT $json->encode($hash);
print STDOUT "\n" if not $array;
};
END { print STDOUT "\n]\n" if $array }
# Monkey patch
*RevBank::Amount::TO_JSON = sub($self, @) {
$self->string("+");
};
} else {
*_log = sub { };
}
}
sub hook_abort(@) {
_log({ _ => "ABORT" });
}
sub hook_reject($class, $plugin, $reason, $abort, @) {
_log({ _ => "REJECT", plugin => $plugin, reason => $reason, abort => $abort });
}
sub hook_retry($class, $plugin, $reason, $abort, @) {
_log({ _ => "RETRY", plugin => $plugin, reason => $reason, abort => $abort });
}
sub hook_user_created($class, $username, @) {
_log({ _ => "NEWUSER", account => $username });
}
# NB: stringify transaction_id because future ids might not be numeric.
sub hook_user_balance($class, $user, $old, $delta, $new, $transaction_id, @) {
_log({ _ => "BALANCE", account => $user, old => $old, delta => $delta, new => $new, transaction_id => "$transaction_id" });
}
sub hook_checkout($class, $cart, $username, $transaction_id, @) {
_log({ _ => "CHECKOUT", account => $username, transaction_id => "$transaction_id" });
}

View file

@ -1,58 +1,58 @@
#!perl
sub command { NEXT }
my $filename = ".revbank.log";
sub _log($tag, @message) {
@message = ("") if not @message;
append $filename, map(s/^/now() . " $tag "/rgme, @message), "\n";
sub _log {
open my $fh, '>>', $filename or warn "$filename: $!";
print $fh now(), " ", @_, "\n";
close $fh or warn "$filename: $!";
}
my %buffer;
sub hook_abort(@) {
sub hook_abort {
_log("ABORT");
}
sub hook_prompt($class, $cart, $prompt, @) {
sub hook_prompt {
my ($class, $cart, $prompt) = @_;
$buffer{prompt} = $prompt;
}
sub hook_input($class, $cart, $input, $split_input, @) {
sub hook_input {
my ($class, $cart, $input, $split_input) = @_;
$input //= "(UNDEF)";
$input = "(EMPTY)" if not length $input;
_log(PROMPT => "$buffer{prompt} >> $input");
_log("PROMPT $buffer{prompt} >> $input");
}
sub hook_reject($class, $plugin, $reason, $abort, @) {
_log(REJECT => "[$plugin] $reason");
sub hook_reject {
my ($class, $plugin, $reason, $abort) = @_;
_log("REJECT [$plugin] $reason");
}
sub hook_retry($class, $plugin, $reason, $abort, @) {
_log(RETRY => "[$plugin] $reason");
sub hook_retry {
my ($class, $plugin, $reason, $abort) = @_;
_log("RETRY [$plugin] $reason");
}
sub hook_user_created($class, $username, @) {
_log(NEWUSER => "$username");
sub hook_user_created {
my ($class, $username) = @_;
_log("NEWUSER $username");
}
sub hook_user_balance($class, $user, $old, $delta, $new, $transaction_id, @) {
sub hook_user_balance {
my ($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");
_log("BALANCE $transaction_id $user had $old, $lost $delta, now has $new");
}
sub hook_checkout($class, $cart, $username, $transaction_id, @) {
_log(CHECKOUT => "$transaction_id $_") for map $_->as_loggable, $cart->entries;
sub hook_checkout {
my ($class, $cart, $username, $transaction_id) = @_;
_log("CHECKOUT $transaction_id $_") for map $_->as_loggable, $cart->entries;
}
sub hook_log_warning($class, $message, @) {
_log(WARNING => $message);
}
sub hook_log_error($class, $message, @) {
_log(ERROR => $message);
}
sub hook_log_info($class, $message, @) {
_log(INFO => $message);
sub hook_register {
my ($class, $plugin) = @_;
_log("REGISTER $plugin");
}

View file

@ -4,9 +4,10 @@ HELP "market" => "Edit market list";
my $filename = 'revbank.market';
sub _read_market() {
sub _read_market {
open my $fh, '<', $filename or die "$filename: $!";
my %market;
for (slurp $filename) {
while (readline $fh) {
/^\s*#/ and next;
/\S/ or next;
chomp;
@ -21,10 +22,11 @@ sub _read_market() {
return \%market;
}
sub command :Tab(market,&tab) ($self, $cart, $command, @) {
sub command :Tab(market,&tab) {
my ($self, $cart, $command) = @_;
if ($command eq 'market') {
require RevBank::TextEditor;
RevBank::TextEditor::edit($filename);
system $ENV{EDITOR} || 'vi', $filename;
return ACCEPT;
}
@ -35,22 +37,24 @@ sub command :Tab(market,&tab) ($self, $cart, $command, @) {
my $space = parse_amount($product->{ space }) or return NEXT;
my $description = $product->{description};
my @existing = grep {
$_->attribute('plugin') eq $self->id and
$_->attribute('product_id') eq $command
} $cart->entries('plugin');
if (@existing) {
$existing[0]->quantity($existing[0]->quantity + 1);
return ACCEPT;
}
$cart->add(
-($seller + $space),
"$description (sold by $username)",
{
product_id => $command,
plugin => $self->id,
deduplicate => join("/", $self->id, $command),
}
{ product_id => $command, plugin => $self->id }
)->add_contra(
$username,
$seller,
"\$you bought $description"
)->add_contra(
"+sales/market",
$space,
"\$you bought $description from $username"
);
return ACCEPT;

View file

@ -1,157 +0,0 @@
#!perl
use List::Util qw(none uniqstr);
my @deny_plugins = (
"give",
#"market",
#"products",
"take",
#"unlisted",
"withdraw",
);
my $allow_multi_user = 1;
sub _derive_plugin($symbol) {
return $1 if $symbol =~ /^RevBank::Plugin::(\w+)::/;
return;
}
sub _inform($unresolved, $username, $skip_print = 0) {
call_hooks("beep");
say "Not possible:";
for my $entry ($unresolved->entries) {
unless ($skip_print) {
my $line = ($entry->as_printable)[0];
say $line;
$line =~ s/^\s+//;
call_hooks("log_info", "nomoney: $line");
}
my $broke_users = $entry->attribute('nomoney_users');
for my $account (sort keys %$broke_users) {
my $balance = RevBank::Users::balance($account);
my $m = sprintf(
"%s have %s",
($account eq $username ? "You don't" : "$account doesn't"),
abs($broke_users->{$account}),
);
call_hooks("log_info", "nomoney: $m (balance: $balance)");
my $b = ($balance < 0 ? "\e[31;1m$balance\e[m" : $balance);
say "\e[31;1m$m\e[m (balance: $b)";
}
}
}
my %unresolved; # to share state between hooks, keyed per real cart
sub hook_checkout_prepare($class, $cart, $username, $transaction_id, @) {
my $unresolved = $unresolved{$cart} = RevBank::Cart->new;
my $deltas = $cart->deltas($username);
my %balances;
for my $account (keys %$deltas) {
next if $deltas->{$account} > 0;
next if RevBank::Users::is_special($account);
my $old = $balances{$account} = RevBank::Users::balance($account);
my $new = $old + $deltas->{$account};
next if $new >= 0 or $new > $old;
for my $entry ($cart->entries) {
my $plugin = $entry->attribute('plugin') // _derive_plugin($entry->{caller});
next if not $plugin;
next if none { $plugin eq $_ } @deny_plugins;
my @contra_users = uniqstr sort grep {
not RevBank::Users::is_special($_)
and $_ ne $username
} map {
$_->{user}
} $entry->contras;
next if $allow_multi_user and @contra_users > 1;
next if none { $account eq $_ } $entry->user // $username, @contra_users;
$unresolved->add_entry($entry);
}
}
return if not $unresolved->size; # allow transaction as is
my $newline = 0;
if ($cart->changed) {
# Show original cart before changing it, if it hasn't been shown before
say "Pending:";
$cart->display;
$newline = 1;
}
$cart->delete($_) for @{ $unresolved->{entries} };
# Find entries that can be done, by brute force, and add them back.
RESOLVE: {
my $resolved_deltas = $cart->deltas($username);
my %resolved_balances = %balances;
$resolved_balances{$_} += $resolved_deltas->{$_} for keys %$resolved_deltas;
for my $entry ($unresolved->entries) {
my $single = RevBank::Cart->new;
$single->add_entry($entry);
my $trial_deltas = $single->deltas($username);
my %broke_users;
$entry->attribute('nomoney_users', \%broke_users);
for my $account (keys %$trial_deltas) {
next if RevBank::Users::is_special($account);
next if $trial_deltas->{$account} > 0;
my $trial_balance = $resolved_balances{$account} + $trial_deltas->{$account};
if ($trial_balance < 0) {
$broke_users{$account} += $trial_deltas->{$account};
}
}
if (not %broke_users) {
$cart->add_entry($entry);
$unresolved->delete($entry);
redo RESOLVE;
}
}
}
if (not $cart->size) {
print "\n" if $newline;
_inform($unresolved, $username, 1);
return ABORT;
}
return;
}
sub hook_abort($class, $cart, @) {
delete $unresolved{$cart};
return;
}
sub hook_checkout_done($class, $cart, $username, $transaction_id, @) {
my $n = $unresolved{$cart}->size or return;
print "\n";
_inform($unresolved{$cart}, $username);
delete $unresolved{$cart};
my $message = $n == 1 ? "THIS ENTRY WAS IGNORED" : "THESE ENTRIES WERE IGNORED";
say "\e[1;4m$message.\e[0m" if $n;
return;
}

View file

@ -1,91 +0,0 @@
#!perl
use RevBank::Products qw(read_products);
use FindBin qw($Bin);
my $fn = ".revbank.oepl";
my $hex = '[0-9A-F]';
my $mac_regex = qr/^(?:$hex {12}|$hex {14}|$hex {16})$/x;
sub _create() {
open my $fh, '>>', $fn;
}
sub _run(@args) {
local $ENV{REVBANK_SKIP_LOCK} = 1;
system perl => "$Bin/contrib/openepaperlink.pl", @args;
}
sub _read_oepl() {
return { map { (split " ")[0, 1] } slurp $fn };
}
sub _touch() {
utime undef, undef, $fn;
}
sub command :Tab(openepaperlink) ($self, $cart, $command, @) {
if ($command =~ $mac_regex) {
my $mac2product = _read_oepl;
return REDO, $mac2product->{$command} if exists $mac2product->{$command};
}
$command eq 'openepaperlink' or return NEXT;
return "Product ID (or 'unlink')", sub ($self, $cart, $product_id, @) {
my $product;
if ($product_id ne 'unlink') {
$product = read_products->{$product_id} or return REJECT, "No such product.";
$product_id = $product->{id}; # don't use alias
}
return "Tag MAC", sub ($self, $cart, $mac, @) {
$mac =~ $mac_regex or return REJECT, "Malformed MAC.";
_run erase => $mac if $product_id eq 'unlink'; # while it's still in the .oepl
_create;
my $found = 0;
rewrite $fn, sub($line) {
my ($m) = split " ", $line;
return $line if $m ne $mac;
$found++;
return undef if $product_id eq 'unlink';
return "$mac $product_id\n" if $m eq $mac;
};
if (!$found and $product_id ne 'unlink') {
append $fn, "$mac $product_id\n";
}
_run $mac unless $product_id eq 'unlink';
return ACCEPT;
};
};
}
sub hook_products_changed($class, $changes, $mtime, @) {
-f $fn or return;
return with_lock {
$mtime >= (stat $fn)[9] or return;
my @macs;
my %deleted;
my %product2mac = reverse %{ _read_oepl() };
for my $pair (@$changes) {
my ($old, $new) = @$pair;
my $id = defined($new) ? $new->{id} : $old->{id};
$product2mac{$id} or next;
push @macs, $product2mac{$id};
}
@macs or return;
_run @macs;
sleep 1 if $mtime == time;
_touch;
};
}

55
plugins/pfand Normal file
View file

@ -0,0 +1,55 @@
#!perl
HELP "pfand" => "Pfand zurueck";
# This is a demo plugin. It's called "pfand" because "deposit" would be
# confusing and only the Germans are crazy enough to have deposits on small
# bottles anyway ;)
# The file format for 'revbank.pfand' is simply two whitespace separated
# columns: product id and pfand amount.
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) = @_;
return NEXT if $command ne 'pfand';
return "Pfand zurueck fuer", \&product;
}
sub product :Tab(&tab) {
my ($self, $cart, $product) = @_;
my $pfand = parse_amount(_read_pfand->{ $product })
or return REJECT, "Invalid pfand amount for $product";
if ($pfand) {
$cart->add(+$pfand, "Pfand zurueck", { is_return => 1 });
} else {
say "$product: Kein Pfand";
}
return ACCEPT;
}
sub tab {
return keys %{ _read_pfand() };
}
sub hook_add_entry {
my ($class, $cart, $entry) = @_;
return if $entry->has_attribute('is_return');
return if not $entry->has_attribute('product_id');
my $pfand = _read_pfand->{ $entry->attribute('product_id') } or return;
$cart->add(-$pfand, "Pfand", { is_pfand => 1 });
return;
}

45
plugins/plus Normal file
View file

@ -0,0 +1,45 @@
#!perl
HELP "+<N>" => "Add N more items of the previous thing";
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) = @_;
return ABORT, $err_pfand if $cart->entries('is_pfand');
my ($post) = $command =~ /^\+(\d+)?$/
or return NEXT;
return ABORT, "Can't modify an empty transaction." if not $cart->size;
my $last = ($cart->entries)[-1];
return REJECT, "Addition only works on products." if not $last->has_attribute('product_id');
if ($post) {
return REJECT, $err_limit if $last->quantity + $post > $limit;
$last->quantity($last->quantity + $post);
return ACCEPT;
}
return "Add to previous product", \&add;
}
sub add {
my ($self, $cart, $arg) = @_;
$arg =~ /^\d+$/ and $arg > 0
or return REJECT, "Invalid value.";
my $last = ($cart->entries)[-1];
return REJECT, $err_limit if $last->quantity + $arg > $limit;
$last->quantity($last->quantity + $arg);
return ACCEPT;
}

View file

@ -1,53 +1,57 @@
#!perl
use RevBank::Products qw(read_products);
HELP1 "<productID>" => "Add a product to pending transaction";
HELP "<productID>" => "Look up products from database";
HELP "edit" => "Edit product list";
sub command :Tab(&tab) ($self, $cart, $command, @) {
$command =~ /\S/ or return NEXT;
$command =~ /^\+/ and return NEXT;
my $filename = 'revbank.products';
my $products = read_products;
sub _read_products {
open my $fh, '<', $filename or die "$filename: $!";
my %products;
while (readline $fh) {
/^\s*#/ and next;
/\S/ or next;
chomp;
my ($ids, $p, $d) = split " ", $_, 3;
my @ids = split /,/, $ids;
my $product = $products->{ $command } or return NEXT;
my $price = $product->{price};
my $entry = $cart->add(
-$product->{total_price},
$product->{description},
{
product_id => $product->{id},
plugin => $self->id,
product => $product,
deduplicate => join("/", $self->id, $product->{id}),
}
);
my $contra_desc = "\$you bought $product->{description}";
my @addons = @{ $product->{addons} // [] };
my $display = undef;
$display = "Product" if @addons and $price->cents > 0;
$display = "Reimbursement" if @addons and $price->cents < 0;
$entry->add_contra(
$product->{contra},
+$price,
$contra_desc,
$display
);
for my $addon (@addons) {
$entry->add_contra(
$addon->{contra},
$addon->{price},
"$addon->{description} ($contra_desc)",
$addon->{description}
);
$products{ $_ } = { id => $ids[0], price => $p, description => $d}
for @ids;
}
return \%products;
}
sub command :Tab(edit,&tab) {
my ($self, $cart, $command) = @_;
if ($command eq 'edit') {
system $ENV{EDITOR} || 'vi', $filename;
return ACCEPT;
}
my $product = _read_products->{ $command } or return NEXT;
my $price = parse_amount( $product->{price} ) or return NEXT;
my @existing = grep {
$_->attribute('plugin') eq $self->id and
$_->attribute('product_id') eq $product->{id}
} $cart->entries('plugin');
if (@existing) {
$existing[0]->quantity($existing[0]->quantity + 1);
return ACCEPT;
}
$cart->add(
-$price,
$product->{description},
{ product_id => $product->{id}, plugin => $self->id }
);
return ACCEPT;
}
sub tab {
return grep !/^\+/, grep /\D/, keys %{ read_products() };
return grep /\D/, keys %{ _read_products() };
}

View file

@ -1,17 +0,0 @@
=head1 NAME
products - RevBank plugin for selling products
=head1 DESCRIPTION
This plugin turns products from the product list into RevBank commands,
that add the respective products as Entries to the current Cart.
Note that by design, RevBank does not depend on this plugin or the products
list that is shared between some of the plugins. It is possible to use a
different source of products (e.g. an external database) in addition to, or
instead of, this plugin.
=head1 CONFIGURATION
See the documentation for C<RevBank::Products> (hint: in C<lib/>).

View file

@ -1,4 +0,0 @@
sub command($self, $cart, $command, @) {
return REDO, $1 if $command =~ /^angel-(.*)/;
return NEXT;
}

View file

@ -1,45 +0,0 @@
use List::Util qw(sum);
my @regexes = (
qr[^https?://.*?/01/(\d{14})\b], # GS1 Digital Link with GTIN-14
qr[^https?://.*?/01/0(\d{13})\b], # GS1 Digital Link with GTIN-13
qr[^https?://.*?/01/00(\d{12})\b], # GS1 Digital Link with GTIN-12
qr[^https?://.*?/01/0{6}(\d{8})\b], # GS1 Digital Link with GTIN-8
# "Compressed" GS1 Digital Links are not supported, as the current draft
# specification is insanely complex: it involves base64 and hexadecimal
# strings, binary data that isn't octet-aligned, and a vast number of
# lookup tables, all of which are needed just to extract the GTIN. One can
# only hope that this scheme to save a few bytes will never catch on.
qr[^\(01\)(\d{14})\b], # GS1 Element String with GTIN-14
qr[^\(01\)0(\d{13})\b], # GS1 Element String with GTIN-13
qr[^\(01\)00(\d{12})\b], # GS1 Element String with GTIN-12
qr[^\(01\)0{6}(\d{8})\b], # GS1 Element String with GTIN-8
qr[^01(\d{14})(?=\d|$)], # GS1-128 (without FNC) with GTIN-14
qr[^010(\d{13})(?=\d|$)], # GS1-128 (without FNC) with GTIN-13
qr[^0100(\d{12})(?=\d|$)], # GS1-128 (without FNC) with GTIN-12
qr[^010{6}(\d{8})(?=\d|$)], # GS1-128 (without FNC) with GTIN-8
qr[^https://\w+url\.com/(?:q/|q/srn|srn)(\d{13})]i, # spam with GTIN-13
);
sub command ($self, $cart, $command, @) {
$self->{orig_command} //= $command;
$self->{regexes} //= [ @regexes ];
while (my $regex = shift @{ $self->{regexes} }) {
if ($self->{orig_command} =~ $regex) {
my $gtin = $1;
my @digits = reverse split //, $gtin;
my $checksum = (10 - sum(map $digits[$_] * ($_ % 2 ? 3 : 1), 1..$#digits) % 10) % 10;
$digits[0] == $checksum or next;
return REDO, $gtin;
}
}
return NEXT;
}

View file

@ -1,7 +1,6 @@
#!perl
HELP "<N>x, <N>*" => "Set quantity of previous/next product";
HELP "-<N>, +<N>, *<N>, x<N>" => "Change quantity of previous product";
HELP "*<N>, x<N>, <N>x, <N>*" => "Repeat previous/next product N times";
my $err_stacked = "Stacked repetition is not supported.";
my $err_pfand = "Plugins 'pfand' and 'repeat' cannot be combined.";
@ -11,32 +10,21 @@ 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($self, $cart, $command, @) {
my ($lhs, $op, $rhs) = $command =~ /^(\d+)?([x*+-])(\d+)?$/
or return NEXT;
sub command {
my ($self, $cart, $command) = @_;
return ABORT, $err_pfand if $cart->entries('is_pfand');
my $last = $cart->selected;
my ($lhs, $op, $rhs) = $command =~ /^(\d+)?([x*+-])(\d+)?$/
or return NEXT;
return NEXT if $lhs and $rhs; # 123x123 -> invalid, likely user or product
my $last = ($cart->entries)[-1];
if ($lhs) {
return REJECT, $err_postfix if $op eq '+' or $op eq '-';
$lhs = abs $lhs; # withdrawal is negative
return REJECT, $err_limit if $lhs > $limit;
$cart
->add(0, "? (The next thing you add will be multiplied.)", { _repeat => 1, refuse_checkout => 1 })
->quantity($lhs);
return ACCEPT;
}
return ABORT, "Can't modify an empty transaction." if not $cart->size;
return REJECT, $err_nope if $last->attribute('no_repeat');
return NEXT if $lhs and $rhs; # 123x123 -> invalid syntax
if ($rhs) {
return ABORT, "Can't modify an empty transaction." if not $cart->size;
return REJECT, $err_nope if $last->attribute('no_repeat');
return REJECT, $err_limit if $rhs > $limit;
if ($op eq '+') {
@ -56,38 +44,67 @@ sub command($self, $cart, $command, @) {
}
return ACCEPT;
}
# $op is not + or -, so it must be * (or x).
return REJECT, $err_stacked if $last->multiplied;
$last->quantity($rhs);
return ACCEPT;
}
if ($op eq '+' or $op eq '-') {
$self->{op} = $op;
return "$op how many?", \&plusminus;
if (not $lhs and not $rhs) {
# Lone operator. Convert withdrawal into repetition.
return ABORT, "Can't modify an empty transaction." if not $cart->size;
if ($op eq '+' or $op eq '-') {
$self->{op} = $op;
return "$op how many?", \&plusminus;
}
if ($last->has_attribute('is_withdrawal')) {
$lhs = $last->{amount}->abs->float;
$lhs == int $lhs or return REJECT, "Repeat only works on integers.";
$cart->delete($last);
}
}
if ($lhs) {
return REJECT, $err_postfix if $op eq '+' or $op eq '-';
$lhs = abs $lhs; # withdrawal is negative
return REJECT, $err_limit if $lhs > $limit;
$cart
->add(0, "? (The next thing you add will be multiplied.)", { _repeat => 1, refuse_checkout => 1 })
->quantity($lhs);
return ACCEPT;
}
# $op is not + or -, so it must be * (or x).
return REJECT, $err_stacked if $last->multiplied;
return REJECT, $err_nope if $last->attribute('no_repeat');
return "Multiply previous product by", \&repeat;
}
sub repeat($self, $cart, $arg, @) {
sub repeat {
my ($self, $cart, $arg) = @_;
$arg =~ /^\d+$/ and $arg > 0
or return REJECT, "Invalid value.";
return REJECT, $err_limit if $arg > $limit;
$cart->selected->quantity($arg);
($cart->entries)[-1]->quantity($arg);
return ACCEPT;
}
sub plusminus($self, $cart, $arg, @) {
sub plusminus {
my ($self, $cart, $arg) = @_;
$arg =~ /^\d+$/ and $arg > 0
or return REJECT, "Invalid value.";
my $last = $cart->selected;
my $last = ($cart->entries)[-1];
my $new = $last->quantity;
$new += $arg if $self->{op} eq '+';
$new -= $arg if $self->{op} eq '-';
@ -97,12 +114,13 @@ sub plusminus($self, $cart, $arg, @) {
$cart->delete($last);
print "Deleted.\n";
} else {
$cart->selected->quantity($new);
($cart->entries)[-1]->quantity($new);
}
return ACCEPT;
}
sub hook_added_entry($class, $cart, $entry, @) {
sub hook_added_entry {
my ($self, $cart, $entry) = @_;
$cart->size >= 2 or return;
my @entries = $cart->entries;

View file

@ -1,15 +1,27 @@
#!perl
HELP "restart" => "Attempt to restart the RevBank shell";
sub command :Tab(restart) ($self, $cart, $command, @) {
sub command :Tab(restart) {
my ($self, $cart, $command) = @_;
return NEXT if $command ne 'restart';
no warnings;
call_hooks("restart_exec");
no warnings qw(exec);
exec $0;
call_hooks("restart_survived");
return ABORT, "exec() failed. You'll have to restart revbank yourself :P";
}
sub hook_input {
my ($self, $cart, $input, $split_input) = @_;
return if defined $input;
no warnings;
call_hooks("restart_restart");
exec $0;
call_hooks("restart_survived");
}

View file

@ -7,35 +7,29 @@
sub command :Tab(barcode) ($self, $cart, $command, @) {
sub command :Tab(barcode) {
my ($self, $cart, $command) = @_;
return NEXT if $command ne "barcode";
return "Barcode data", \&data;
}
sub data($self, $cart, $input, @) {
my $price = 0.07;
sub data {
my ($self, $cart, $input) = @_;
$cart
->add(
-$price,
"Barcode <$input>",
{
is_barcode => 1,
barcode_data => $input,
deduplicate => join("/", $self->id, $input),
}
)
->add_contra(
"+sales/barcodes",
+$price,
"\$you bought barcode <$input>"
);
$cart->add(
-0.07,
"Barcode <$input>",
{ is_barcode => 1, barcode_data => $input }
);
return ACCEPT;
}
sub hook_checkout($class, $cart, $username, $transaction_id, @) {
sub hook_checkout {
my ($class, $cart, $username, $transaction_id) = @_;
my @barcodes;
for my $entry ($cart->entries('is_barcode')) {
push @barcodes, ($entry->attribute('barcode_data')) x $entry->quantity;

20
plugins/revspace_bounties Normal file
View file

@ -0,0 +1,20 @@
#!perl
my %bounties = (
1 => [ 10, "Bedankt voor het vegen/stofzuigen" ],
2 => [ 10, "Bedankt voor het afvoeren van het afval" ],
3 => [ 25, "Bedankt voor het dweilen" ],
4 => [ 15, "Bedankt voor 't poetsen van alle tafels" ],
);
sub command :Tab(BOUNTY1,BOUNTY2,BOUNTY3,BOUNTY4) {
my ($self, $cart, $command) = @_;
if ($command =~ /BOUNTY(\d+)/) {
$cart->add(+$bounties{$1}[0], $bounties{$1}[1]);
return ACCEPT;
}
return NEXT;
}

View file

@ -1,8 +0,0 @@
# Accept the odd QR-codes on Coke (and Fanta, etc.) cans, as they also contain the EAN.
# For this plugin to be useful, it needs to be BEFORE "users" in "revbank.plugins".
sub command {
$_[2] =~ s@^https?://(coke|fanta)url.com/q/srn@@gi; # input is actually a mutable string
return NEXT;
}

View file

@ -1,6 +1,9 @@
#!perl
sub hook_user_balance($class, $username, $old, $delta, $new, $transaction_id, @) {
sub command { NEXT }
sub hook_user_balance {
my ($class, $username, $old, $delta, $new, $transaction_id) = @_;
my $msg = "$transaction_id ($username)";
$msg =~ s/[^\x20-\x7E]//g;
$msg =~ s/'//g;

View file

@ -1,30 +0,0 @@
#!perl
my $cost = 2.50;
sub command :Tab(lasercutter) ($self, $cart, $command, @) {
$command eq 'lasercutter' or return NEXT;
return "How long did you use the machine? (h:mm)", \&time
}
sub time ($self, $cart, $time, @) {
my ($h, $m) = $time =~ /^\s*([0-9]*)(?:[:.]([0-9]+))?\s*$/;
$h ||= 0;
$m ||= 0;
$h or $m or return REJECT, "Invalid time.";
print "Note: rounding up to next multiple of 0:15.\n" if $m % 15;
my $q = $h * 4 + int($m / 15) + ($m % 15 ? 1 : 0);
# reformat rounded time
$time = int($q / 4) . ":" . sprintf("%02d", ($q % 4) * 15);
$cart
->add(-$q * $cost, "Lasercutter usage ($time)")
->add_contra("+sales/lasercutter", $q * $cost, "\$you used lasercutter ($time)");
return ACCEPT;
}

View file

@ -5,7 +5,8 @@ use JSON;
my $ua = LWP::UserAgent->new(agent => "revbank");
my $backend_url = "https://deposit.revspace.nl/mollie.php";
sub backend_call($hash) {
sub backend_call {
my ($hash) = @_;
#$hash->{test} = 1; # use mollie test environment
my $response = $ua->post($backend_url, $hash);
@ -19,7 +20,9 @@ sub backend_call($hash) {
return $result;
}
sub command($self, $cart, $command, @) {
sub command {
my ($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;
@ -35,21 +38,16 @@ sub command($self, $cart, $command, @) {
$description .= " TEST MODE ($result->{test_amount})";
}
$cart
->add(
+$amount,
$description,
{ is_deposit => 1, method => 'online', mollie_id => $id, no_repeat => 1 }
)
->add_contra(
"-deposits/online",
-$amount,
"$description by \$you"
);
$cart->add(
+$amount,
$description,
{ is_deposit => 1, method => 'online', mollie_id => $id, no_repeat => 1 }
);
return ACCEPT;
}
sub hook_abort($class, $cart, $reason, @) {
sub hook_abort {
my ($class, $cart, $reason) = @_;
# Opportunistic; ignore failures. Can't do anything about it anyway.
my @ids = map $_->attribute('mollie_id'), $cart->entries('mollie_id');
@ -57,7 +55,8 @@ sub hook_abort($class, $cart, $reason, @) {
for @ids;
}
sub hook_checkout($class, $cart, $user, $transaction_id, @) {
sub hook_checkout {
my ($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');

View file

@ -2,14 +2,20 @@
use Net::MQTT::Simple "mosquitto.space.revspace.nl";
sub hook_checkout($class, $cart, $user, $transaction_id, @) {
sub command { NEXT }
sub hook_checkout {
my ($class, $cart, $user, $transaction_id) = @_;
my $filename = "revbank.sales";
my @entries = $cart->entries('product_id') or return;
my %already_retained;
# XXX: hook_checkout is called while the global lock is held, and the
# potentially slow network traffic could make that take quite long.
my %stats = eval { map { split " ", $_, 2 } slurp $filename };
my %stats = do {
my $in;
open($in, '<', $filename)
? map { split " ", $_, 2 } readline $in
: ()
};
$stats{ $_->attribute('product_id') } += $_->quantity for @entries;
@ -23,7 +29,8 @@ sub hook_checkout($class, $cart, $user, $transaction_id, @) {
$already_retained{ $product } = 1;
}
spurt $filename, map {
sprintf "%-16s %9d\n", $_, $stats{$_}
} sort keys %stats;
open my $out, '>', "$filename.$$" or warn "$filename.$$: $!";
printf {$out} "%-16s %9d\n", $_, $stats{$_} for sort keys %stats;
close $out or die "$filename.$$: $!";
rename "$filename.$$", $filename or die $!;
}

View file

@ -2,17 +2,20 @@
use POSIX qw(strftime);
sub _box(@lines) {
sub command { NEXT }
sub _box {
print(
"#" x 79, "\n",
(map { sprintf("## %-73s ##\n", $_) } @lines),
(map { sprintf("## %-73s ##\n", $_) } @_),
"#" x 79, "\n"
);
}
sub hook_checkout_done($class, $cart, $user, $transaction_id, @) {
sub hook_checkout_done {
my ($class, $cart, $user, $transaction_id) = @_;
defined $user or return; # hacks like 'undo' don't have an acting user
RevBank::Users::is_hidden($user) and return;
my $balance = RevBank::Users::balance($user) or return;
my $since = RevBank::Users::since($user);

View file

@ -1,3 +1,5 @@
sub command { NEXT }
# Terminal hacks
# Reset terminal on startup

View file

@ -1,8 +0,0 @@
# Attempt to restart on SIGHUP
$SIG{HUP} = sub {
call_hooks("restart_exec");
no warnings qw(exec);
exec $0;
call_hooks("restart_survived");
};

View file

@ -1,5 +1,7 @@
#!perl
sub command { NEXT }
$SIG{INT} = sub {
$::ABORT_HACK = "^C";

View file

@ -1,34 +0,0 @@
#!perl
# Note: this plugin only makes sense if you have proper cashbox tracking,
# which requires the "deposit_methods" plugin for differentiating between
# bank transfers and cash deposits.
#
# If you ONLY allow cash deposits, and are not using the "deposit_methods"
# plugin, you could alternatively hack the "deposit" plugin to use the "-cash"
# contra instead of the "-deposits/other" contra.
sub command :Tab(skim,unskim) ($self, $cart, $command, @) {
$command eq 'skim' or $command eq 'unskim' or return NEXT;
$self->{command} = $command;
call_hooks("cash");
return "Amount to $command", \&amount;
}
sub amount($self, $cart, $arg, @) {
warn "Use 'unskim' to return (part of) a previously skimmed amount.\n"
if $arg =~ /^-/;
my $amount = parse_amount($arg) or return REJECT, "Invalid amount";
$amount = -$amount if $self->{command} eq 'unskim';
my $entry = $cart
->add(0, "Skimmed $amount", { is_withdrawal => 1 })
->add_contra("-cash", +$amount, "Skimmed by \$you")
->add_contra("-cash/skimmed", -$amount, "Skimmed by \$you");
return ACCEPT;
}

View file

@ -4,16 +4,19 @@ use List::Util ();
HELP "split <account>..." => "Split the bill with others";
sub _select_split($cart) {
sub _select_split {
my ($cart) = @_;
grep $_->{amount} < 0, $cart->entries
}
sub command :Tab(split) ($self, $cart, $command, @) {
sub command :Tab(take,steal,split) {
my ($self, $cart, $command) = @_;
$command eq 'split' or return NEXT;
$self->{users} = [];
my $sum = List::Util::sum(map -$_->{amount} * $_->{quantity}, _select_split($cart));
my $sum = List::Util::sum(map -$_->{amount}, _select_split($cart));
$self->{split_amount} = $sum;
return REJECT, "Nothing to split. Add products first." if not $sum;
@ -22,7 +25,9 @@ sub command :Tab(split) ($self, $cart, $command, @) {
return "User to take from (not yourself)", \&arg;
}
sub arg :Tab(USERS) ($self, $cart, $arg, @) {
sub arg :Tab(USERS) {
my ($self, $cart, $arg) = @_;
my $users = $self->{users};
if (@$users and $arg eq $self->{split_finish}) {

View file

@ -1,153 +0,0 @@
#!perl
use List::Util;
use RevBank::Products;
our @addon_accounts = ("+statiegeld");
my $nope = "Sorry, no deposit on that product.\n";
our $S = ($ENV{REVBANK_STATIEGELD} // 0) == 1;
sub statiegeld_product($product) {
if (not ref $product) {
# $product is a product id string; look up in product list
$product = read_products->{$product} or return;
}
# Called 'addons' here but also includes the queried product itself,
# to support things that are 100% statiegeld (e.g. empty crate)
my @relevant_addons = grep {
my $addon = $_;
!$addon->{percent}
and (List::Util::any { $addon->{contra} eq $_ } @addon_accounts)
and $addon->{price} > 0;
} $product, @{ $product->{addons} // [] };
return 0 if not @relevant_addons;
return { product => $product, statiegeld_addons => \@relevant_addons };
}
sub hook_deposit_command($class, $prompt, $array, @) {
$$prompt =~ s/$/, or scan empty container/;
push @$array, sub($, $cart, $input, @) {
my $p = statiegeld_product($input) // return NEXT;
if (not $p) {
print $nope;
return NEXT;
}
local $S = 1;
return command($class, $cart, $input);
};
}
sub command { # args via @_ for mutable alias
my ($invocant, $cart, $command) = @_;
$S or return NEXT;
# Hidden feature: use \ in front of product id to ignore statiegeld plugin.
# Not sure if this will stay; there might be a negative social aspect to
# normalizing grabbing a product and walking away from where one would
# normally pay.
if ($_[2] =~ s/^\\//) {
$cart->{statiegeld_ignore} = 1;
return NEXT;
}
defined &RevBank::Plugin::products::read_products
or die "statiegeld plugin requires products plugin";
$command =~ /^\+/ and return NEXT;
my $sg = statiegeld_product($command) // return NEXT;
if (not $sg) {
print $nope;
return ACCEPT;
}
my $product = $sg->{product};
my $addons = $sg->{statiegeld_addons};
for my $addon (@$addons) {
my $d = $addon->{id} eq $product->{id}
? "$addon->{description}"
: "$addon->{description} ($product->{description})";
$cart
->add(+$addon->{price}, $d, {
plugin => $invocant->id,
addon_id => $addon->{id},
product_id => $product->{id},
deduplicate => join("/", $invocant->id, $product->{id}),
})
->add_contra($addon->{contra}, -$addon->{price}, "$d for \$you");
}
return ACCEPT;
}
sub hook_added_entry ($class, $cart, $entry, @) {
$S or return;
delete $cart->{statiegeld_ignore} and return;
$entry->has_attribute('plugin') or return;
if ($entry->attribute('plugin') eq 'market') {
print $nope;
$cart->delete($entry);
}
if ($entry->attribute('plugin') eq 'products') {
my $id = $class->id;
die "Configuration error: the '$id' plugin must be *before* the 'products' plugin in revbank.plugins.\n";
}
}
# Override main revbank prompt
sub hook_prompt { # ($class, $cart, $prompt), but via @_ for mutable alias
$S or return;
my $message = "Scan empty container for deposit return.";
# The message is prepended to the prompt, so it is printed after
# clear-screen (^L). The color is repeated on the second line because
# readline redraws only the last line of a multiline prompt.
my $yellow = "\x01\e[33;1m\x02";
my $reset = "\x01\e[m\x02";
my $statiegeld_prompt = "$yellow$message$reset\n$yellow+>$reset";
$_[2] =~ s/^$/$statiegeld_prompt/;
}
sub hook_input { # args via @_ for mutable alias
my ($class, $cart, $input, $split_input) = @_;
$S or return;
defined $input or return;
# Extra newline before new "Scan products for ..." line.
print "\n" if defined $input and $input eq "" and $split_input;
# Hijack 'help' command so it never reaches the 'help' plugin.
if ($split_input and $input eq "help") {
print <<"END";
This is a beverage container (e.g. bottle) deposit return terminal to get your
money back; please use the other RevBank terminal for buying things and to read
the regular RevBank help text. (Normal RevBank commands are available.)
\e[1mJust scan the products and type your account name.\e[0m; deposits are only refunded
for container deposits on products that we have sold to you.
END
no warnings qw(exiting);
# "Exiting subroutine via %s"
# "(W exiting) You are exiting a subroutine by unconventional means,
# such as a goto, or a loop control statement."
redo OUTER; # this is phenomenally vile :)
}
$_[2] = "help" if $split_input and $input eq "\\help";
}

View file

@ -1,65 +0,0 @@
=head1 NAME
statiegeld - RevBank plugin for return deposits
=head1 SYNOPISIS
revbank.products:
clubmate 1.40 "Club-Mate bottle" +sb
cola 0.90 "Cola can" +sc
+sb 0.15@+statiegeld "Bottle deposit"
+sc 0.25@+statiegeld "Can deposit"
matecrate 1.50@+statiegeld "Mate crate (empty)"
=head1 DESCRIPTION
This plugin allows users to get refunds for empty container deposits.
In a typical setup, there would be a separate terminal where RevBank runs in
statiegeld mode. In statiegeld mode, you scan products to get your deposit
money back in the same way you would normally buy them.
Alternatively, on a regular RevBank terminal, the C<deposit> command (which is
provided by the C<deposit> plugin) is extended to support product id's where
you would normally enter an amount.
=head2 Usage
If RevBank was run with the environment variable C<REVBANK_STATIEGELD> set to
C<1>, the user just scans the products.
Alternatively, a product can be scanned after entering the C<deposit> command.
The product_id (barcode) is used to look up the stategield addon. In case of a
non-hidden addon (does not begin with C<+>), the name of the addon can also be
used.
=head2 Configuration
The statiegeld plugin recognises products from C<revbank.products> by matching
the contra accounts (the C<+statiegeld> in C<0.15@+statiegeld>) of the
product's addons against a list of known accounts.
That list is hard coded in the plugin, but could be changed if you want to use
a different account than the default C<+statiegeld>. The contra account can be
a hidden account or a regular account.
Don't remove statiegeld addons because that means customers can no longer get
their deposits back. Also, consider the consequences of changing the price
before doing so.
=head2 "statiegeld"?!
"Statiegeld" is the Dutch word for container deposits. Because the English word
"deposit" is also the verb for adding money to your account, and used
extensively in RevBank, it was useful to distinguish between the two features.
In the user interface, the terms "deposit" and "deposit return" are used.
=head2 Limits
By itself, the C<statiegeld> plugin only supports refunding deposits for known
products that are configured as such. There is no limit to how many containers
the user can return to get refunds. There's another plugin,
C<statiegeld_tokens>, that can be used to limit the refunds to what the same
user has actually purchased.

View file

@ -1,303 +0,0 @@
#!perl
use List::Util;
use RevBank::Products;
HELP void => "Destroy deposit tokens";
my $ttl = 100 * 86400; # expiry time in seconds
my $filename = "revbank.statiegeld";
# Token format: token_type,time,expiry_time,product_id,transaction_id,seq
# - token_type (also just "type") is the id of the product addon.
# - expiry_time < 0 means the token does not expire.
# - time and product_id is recorded but only used for debugging.
# - seq is a 0 based counter per transaction to make tokens unique,
# although the uniqueness of tokens is currently neither used nor enforced.
#
# Tokens are spent in FIFO order, by type rather than product_id. This
# effectively extends the TTL for active consumers. The product_ids of
# a user's remaining tokens may not correspond to those of the empty containers
# in their possession.
sub _addon_accounts {
my @accounts = @RevBank::Plugin::statiegeld::addon_accounts
or die "statiegeld_tokens plugin requires statiegeld plugin";
return @accounts;
}
sub _time_is_reliable() {
state $cache;
state $cached_at;
undef $cache if defined $cached_at and $cached_at <= (time() - 10);
return $cache if defined $cache;
$cache = sub {
return 1 if system('ntpstat >/dev/null 2>/dev/null') == 0;
return 1 if `timedatectl show -p NTPSynchronized 2>/dev/null` =~ /=yes/;
warn "Time/NTP status unknown or bad; deposit tokens will not expire.\n";
return 0;
}->();
$cached_at = time;
return $cache;
}
sub _read {
spurt $filename if not -e $filename;
my %users_tokens;
for (slurp $filename) {
/\S/ or next;
my ($username, @tokens) = split " ", $_;
if (exists $users_tokens{lc $username}) {
die "Corrupt data file $filename, $username listed twice";
}
my %by_type;
for my $token (@tokens) {
my ($token_type) = (split /,/, $token)[0];
push @{ $by_type{$token_type} }, $token;
}
$users_tokens{lc $username} = \%by_type;
}
return \%users_tokens;
}
sub _expire_tokens($line, $time) {
$time > 0 or return $line;
defined $line or return $line;
$line =~ / / or return $line;
my ($username, @tokens) = split " ", $line;
# Rewrite line with only non-tokens, invalid tokens, and non-expired tokens
my @keep;
my @expired;
for my $token (@tokens) {
my ($type, undef, $expiry) = split /,/, $token;
my $expired = defined($expiry) && $expiry > 0 && $expiry < $time;
push @{ $expired ? \@expired : \@keep }, $token;
}
call_hooks(
"log_info",
"statiegeld_tokens: ${\scalar @expired} expired for $username: @expired"
) if @expired;
return join(" ", $username, @keep) . "\n";
}
sub _write($username, $tokens_by_type, $create) {
my @tokens = map @{ $tokens_by_type->{$_} }, sort keys %$tokens_by_type;
my $new_line = @tokens == 0 ? undef : join(" ", $username, @tokens) . "\n";
my $time = _time_is_reliable ? time() : -1;
if ($create) {
append $filename, $new_line if defined $new_line;
} else {
rewrite $filename, sub ($old_line) {
$old_line =~ /\S/ or return $old_line; # keep whitespace-only lines
# removes line from file if $new_line is undef
my $line = /(\S+)/ && lc($1) eq lc($username) ? $new_line : $old_line;
return _expire_tokens($line, $time);
};
}
}
sub _warn($message) {
warn "\e[31;1mSorry,\e[0m $message\n";
}
sub hook_undo($class, $cart) {
# Undoing properly is hard. We can easily void tokens, but we can't restore
# them. That would requires duplicating all of the undo logic that exists
# for account balances, but for tokens. Too much work for something that I
# suspect would hardly be used anyway, so instead we'll just prohibit
# undoing refunds.
for my $entry ($cart->entries) {
# Undo deposit refund: prohibit
for my $contra ($entry->contras) {
next if $contra->{amount} < 0;
next if List::Util::none { $contra->{user} eq $_ } _addon_accounts;
return ABORT, "Sorry, deposit refunds cannot be undone.";
}
}
}
sub _handle_undo($cart) {
for my $entry ($cart->entries) {
# Undo buying: void specific tokens
my $undo_tid = $entry->attribute('undo_transaction_id')
or die "Plugin error: broken '-undo' transaction";
rewrite $filename, sub ($line) {
my ($username, @tokens) = split " ", $line;
@tokens = grep {
my ($token_type, undef, undef, undef, $tid) = split /,/, $_;
$tid ne $undo_tid
} @tokens;
return @tokens ? join(" ", $username, @tokens) . "\n" : undef;
};
}
}
sub hook_checkout_prepare($class, $cart, $username, $transaction_id, @) {
if ($username eq '-undo') {
_handle_undo($cart);
return;
}
# Read data
my $tokens_by_type = _read->{lc $username};
my $is_new = !defined $tokens_by_type;
$tokens_by_type = {} if $is_new;
my $time_is_reliable = _time_is_reliable;
my $tokens_changed = 0;
my @created;
my @used;
# Products bought: add tokens
my $seq = 0;
for my $entry ($cart->entries('product')) {
my $sg = RevBank::Plugin::statiegeld::statiegeld_product($entry->attribute('product'))
or next;
for my $addon (@{ $sg->{statiegeld_addons} }) {
# These should never contain spaces or commas in vanilla revbank,
# but custom plugins may be less well behaved.
/[\s,]/ and die "Internal error"
for $addon->{id}, $entry->attribute('product_id'), $transaction_id;
for (1 .. $entry->quantity) {
my $token = join(",",
$addon->{id}, # token_type
time(),
($time_is_reliable ? time() + $ttl : -1),
$entry->attribute('product_id'),
$transaction_id,
$seq++,
);
push @created, $token;
push @{ $tokens_by_type->{$addon->{id}} }, $token;
}
$tokens_changed++;
}
}
# Products (containers) returned: void tokens in FIFO order
my $cart_changed = 0;
my %warnings_by_type;
my %had_num_tokens_by_type = map { $_ => scalar @{ $tokens_by_type->{$_} } } keys %$tokens_by_type;
ENTRY: for my $entry ($cart->entries('plugin')) {
$entry->attribute('plugin') eq 'statiegeld' or next;
my $type = $entry->attribute('addon_id');
my $available = @{ $tokens_by_type->{$type} // [] };
if ($available < $entry->quantity) {
if ($available == 0) {
$cart->delete($entry);
$warnings_by_type{$type}++;
next ENTRY;
}
$entry->quantity($available);
$warnings_by_type{$type}++;
}
push @used, splice @{ $tokens_by_type->{$type} }, 0, $entry->quantity;
$tokens_changed++;
}
for my $type (keys %warnings_by_type) {
my $products = read_products;
my $addon = $products->{"+$type"} // $products->{$type};
my $avail = $had_num_tokens_by_type{$type} // 0;
my $only =
+ $avail == 0 ? "0 deposit tokens"
: $avail == 1 ? "only 1 deposit token"
: "only $avail deposit tokens";
_warn qq[you have $only of type $type.\n]
. qq[($type = "$addon->{description}")];
}
# Store data
call_hooks(
"log_info",
"statiegeld_tokens: ${\scalar @created } created for $username: @created"
) if @created;
call_hooks(
"log_info",
"statiegeld_tokens: ${\scalar @used } used by $username: @used"
) if @used;
_write $username, $tokens_by_type, $is_new if $tokens_changed;
return ABORT if %warnings_by_type and not $cart->size;
if (%warnings_by_type and $cart->changed(1)) {
print "\n"; # Between warnings and transaction overview
}
return;
}
sub hook_user_info ($class, $username, @) {
my $tokens_by_type = _read->{lc $username};
my @info;
for my $type (sort keys %$tokens_by_type) {
my @tokens = @{ $tokens_by_type->{$type} // [] };
push @info, sprintf("%dx %s", scalar @tokens, $type);
}
@info = ("none") if not @info;
print "Deposit tokens: ", join(", ", @info), "\n";
}
sub command($self, $cart, $command, @) {
$command eq 'void' or return NEXT;
my $found =0;
for my $entry ($cart->entries('plugin')) {
next if $entry->attribute('plugin') ne 'statiegeld';
$found++;
}
$found or return REJECT, "Add deposit returns first.";
return "The tokens will be deleted irrevokably and you will NOT RECEIVE THE MONEY.\n"
. "Type 'yes' if you are sure", \&void;
}
sub void :Tab(yes,no) ($self, $cart, $input, @) {
if (lc $input eq 'y') {
return REJECT, "y is not yes...";
}
if (lc $input ne 'yes') {
print "Destruction cancelled.\n";
return ACCEPT;
}
for my $entry ($cart->entries('plugin')) {
next if $entry->attribute('plugin') ne 'statiegeld';
$entry->{description} = "Void: $entry->{description}";
$entry->amount(0);
$entry->delete_contras;
# Change key so subsequently added things aren't also void;
# deduplication of tokens to be voided doesn't actually work yet.
$entry->attribute(deduplicate => join("/", $self->id, $entry->attribute('addon_id')));
}
return ACCEPT;
}

View file

@ -1,31 +0,0 @@
=head1 NAME
statiegeld_tokens - RevBank plugin for limiting return deposits
=head1 DESCRIPTION
When using this plugin together with C<statiegeld>, return deposits are limited
to what users have previously paid. This is done by keeping track of I<tokens>:
when you buy something with a deposit, you receive a token, and when you return
the empty container, you spend the token when getting your deposit back.
Tokens expire and are (currently) spent in FIFO order per type. The token type
corresponds to the product_id of the matched addon.
The tokens are stored in a file called C<revbank.statiegeld> which is not
intended to be edited externally.
=head2 User interaction
When checking out, return deposits are removed from the cart if the user does
not have enough tokens for the transaction.
Users can choose to delete tokens by entering the C<void> command before
checking out. At the moment of writing, it is unclear whether this is actually
useful for any practical use case.
=head2 NTP
Tokens expire only if C<ntpdate> or systemd's C<datetimectl> says the system
time is synchronized. Else, new tokens made will never expire and existing
tokens won't be processed for expiry.

View file

@ -1,27 +1,21 @@
#!perl
{
# If you want to keep track of stock, you need a way for people to
# register cash payments. The 'cash' plugin takes care of that, but
# that also assumes deposit_methods. So here's a minimal fallback
# implementation for the 'cash' command.
HELP "cash" => "Checkout without a user account";
# If you use the 'cash' plugin, make sure it is loaded *before*
# the 'stock' plugin in 'revbank.plugins'.
sub command :Tab(cash) {
my ($self, $cart, $command) = @_;
HELP1 "cash" => "Checkout without a user account";
return NEXT if $command ne 'cash';
sub command :Tab(cash) ($self, $cart, $command, @) {
return NEXT if $command ne 'cash';
return NEXT if not $cart->size;
call_hooks("checkout", $cart, 'cash', 0); # Fake checkout
$cart->empty;
$cart->checkout('-cash');
return ACCEPT;
}
return ACCEPT;
}
sub hook_checkout($class, $cart, $user, $transaction_id, @) {
sub hook_checkout {
my ($class, $cart, $user, $transaction_id) = @_;
# Hack42 for some reason used the dutch word in their revbank1 hack.
my $filename = -e("revbank.voorraad")
? "revbank.voorraad"
@ -29,11 +23,17 @@ sub hook_checkout($class, $cart, $user, $transaction_id, @) {
my @entries = $cart->entries('product_id') or return;
my %stock = eval { map { split " ", $_, 2 } slurp $filename };
my %stock = do {
my $in;
open($in, '<', $filename)
? map { split " ", $_, 2 } readline $in
: ()
};
$stock{ $_->attribute('product_id') } -= $_->quantity for @entries;
spurt $filename, map {
sprintf "%-16s %+9d\n", $_, $stock{$_}
} sort keys %stock;
open my $out, '>', "$filename.$$" or warn "$filename.$$: $!";
printf {$out} "%-16s %+9d\n", $_, $stock{$_} for sort keys %stock;
close $out or die "$filename.$$: $!";
rename "$filename.$$", $filename or die $!;
}

View file

@ -1,40 +1,15 @@
#!perl
sub command :Tab(tail) ($self, $cart, $command, @) {
sub command :Tab(tail) {
my ($self, $cart, $command) = @_;
return NEXT if $command ne 'tail';
my $n = (`tput lines 2>/dev/null` || 13) - 3;
my $c = (`tput cols 2>/dev/null` || 80) + 0;
open my $fh, "<", ".revbank.log" or die $!;
my @lines;
while (defined($_ = readline $fh)) {
length($_) > 28 or next;
substr($_, 20, 8) eq 'CHECKOUT' or next; # fast check
my ($dt, $c, $t_id, $u, $dir, $qty, $amount, undef, $desc) = split " ", $_, 9;
$c eq 'CHECKOUT' or next; # real check after expensive split
RevBank::Users::is_hidden($u) and next;
shift @lines if @lines == $n;
$qty = 1 if $qty eq 'EUR'; # log files before commit 63f81e37 (2019-11-05)
push @lines, [$dt, $u, ($dir eq 'GAIN' ? "+ $amount" : $amount), $desc, $qty];
}
close $fh;
my $usercol = 1;
length($_->[1]) > $usercol and $usercol = length($_->[1]) for @lines;
for my $line (@lines) {
my $qty = pop @$line;
$line->[0] =~ s/_/ /;
$line->[1] = sprintf "%-${usercol}s", $line->[1];
$line->[2] = sprintf "%8s", $line->[2];
$line->[3] = "${qty}x $line->[3]" if $qty > 1;
print substr "@$line", 0, $c;
}
# ew :)
system "perl -lane's/CHECKOUT\\s+\\S+\\s+// or next; s/ #// or next; s/_/ /; print' .revbank.log | tail -n$n | perl -ple'\$_ = substr \$_, 0, $c'";
return ACCEPT;
}

View file

@ -2,7 +2,9 @@
HELP "take <account>... <amount> <reason>" => "Transfer money from them to you";
sub command :Tab(take,steal) ($self, $cart, $command, @) {
sub command :Tab(take,steal) {
my ($self, $cart, $command) = @_;
$command eq 'take' or $command eq 'steal'
or return NEXT;
@ -11,7 +13,9 @@ sub command :Tab(take,steal) ($self, $cart, $command, @) {
return "User to take from", \&arg;
}
sub arg :Tab(USERS) ($self, $cart, $arg, @) {
sub arg :Tab(USERS) {
my ($self, $cart, $arg) = @_;
my @users = @{ $self->{users} };
my $amount = parse_amount($arg);
@ -36,14 +40,15 @@ sub arg :Tab(USERS) ($self, $cart, $arg, @) {
push @{ $self->{users} }, $user;
} else {
return REJECT, "$arg: No such user" .
($amount || !@{ $self->{users} } ? "." : ", and not a valid amount.");
($amount ? "." : ", and not a valid amount.");
}
return "User to take from, or total amount to finish", \&arg;
}
# finish
sub reason :Tab(bbq) ($self, $cart, $reason, @) {
sub reason :Tab(bbq,NOABORT) { # finish
my ($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 :)."
@ -54,7 +59,7 @@ sub reason :Tab(bbq) ($self, $cart, $reason, @) {
my $total = $self->{total};
my $users = join '/', @users;
my $entry = $cart->add($total, "Take from $users ($reason)", { is_take => 1 });
my $entry = $cart->add($total, "Taken from $users ($reason)", { is_take => 1 });
for my $user (@users) {
$entry->add_contra( $user, -$each, "Taken by \$you ($reason)" );
}

View file

@ -1,41 +0,0 @@
#!perl
# This is basically like 'withdraw', but for non-cash (e.g. iban)
my @TAB;
sub command :Tab(undeposit) ($self, $cart, $command, @) {
$command eq 'undeposit' or return NEXT;
warn "\n\n\n";
warn "\e[1mNote: this function is for internal use by board members ONLY.\e[0m\n";
warn "\n\n\n";
warn "Enter 'abort' to abort.\n";
@TAB = grep /^[-+]deposit/, RevBank::Users::names
or return REJECT, "No contras available.";
print "Available contras:\n", map " $_\n", sort(@TAB);
return "Contra", \&contra;
}
sub tab { @TAB }
sub contra :Tab(&tab) ($self, $cart, $arg, @) {
return REJECT, "Invalid contra." unless grep $_ eq $arg, @TAB;
$self->{contra} = $arg;
return "Amount to withdraw", \&amount;
}
sub amount($self, $cart, $arg, @) {
my $amount = parse_amount($arg);
defined $amount or return REJECT, "Invalid amount";
$cart
->add(-$amount, "Undeposit", { is_withdrawal => 1 })
->add_contra($self->{contra}, +$amount, "Undeposited by \$you");
return ACCEPT;
}

View file

@ -1,92 +1,56 @@
#!perl
HELP1 "undo <transactionID>" => "Undo a transaction";
HELP "undo <transactionID>" => "Undo a transaction";
my $filename = ".revbank.undo";
my @TAB;
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 REJECT, "Undo is not available mid-transaction.";
$cart->size and return ABORT, "Undo is not available mid-transaction.";
my @log;
for my $line (slurp $filename) {
my ($tid, $user, $delta, $dt) = split " ", $line;
if (@log and $log[-1]{tid} eq $tid) {
push @{ $log[-1]{deltas} }, [ $user, $delta ];
} else {
push @log, { tid => $tid, dt => $dt, deltas => [ [ $user, $delta ] ] };
}
}
@TAB = ();
my $menu = "";
my $max = @log < 15 ? @log : 15;
for my $txn (@log[-$max .. -1]) {
$menu .= "ID: $txn->{tid} $txn->{dt} " . join(", ",
map { sprintf "%s:%+.2f", @$_ } @{ $txn->{deltas} }
) . "\n";
push @TAB, $txn->{tid};
}
return $menu . "Transaction ID", \&undo;
return "Transaction ID", \&undo;
}
sub tab { @TAB }
sub undo {
my ($self, $cart, $tid) = @_;
our $doing_undo = 0; # Ugly but works, just like the rest of this plugin
sub undo :Tab(&tab) ($self, $cart, $tid, @) {
open my $in, '<', $filename or die "$filename: $!";
open my $out, '>', "$filename.$$" or die "$filename.$$: $!";
my $description = "Undo $tid";
my $entry;
my $found = 0;
my $aborted = 0;
return with_lock {
for my $line (slurp $filename) {
if ($line =~ /^\Q$tid\E\s/) {
my (undef, $user, $delta) = split " ", $line;
while (defined(my $line = readline $in)) {
if ($line =~ /^\Q$tid\E\s/) {
my (undef, $user, $delta) = split " ", $line;
$entry ||= $cart->add(0, $description, { undo_transaction_id => $tid });
$entry ||= $cart->add(0, $description);
$entry->{FORCE} = 1;
$entry->add_contra($user, $delta, "Undo $tid");
}
$entry->add_contra($user, $delta, "Undo $tid");
} else {
print {$out} $line;
}
$cart->size or return ABORT, "Transaction ID '$tid' not found in undo log.";
call_hooks("undo", $cart) or return ABORT;
local $doing_undo = 1; # don't allow undoing undos
$cart->checkout('-undo');
return ACCEPT;
};
}
sub hook_checkout_prepare($class, $cart, $username, $transaction_id, @) {
$username eq '-undo' or return;
for my $entry ($cart->entries) {
my $undo_tid = $entry->attribute('undo_transaction_id')
or die "Plugin error: broken '-undo' transaction";
rewrite $filename, sub($line) {
if ($line =~ /^\Q$undo_tid\E\s/) {
return undef; # remove line
} else {
return $line;
}
};
}
close $in;
close $out or die $!;
if ($cart->size) {
rename "$filename.$$", $filename or die $!;
$cart->checkout('**UNDO**');
} else {
return ABORT, "Transaction ID '$tid' not found in undo log.";
}
return ACCEPT;
}
sub hook_user_balance($class, $username, $old, $delta, $new, $transaction_id, @) {
return if $doing_undo; # don't allow undoing undos
sub hook_user_balance {
my ($class, $username, $old, $delta, $new, $transaction_id) = @_;
append $filename, join(" ", $transaction_id, $username, -$delta, now()), "\n";
open my $fh, '>>', $filename or die "$filename: $!";
print {$fh} join " ", $transaction_id, $username, -$delta, now(), "\n";
close $fh or die "$filename: $!";
}

View file

@ -1,34 +1,30 @@
#!perl
HELP1 "unlisted" => "Buy unlisted product (manual entry)";
HELP "unlisted" => "Buy unlisted product (manual entry)";
sub command :Tab(unlisted,donate) ($self, $cart, $command, @) {
sub command :Tab(unlisted,donate) {
my ($self, $cart, $command) = @_;
$command eq 'unlisted' or $command eq 'donate' or return NEXT;
$self->{command} = $command;
my $prompt = $command eq 'donate' ? 'Amount' : 'Price';
return $prompt, \&amount;
return "Amount to deduct from your account", \&amount;
}
sub amount($self, $cart, $arg, @) {
sub amount {
my ($self, $cart, $arg) = @_;
$self->{amount} = parse_amount($arg) or return REJECT, "Invalid amount.";
if ($self->{command} eq 'donate') {
return "Message ('x' for no message)", sub($self, $cart, $desc, @) {
$desc = $desc eq 'x' ? "" : " ($desc)";
$cart
->add(-$self->{amount}, "Donation$desc - THANK YOU!")
->add_contra("+donations", +$self->{amount}, "Donation by \$you");
return ACCEPT;
}
$cart->add(-$self->{amount}, "Donation (THANK YOU!)");
return ACCEPT;
}
return "Please provide a short description", sub($self, $cart, $desc, @) {
$cart
->add(-$self->{amount}, "Unlisted: $desc")
->add_contra("+sales/unlisted", +$self->{amount}, "Unlisted: $desc by \$you");
return ACCEPT;
};
return "Please provide a short description", \&description;
}
sub description {
my ($self, $cart, $desc) = @_;
$cart->add(-$self->{amount}, $desc);
return ACCEPT;
}

View file

@ -1,8 +1,10 @@
#!perl
sub command($self, $cart, $command, @) {
sub command {
my ($self, $cart, $command) = @_;
if ($command =~ m[^https?://]) {
print "This is not a browser...\n";
print "This is not a browser...";
return ACCEPT;
}
return NEXT;
}

View file

@ -1,99 +1,57 @@
#!perl
HELP1 "<account>" => "[Pay with your account and] show balance";
HELP "list" => "List accounts and balances";
HELP "log" => "View transaction log";
HELP "shame" => "Display Hall of Shame (negative balances)";
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,log,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';
return "Username", \&log_for if $command eq 'log';
my $user = parse_user($command)
or return NEXT;
return $self->balance($user) if not $cart->size;
$cart->checkout($user);
$cart->checkout($user) or return REJECT, "Checkout failed.";
return ACCEPT;
}
sub list($self) {
require RevBank::TextEditor;
sub hook_checkout {
my ($class, $cart, $user, $transaction_id) = @_;
my $list = join "", sort {
lc($a) cmp lc($b)
} grep {
!/^[-+]/
} slurp("revbank.accounts");
RevBank::TextEditor::pager("RevBank account list", $list);
return ACCEPT;
}
sub shame($self) {
my $list = join "", sort {
(split " ", $a)[1] <=> (split " ", $b)[1]
} grep {
/ -/ && !/^[-+]/
} slurp("revbank.accounts");
$list =~ s/( -[\d.]+)/\e[31;1m$1\e[0m/g;
print $list;
return ACCEPT;
}
sub _grep($user) {
$user = lc $user;
my @lines;
open my $fh, "<", ".revbank.log" or die $!;
while (defined($_ = readline $fh)) {
length($_) > 28 or next;
substr($_, 20, 8) eq 'CHECKOUT' or next; # fast check
my ($dt, $c, $t_id, $u, $dir, $qty, $amount, undef, $desc) = split " ", $_, 9;
$c eq 'CHECKOUT' or next; # real check after expensive split
lc($u) eq $user or next;
$qty = 1 if $qty eq 'EUR'; # log files before commit 63f81e37 (2019-11-05)
push @lines, sprintf "%s %8s %s%-s", (
$dt =~ s/_/ /r,
$dir eq 'GAIN' ? "+ $amount" : $amount, # like R::A->string_flipped
$qty > 1 ? $qty . "x " : "",
$desc
);
if ($cart->changed) {
say "Done:";
$cart->display;
}
return @lines;
say "Transaction ID: $transaction_id";
}
sub log_for :Tab(USERS) ($self, $cart, $input, @) {
my $user = parse_user($input) or return REJECT, "Unknown user";
my @lines = _grep($user);
require RevBank::TextEditor;
RevBank::TextEditor::logpager("RevBank log for $user", join("", @lines, "(end)"));
sub list {
system "sort -f revbank.accounts | grep -v ^# | perl -pe's/( -[\\d.]+)/\\e[31;1m\$1\\e[0m/' | more";
return ACCEPT;
}
sub _recent($n, $u) {
sub shame {
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) = @_;
$n += 0;
print "Last $n transactions for $u:\n";
print grep defined, +(_grep($u))[-$n .. -1];
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($self, $u) {
_recent(10, $u);
call_hooks("user_info", $u);
my $balance = RevBank::Users::balance($u);
my $red = $balance->cents < 0 ? "31;" : "";
printf "Balance for $u is \e[%s1m%s\e[0m\n", $red, $balance->string("+");
sub balance {
my ($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;
}

View file

@ -1,27 +0,0 @@
sub _read_vat {
my %vat;
for my $line (slurp "revbank.vat") {
my ($match, $vataccount, $pct) = split " ", $line;
$vat{lc $match} = { user => $vataccount, pct => $pct };
}
return \%vat;
}
sub hook_checkout_prepare($class, $cart, $username, $transaction_id, @) {
my $config = _read_vat;
for my $entry ($cart->entries) {
for my $contra ($entry->contras) {
my $vat = $config->{ lc $contra->{user} } or next;
my $amount = RevBank::Amount->new(
$contra->{amount}->cents * $vat->{pct} / (100 + $vat->{pct})
);
my $desc = "VAT ($vat->{pct}% * $contra->{amount})";
my $display = RevBank::Users::is_hidden($contra->{user}) ? undef : $desc;
$entry->add_contra($contra->{user}, -$amount, $desc, $display);
$entry->add_contra($vat->{user}, +$amount, $desc);
}
}
}

View file

@ -1,61 +0,0 @@
=head1 NAME
vat - RevBank plugin for keeping a VAT administration
=head1 SYNOPSIS
C<revbank.vat>
+sales/products +btw/laag 9
+sales/products/hoogbtw +btw/hoog 21
+sales/market +btw/hoog 21
lasercutter +btw/hoog 21
C<revbank.products>
123123123 1.00 "Example product that gets the default contra"
42424242 1.00@+sales/products/hoogbtw "Example with high VAT rate"
=head1 DESCRIPTION
With this plugin, and a properly configured C<revbank.vat> file, RevBank will
subtract the appropriate VAT amount from the revenue account and collect that
in the indicated VAT accounts.
C<revbank.vat> is a whitespace separated file with three columns. The first
column is the account to match, the second column is the account to collect VAT
in, the third is the VAT rate (percentage).
VAT is hidden from the user interface, and only recorded internally, except
when the matched account is a regular account (does not begin with C<-> or
C<+>).
Note that in The Netherlands, hackerspaces will generally be able to use the
I<vrijstelling voor kantines> and I<vrijstelling voor fondsenwervende
activiteiten>. If you pick what you sell carefully, you may not need a BTW/VAT
administration at all.
=head1 CAVEATS
You should test extensively before using this plugin in production. Please let
me know how well it works, because you are probably the first to actually use
this plugin.
There is no configuration for a default VAT rate, so you have to carefully look
for every sales account that requires it and list each one.
Only the contras are matched, e.g. in the example from the synopsis, a C<give>
to C<lasercutter> will incur VAT, but when someone impersonates C<lasercutter>
and does a C<take> from a user from the perspective from C<lasercutter>, no VAT
is counted. This is a feature, and no regular actual user should ever use it
like that, but you should be aware of this subtlety and monitor the log file
for mistakes.
Negative amounts will get negative VAT (e.g. a C<take> from C<lasercutter> in
the example from the synopsis).
=head1 DISCLAIMER
RevBank is not certified or audited tax administration software. You need to
configure it according to local tax laws; don't just copy the example
configuration. Use at your own risk.

16
plugins/voorbeeld Normal file
View file

@ -0,0 +1,16 @@
#!perl
sub command { print "@_\n"; NEXT }
sub hook_user_balance {
my ($class, $username, $old, $delta, $new) = @_;
print "c: $class\n";
print "u: $username\n";
print "o: $old\n";
print "d: $delta\n";
print "n: $new\n";
}

View file

@ -5,7 +5,8 @@
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[^
(?:
@ -25,10 +26,13 @@ sub _read_warnings() {
my ($id, $desc) = @_;
(grep { $_ eq $id } split /,/, $products) ? $text : ();
}
} grep /\S/, grep !/^\s*#/, slurp 'revbank.warnings';
} grep /\S/, grep !/^\s*#/, readline $fh;
}
sub hook_add_entry($class, $cart, $entry, @) {
sub command { NEXT }
sub hook_add_entry {
my ($class, $cart, $entry) = @_;
return if not $entry->has_attribute('product_id'); # skip unlisted, deposit, give, take
my @warnings = map {

View file

@ -1,14 +0,0 @@
sub _set_title($title) {
my $term = $ENV{TERM} or return;
print "\e]2;$title\a" if $term =~ /^xterm|^rxvt/;
print "\e]2;$title\e\\" if $term =~ /^screen/; # includes tmux
}
sub hook_prompt($class, $cart, $prompt, @) {
_set_title($cart->size ? "*RevBank" : "RevBank");
}
END {
_set_title("-");
}

View file

@ -1,20 +1,15 @@
#!perl
HELP1 "withdraw <amount>" => "Withdraw from your account";
HELP "<amount>" => "Withdraw or enter price manually";
sub command :Tab(withdraw) ($self, $cart, $command, @) {
$command eq 'withdraw' or return NEXT;
sub command {
my ($self, $cart, $command) = @_;
return "Amount to withdraw from your account", \&amount;
}
my $amount = parse_amount($command);
defined $amount or return NEXT;
sub amount($self, $cart, $arg, @) {
my $amount = parse_amount($arg);
defined $amount or return REJECT, "Invalid amount";
$cart
->add(-$amount, "Withdrawal", { is_withdrawal => 1 })
->add_contra("-cash", +$amount, "Withdrawn by \$you");
$cart->add(-$amount, "Withdrawal or unlisted product",
{ is_withdrawal => 1 });
return ACCEPT;
}

326
revbank
View file

@ -1,13 +1,11 @@
#!/usr/bin/env perl
#!/usr/bin/perl -w
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 strict;
use attributes;
use IO::Select;
use List::Util ();
use Term::ReadLine;
require Term::ReadLine::Gnu; # The other one sucks.
use FindBin qw($RealBin);
use lib "$RealBin/lib";
@ -15,15 +13,15 @@ use RevBank::Plugins;
use RevBank::Global;
use RevBank::Messages;
use RevBank::Cart;
use RevBank::Prompt;
our $VERSION = "8.3.1";
our %HELP1 = (
our $VERSION = "3.2";
our %HELP = (
"abort" => "Abort the current transaction",
);
my @words; # input
my @words;
my $retry;
my @retry;
my $one_off = 0;
@ -33,61 +31,119 @@ if (@ARGV) {
$one_off = 1;
@words = RevBank::Prompt::split_input($ARGV[1]);
@words and not ref $words[0] or die "Syntax error.\n";
@words = split " ", $ARGV[1];
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 $readline = Term::ReadLine->new($0);
my $select = IO::Select->new;
$select->add(\*STDIN);
my $cart = RevBank::Cart->new;
sub prompt {
my ($prompt, $plugins, $completions) = @_;
if ($prompt) {
$prompt =~ s/$/:/ if $prompt !~ /[?>]$/;
$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;
};
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 $preset = join " ", @retry[0 .. $#retry - 1];
my $cursor = length $preset;
$preset .= " " . join " ", @{ $retry[-1] };
$readline->insert_text($preset);
$readline->Attribs->{point} = $cursor;
@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");
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";
my $split_input = 1;
my $prompt = "";
my @plugins = RevBank::Plugins->new;
my $method = "command";
sub abort {
print @_, " " if @_;
@words = ();
@retry = ();
call_hooks "abort", $cart, \@_;
$cart->empty;
{ no warnings; redo OUTER; }
}
PROMPT: {
if (not @words) {
@ -99,157 +155,73 @@ OUTER: for (;;) {
}
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 %completions = qw(abort 1);
for my $plugin (@plugins) {
my $attr = attributes::get(
ref $method ? $method : $plugin->can($method)
) or next;
my ($tab) = $attr =~ /Tab \( (.*?) \)/x;
for my $keyword (split /\s*,\s*/, $tab) {
if ($keyword =~ /^&(.*)/) {
my $method = $1;
@completions{ $plugin->$method } = ();
} else {
$completions{ $keyword }++;
}
}
my $sep = $word_based ? " " : "";
$default = join($sep, @accepted, @rejected, @trailing);
$pos = @accepted ? length "@accepted$sep" : 0;
@retry = ();
$retry = 0;
}
if (delete $completions{USERS}) {
$completions{$_}++ for RevBank::Users::names;
}
if (delete $completions{NOABORT}) {
delete $completions{abort};
}
my $input = RevBank::Prompt::prompt(
$prompt, \@completions, $default, $pos, $cart, \@plugins
);
if (not defined $input) {
exit if not ttyname fileno STDIN; # Controlling terminal gone
}
my $input = prompt $prompt, \@plugins, [ keys %completions ];
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;
}
@words = ($split_input ? split(" ", $input) : $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
abort if grep $_ eq 'abort', @words;
my $word = shift @words;
push @retry, $word;
$split_input = 0; # Only split 'outer' input.
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$@";
PLUGIN: for my $plugin (@plugins) {
my ($rv, @rvargs) = eval { $plugin->$method($cart, $word) };
if ($@) {
call_hooks "plugin_fail", $plugin->id, $@;
abort;
}
if (not defined $rv) {
call_hooks "plugin_fail", $plugin->id, $mname . "No return code";
call_hooks "plugin_fail", $plugin->id, "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;
}
call_hooks "plugin_fail", $plugin->id, "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];
@ -263,31 +235,23 @@ OUTER: for (;;) {
}
}
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.";
call_hooks "plugin_fail", $plugin->id, "Only 'command' "
. "should ever return NEXT.";
abort;
}
call_hooks "plugin_fail", $plugin->id, $mname . "Invalid return value";
call_hooks "plugin_fail", $plugin->id, "Invalid return value";
abort;
}
call_hooks "invalid_input", $cart, $origword, $word, \@allwords;
call_hooks "invalid_input", $cart, $word;
@retry = ();
abort if @words;
redo OUTER;
} }
}
}
}

Some files were not shown because too many files have changed in this diff Show more