Move read_products() from plugin to core
Additional changes:
- Parametrized $filename and $default_contra
- Add ->{config} to product hashes, which is the re-serialized config line
This commit is contained in:
Juerd Waalboer
parent
4abce51769
commit
7c5431fba4
2 changed files with 142 additions and 127 deletions
141
lib/RevBank/Products.pm
Normal file
141
lib/RevBank/Products.pm
Normal file
|
|
@ -0,0 +1,141 @@
|
|||
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);
|
||||
|
||||
sub read_products($filename = "revbank.products", $default_contra = "+sales/products") {
|
||||
state %cache; # $filename => \%products
|
||||
state %mtimes; # $filename => mtime
|
||||
|
||||
my $mtime = \$mtimes{$filename};
|
||||
|
||||
return $cache{$filename} if $$mtime and $$mtime == -M $filename;
|
||||
|
||||
my %products;
|
||||
my $linenr = 0;
|
||||
my $warnings = 0;
|
||||
|
||||
$$mtime = -M $filename;
|
||||
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 $canonical = join " ", map RevBank::Prompt::reconstruct($_), $ids, $p, $desc, @extra;
|
||||
|
||||
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;
|
||||
}
|
||||
}
|
||||
for my $id (@ids) {
|
||||
warn "Product '$id' redefined at $filename line $linenr (original at line $products{$id}{line}).\n" if exists $products{$id};
|
||||
|
||||
$products{$id} = {
|
||||
id => $ids[0],
|
||||
price => $sign * $price,
|
||||
percent => $percent,
|
||||
description => $desc,
|
||||
contra => $contra || $default_contra,
|
||||
_addon_ids => \@addon_ids,
|
||||
line => $linenr,
|
||||
tags => \%tags,
|
||||
config => $canonical,
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
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 $cache{$filename} = \%products;
|
||||
}
|
||||
|
||||
1;
|
||||
128
plugins/products
128
plugins/products
|
|
@ -1,134 +1,8 @@
|
|||
#!perl
|
||||
use RevBank::Products qw(read_products);
|
||||
|
||||
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 (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 ||= "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;
|
||||
}
|
||||
}
|
||||
for my $id (@ids) {
|
||||
warn "Product '$id' redefined at $filename line $linenr (original at line $products{$id}{line}).\n" if exists $products{$id};
|
||||
|
||||
$products{$id} = {
|
||||
id => $ids[0],
|
||||
price => $sign * $price,
|
||||
percent => $percent,
|
||||
description => $desc,
|
||||
contra => $contra || $default_contra,
|
||||
_addon_ids => \@addon_ids,
|
||||
line => $linenr,
|
||||
tags => \%tags,
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
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;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue