revbank/plugins/products
Juerd Waalboer 55a83d9ceb v6.0.0: big revbank.products syntax change
Rationale in UPGRADING.md

It's a big change technically, but converting the format won't be hard
for admins.

There's a compatibility mode with loud warnings in case the file isn't
converted.
2024-01-20 03:50:10 +01:00

192 lines
5.2 KiB
Perl

#!perl
HELP1 "<productID>" => "Add a product to pending transaction";
my $filename = 'revbank.products';
my $default_contra = '+sales/products';
sub read_products() {
state %products;
state $mtime;
return \%products if $mtime and $mtime == -M $filename;
%products = ();
$mtime = -M $filename;
my $linenr = 0;
my $warnings = 0;
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 (grep /\0SEPARATOR/, @split) {
warn "Invalid character in $filename line $linenr.\n";
next;
}
if (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 ||= "invalid";
$desc ||= "(no description)";
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;
}
$price = 0 + $price;
} else {
$price = eval { parse_amount($price) };
if (not defined $price) {
warn "Invalid price for '$ids[0]' at $filename line $linenr.\n";
next;
}
}
$products{$_} = {
id => $ids[0],
price => $sign * $price,
percent => $percent,
description => $desc,
contra => $contra || $default_contra,
_addon_ids => \@addon_ids,
line => $linenr,
tags => \%tags,
} for @ids;
}
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;
}
push @{ $product->{addons} }, $addon;
push @addon_ids, @{ $addon->{_addon_ids} };
}
}
return \%products;
}
sub command :Tab(&tab) ($self, $cart, $command, @) {
$command =~ /\S/ or return NEXT;
$command =~ /^\+/ and return NEXT;
my $products = read_products;
my $product = $products->{ $command } or return NEXT;
my $price = $product->{price};
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;
my $entry = $cart->add(
-$price,
$product->{description},
{
product_id => $product->{id},
plugin => $self->id,
product => $product,
deduplicate => join("/", $self->id, $product->{id}),
}
);
$entry->add_contra(
$product->{contra},
+$price,
$contra_desc,
$display
);
for my $addon (@addons) {
my $addon_price = $addon->{price};
if ($addon->{percent}) {
my $sum = List::Util::sum map {
$_->{amount}
} grep {
$_->{user} eq $addon->{contra}
} $entry->contras;
$addon_price = $addon_price / 100 * $sum;
}
$entry->amount( $entry->amount - $addon_price );
$entry->add_contra(
$addon->{contra},
$addon_price,
"$addon->{description} ($contra_desc)",
$addon->{description}
);
}
return ACCEPT;
}
sub tab {
return grep !/^\+/, grep /\D/, keys %{ read_products() };
}