revbank/plugins/statiegeld

#!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";
}