#!perl HELP1 "" => "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; 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() }; }