646 lines
18 KiB
Perl
Executable File
646 lines
18 KiB
Perl
Executable File
#!/usr/bin/env perl
|
||
use strict;
|
||
use utf8;
|
||
|
||
my ($db, %OPTS, $ACCOUNT, %targets);
|
||
|
||
package Commands {
|
||
use Text::Wrap qw(wrap);
|
||
use Carp qw(croak);
|
||
use Scalar::Util qw(openhandle);
|
||
|
||
use open qw/:std :encoding(utf8)/;
|
||
|
||
sub import {
|
||
$db = $_[1];
|
||
set_txn_mode(undef, $_[2] // "each");
|
||
}
|
||
|
||
sub cond_txn_all (&);
|
||
sub cond_txn_each (&);
|
||
sub set_txn_mode {
|
||
my (undef, $mode) = @_;
|
||
|
||
my $with_txn = sub (&) { $db->storage->txn_do(shift) };
|
||
my $no_txn = sub (&) { goto &{$_[0]} };
|
||
|
||
no warnings 'redefine';
|
||
if ( $mode eq "all" ) {
|
||
*cond_txn_all = $with_txn;
|
||
*cond_txn_each = $no_txn;
|
||
}
|
||
elsif ( $mode eq "each" ) {
|
||
*cond_txn_all = $no_txn;
|
||
*cond_txn_each = $with_txn;
|
||
}
|
||
else {
|
||
croak "Unsupported txn_mode $mode";
|
||
}
|
||
}
|
||
|
||
sub single_charge { # charge interactively
|
||
my $accounts = $db->resultset("Account");
|
||
|
||
_require_value();
|
||
_require_purpose();
|
||
_provide_date();
|
||
|
||
my $billId = delete $OPTS{'bill-id'}
|
||
and _require_target();
|
||
|
||
my $charger = sub {
|
||
my ($account, $billId) = @_;
|
||
my $what = $billId ? 'add_to_debits' : 'add_to_credits';
|
||
return $account->$what({
|
||
$billId ? (
|
||
billId => sprintf($billId, $account->ID),
|
||
targetCredit => delete( $OPTS{target} ),
|
||
) : (),
|
||
map { $_ => $OPTS{$_} } qw(value purpose date),
|
||
});
|
||
};
|
||
|
||
if ( $ACCOUNT ) {
|
||
my $account = $accounts->find({ ID => $ACCOUNT });
|
||
my ($record, $transf_count);
|
||
cond_txn_each {
|
||
$record = $charger->($account, $billId);
|
||
if ( !$billId and my $t = $OPTS{target} ) {
|
||
$transf_count = $db->make_transfers( $record->ID => $t );
|
||
}
|
||
};
|
||
printf("Created %s, transferred %d of %d.\n",
|
||
$billId // $record->credId, $transf_count, $record->value
|
||
);
|
||
}
|
||
|
||
elsif ( $billId =~ s{ @ (\{)? ((?(1)\S+|\w+)) (?(1)\}) }{ %s }xms ) {
|
||
# ^^ regex to consider list of real or pseudonymized account IDs
|
||
# e.g. @Member | @{one,another,...} | @{M{xyz},M{mno}}
|
||
$accounts = $accounts->search({
|
||
$1 ? (ID => { -in => [ split /,/, $2 ] }) : ( type => $2 )
|
||
});
|
||
cond_txn_all {
|
||
while ( my $account = $accounts->next ) {
|
||
cond_txn_each { $charger->( $account, $billId ); }
|
||
}
|
||
};
|
||
}
|
||
|
||
else {
|
||
croak "You haven't specified an account to charge";
|
||
}
|
||
|
||
}
|
||
|
||
sub _require_value {
|
||
until ( $OPTS{value} && $OPTS{value} =~ m{^\d+(\.\d\d)?$} ) {
|
||
print "Charge value in cent (or use decimal point): ";
|
||
chomp( $OPTS{value} = <STDIN> );
|
||
}
|
||
$_ = integer_money_value($_) for $OPTS{value};
|
||
}
|
||
|
||
sub _require_purpose {
|
||
until ( $OPTS{purpose} ) {
|
||
print "Purpose: ";
|
||
chomp( $OPTS{purpose} = <STDIN> );
|
||
}
|
||
}
|
||
|
||
sub _provide_date {
|
||
my ($YEAR, $MONTH, $DAY) = (localtime)[3,4,5];
|
||
$YEAR += 1900; $MONTH++;
|
||
until ( $OPTS{date} && $OPTS{date} =~ m{\d{4}-?\d\d-?\d\d} ) {
|
||
|
||
printf "Full date [YYYY-MM-DD] or year [%d]: ", $YEAR;
|
||
chomp( my $year = <STDIN> );
|
||
if ( !length($year) ) {}
|
||
elsif ( $year =~ m{^(\d{4})-(\d\d)-(\d\d)$} ) {
|
||
($YEAR, $MONTH, $DAY) = ($1, $2, $3);
|
||
goto ASSIGN;
|
||
}
|
||
elsif ( $year =~ m{^(\d\d)?\d\d$} && $year > 0 ) {
|
||
substr $year, 0, 0, 20 if !$1;
|
||
if ( $year ne $YEAR ) {
|
||
$YEAR = $year;
|
||
$_ = '' for $MONTH, $DAY;
|
||
}
|
||
}
|
||
else { redo; }
|
||
|
||
printf "Month [%d]: ", $MONTH;
|
||
chomp( my $month = <STDIN> );
|
||
if ( !length( $month ) && $MONTH ) {}
|
||
elsif ( $month !~ m{\D} && $month > 0 && $month < 13 ) {
|
||
if ( $month != $MONTH ) {
|
||
$MONTH = $month;
|
||
$DAY = '';
|
||
}
|
||
}
|
||
else { redo; }
|
||
|
||
printf "Day [%d]: ", $DAY;
|
||
chomp( my $day = <STDIN> );
|
||
if ( !length( $day ) ) {}
|
||
elsif ( $day !~ m{\D} && $day > 0 && $month < 31 ) {
|
||
$DAY = $day;
|
||
}
|
||
else { redo; }
|
||
|
||
ASSIGN:
|
||
$OPTS{date} = sprintf "%4d-%02d-%02d", $YEAR, $MONTH, $DAY;
|
||
|
||
}
|
||
}
|
||
|
||
sub _require_target {
|
||
my $t;
|
||
until ( $t = $OPTS{target} and $t =~ m{^\d+$} ) {
|
||
unless ( $t ) {
|
||
print "Target credit id: ";
|
||
chomp( my $t = <STDIN> );
|
||
}
|
||
if ( $t =~ m{ \A \? (\w+) \z } ) {
|
||
$OPTS{target} = select_target_credit_from($t);
|
||
}
|
||
}
|
||
}
|
||
|
||
sub charge_account {
|
||
goto &single_charge if %OPTS;
|
||
|
||
print "Enter records ...\n" if -t STDIN;
|
||
|
||
local *ARGV = (
|
||
openhandle($_[0])
|
||
// croak "charge_account() expects open file handle to read from"
|
||
) if my $abort_on_exception = exists $_[0];
|
||
|
||
# Possible line formats:
|
||
# -------------------------------------------------------
|
||
#
|
||
# Date Account Var Amount Purpose :: Credit (Payment or target)
|
||
# ^^^ Field may be empty or '+', yet not omitted
|
||
# Date Account Amount TCr ID: Purpose :: Bill
|
||
# ^^^ Field may be empty, yet not omitted
|
||
#
|
||
# Please note: Omit Account if it is specified on commandline.
|
||
#
|
||
|
||
cond_txn_all {
|
||
|
||
while ( defined( my $line = <ARGV> ) ) {
|
||
|
||
_strip_comment_from($line) // next;
|
||
|
||
my ($sep) = $line =~ m{([,; \t|])};
|
||
|
||
my @columns
|
||
= split /[$sep][ ]*/, $line,
|
||
defined($ACCOUNT) ? 4 : 5;
|
||
|
||
splice @columns, 1, 0, $ACCOUNT // ();
|
||
|
||
# Strip quotes from all but ultimate purpose
|
||
for ( @columns[ 0 .. 3 ] ) {
|
||
m{\A(["'])}xms && m{$1\z}xms or next;
|
||
substr $_, 0, 1, '';
|
||
substr $_, -1, 1, '';
|
||
}
|
||
my ($record, $transf_count)
|
||
= eval { cond_txn_each { _inner_charge(@columns) } };
|
||
|
||
if ( !defined $record ) {
|
||
if ( $@ ) {
|
||
die $@ if $abort_on_exception;
|
||
warn $@;
|
||
next;
|
||
}
|
||
else { die '_inner_charge() returned nothing'; }
|
||
};
|
||
|
||
printf("Created %s, transferred %d of %d.\n",
|
||
eval { $record->billId } // $record->credId,
|
||
$transf_count, $record->value
|
||
);
|
||
}
|
||
|
||
}
|
||
}
|
||
|
||
sub _inner_charge {
|
||
my ($date, $account, $debit, $credit, $purpose) = @_;
|
||
|
||
$account = $db->resultset("Account")->find($account)
|
||
// croak "There is no account with that name: $account";
|
||
|
||
chomp $credit if !defined $purpose;
|
||
|
||
{ # In order to slurp any consecutive lines take two cases into account:
|
||
# 1) Purpose has not begun next from value on initial line ->
|
||
# Grab every line before the next empty one (must have no length).
|
||
# Consider any quotes to be literal.
|
||
# 2) Grab everything until closing quote is recognized.
|
||
# This is the case when the quote is the same as the opening one,
|
||
# it in not doubled and before a space or the end of line.
|
||
|
||
my ($quot, $end, $has_more, $line);
|
||
|
||
$DB::single = 1;
|
||
|
||
if ( defined $purpose ) {
|
||
$has_more = $purpose !~ s{ \A (?<quot> ["'] ) }{}xms
|
||
&& $purpose =~ m{ : \s* \z }xms;
|
||
}
|
||
else {
|
||
$has_more = 1;
|
||
($purpose = <ARGV>) =~ s{^\s+}{};
|
||
}
|
||
|
||
while (1) { # Single iteration, either early closed or redone
|
||
|
||
$has_more
|
||
or # we are inside region wrapped by identical quotes:
|
||
($quot = $+{quot}) .. ( $end = $purpose =~ s{
|
||
\G # from position of last iteration
|
||
(?<![$quot\\]) # must not be preseded by escape or
|
||
($quot) # same quote
|
||
(?=\s|\z) # before space or end of line
|
||
}{}goxms
|
||
)
|
||
or last # because there are no consecutive lines.
|
||
;
|
||
|
||
last if (!$+{quot} && $end) # we reach closing quote
|
||
|| !defined($line = <ARGV>) # there is no next line
|
||
|| ($has_more && $line eq $/) # empty line
|
||
;
|
||
|
||
$line =~ s{^\s+}{};
|
||
$line =~ s{$quot{2}}{$quot}g if $quot; # merge consecutive quotes
|
||
$purpose .= $line;
|
||
|
||
}
|
||
|
||
chomp $purpose;
|
||
_strip_comment_from($purpose);
|
||
|
||
}
|
||
|
||
my ($record, @transfer, $category);
|
||
|
||
if ( $purpose =~ s{ \s* -C\[ ([^\r\t\n\]]+) \] \z }{}xms ) {
|
||
$category = $db->resultset("Category")->search({
|
||
$1 =~ /^\d+$/ ? (ID => $1) : (label => { -like => "$1%" })
|
||
})->single->ID;
|
||
}
|
||
|
||
if ( $debit =~ /\b\d/ ) {
|
||
|
||
my $tgt = $credit;
|
||
my $billId = $purpose =~ s{ \A ([[:graph:]]+?) : \s* }{}xms
|
||
? $1
|
||
: croak qq{Missing ID in debit purpose: $purpose}
|
||
;
|
||
|
||
if ( $purpose =~ s{ (?: \t | \s* << \s* ) (.+?) \r? \n? \z }{}xms ) {
|
||
push @transfer, [
|
||
map { /\D/ ? $targets{ $_ } : $_ } split /,\s*/, $1
|
||
] => $billId;
|
||
}
|
||
|
||
if ( my ($var, $op, $assigned)
|
||
= $tgt =~ m{ \A ([A-Za-z]\w+) ([?=]) (\w+) \z }xms
|
||
) {
|
||
|
||
if ( defined( my $c = $targets{$var} ) ) {
|
||
croak "$var already assigned to $c";
|
||
}
|
||
|
||
if ( $op eq q{=} ) {
|
||
$tgt = $targets{ $var } = $assigned;
|
||
}
|
||
else {
|
||
$tgt = select_target_credit_from($assigned, $var);
|
||
}
|
||
|
||
}
|
||
elsif ( $tgt =~ /^[a-z]/i ) {
|
||
$tgt = $targets{ $tgt }
|
||
// croak "Target credit not assigned: $tgt!\n";
|
||
}
|
||
else { $tgt = undef; }
|
||
|
||
$record = $account->add_to_debits({
|
||
billId => $billId,
|
||
date => $date,
|
||
purpose => $purpose,
|
||
value => integer_money_value($debit),
|
||
targetCredit => $tgt,
|
||
category => $category
|
||
});
|
||
|
||
}
|
||
|
||
elsif ( $credit =~ /\b\d/ ) {
|
||
|
||
my $tgt = $purpose =~ s{ \s* >> \s* (.+) \r? \n? \z }{}xms && $1;
|
||
|
||
my $c = $account->add_to_credits({
|
||
date => $date,
|
||
account => $account,
|
||
purpose => $purpose,
|
||
value => integer_money_value($credit),
|
||
category => $category
|
||
});
|
||
|
||
if ( $debit =~ /^[a-z]/i ) { $targets{ $debit } = $c->credId; }
|
||
elsif ( length $debit && $debit ne q{+} ) {
|
||
croak "Invalid field input: $debit neither number nor name";
|
||
}
|
||
|
||
push @transfer, $c->credId => $tgt if $tgt;
|
||
|
||
$record = $c;
|
||
}
|
||
|
||
else {
|
||
croak "Cannot be parsed: $debit $credit\n";
|
||
}
|
||
|
||
return $record, @transfer ? $db->make_transfers(@transfer) : 0;
|
||
|
||
}
|
||
|
||
sub _strip_comment_from {
|
||
my $comment;
|
||
$comment .= $1 while $_[0] =~ s{ \s+ (?<!\\) \# (.*) $ }{}gxm;
|
||
$comment =~ s{\\#}{#}gxms;
|
||
return( $comment or length($_[0]) ? q{} : undef );
|
||
}
|
||
|
||
sub integer_money_value {
|
||
|
||
my $val = shift;
|
||
|
||
# Strip currency signs and space.
|
||
$val =~ s{ \A [^0-9]+ }{}xms;
|
||
$val =~ s{ [^0-9]+ \z }{}xms;
|
||
|
||
# Strip cent to finally add to the integer
|
||
my $cent = $val =~ s{ [,.] ([0-9]{2})? \z }{}xms ? $1 || 0 : undef;
|
||
|
||
# Strip number formatting separators
|
||
$val =~ s{ (?<=[0-9]) [ _.,'’] (?=[0-9]) }{}gxms;
|
||
|
||
die "Not a positive money value (cent): $val" if $val =~ /[^0-9]/;
|
||
|
||
($val *= 100) += $cent if defined $cent;
|
||
return $val;
|
||
}
|
||
|
||
sub select_target_credit_from {
|
||
my ($account, $var) = @_;
|
||
|
||
croak "Interactive target credit selection is not possible"
|
||
if !( -t STDIN );
|
||
|
||
print "Please select target credit to reference by $var:\n",
|
||
"-------------------------------------------------\n";
|
||
|
||
$account = $db->resultset("Account")->find($account);
|
||
my $credits = $account->credits->search({}, {
|
||
join => 'income',
|
||
group_by => ['income.targetCredit'],
|
||
having => \[ 'ifnull(sum(income.paid),0) = me.value' ],
|
||
});
|
||
|
||
croak $account->ID
|
||
. " has no credits to receive settlements of debt"
|
||
if !$credits->count;
|
||
|
||
while ( my $c = $credits->next ) {
|
||
printf "%d) %s %s\n", $c->credId, $c->date, $c->purpose;
|
||
}
|
||
|
||
while (1) {
|
||
print "Which credit do you want to target? ";
|
||
chomp( my $input = <STDIN> );
|
||
return $targets{ $var } = $input if $credits->find($input);
|
||
warn "Credit ID $input is not a listed option.\n";
|
||
}
|
||
|
||
}
|
||
|
||
sub make_transfers {
|
||
print "Make transfers ...\n";
|
||
|
||
if ( ! -t STDIN ) {
|
||
croak "Input expected from interactive terminal";
|
||
}
|
||
|
||
my $search_opts = { order_by => { -asc => ['date'] } };
|
||
my $avcredits = $db->resultset("AvailableCredits")->search(
|
||
{ $OPTS{source} ? (
|
||
credId => { -in => TrsrDB::expand_ids($OPTS{source}) }
|
||
) : ()
|
||
},
|
||
$search_opts
|
||
);
|
||
my $transfers = $db->resultset("Transfer");
|
||
|
||
CREDIT:
|
||
while ( my $c = $avcredits->next ) {
|
||
|
||
printf " * [%d] %s has %d available in credit %d) %s\n",
|
||
$c->date, $c->account->ID, $c->difference, $c->credId, $c->purpose;
|
||
|
||
my $suggestions = $c->suggested_to_pay->search(
|
||
{ $OPTS{target} ? (
|
||
billId => { -in => TrsrDB::expand_ids($OPTS{target}) }
|
||
) : ()
|
||
},
|
||
$search_opts
|
||
);
|
||
|
||
my $last_input = q{ };
|
||
|
||
cond_txn_all {
|
||
|
||
DEBIT:
|
||
while ( my $s = $suggestions->next ) {
|
||
printf " - [%s] %s: %s? (%s)\b\b", $s->date, $s->billId,
|
||
$s->purpose, $last_input;
|
||
chomp( my $input = <STDIN> );
|
||
$input = $last_input if !length($input);
|
||
if ( lc($input) =~ /^y(es)?$/i ) {
|
||
$transfers->create({
|
||
credId => $c->credId, billId => $s->billId
|
||
});
|
||
}
|
||
elsif ( !$input || lc($input) !~ /^no?$/i ) {
|
||
print "Input invalid!\n";
|
||
redo DEBIT;
|
||
}
|
||
$last_input = $input;
|
||
}
|
||
|
||
}
|
||
}
|
||
}
|
||
|
||
sub balance_status {
|
||
my ($with_report) = @_;
|
||
print "Get balance status ...\n";
|
||
my $results = $db->resultset("Balance");
|
||
my $header = "\tavailbl\tearned\tspent\tpromise\tarrears\teven_until\n";
|
||
print "ID", $header unless $with_report;
|
||
while ( my $r = $results->next ) {
|
||
my %val = $r->get_columns();
|
||
if ($with_report) { _balance_report( $val{ID} ) }
|
||
print join "\t", $with_report ? "Balance:\n$header" : $val{ID},
|
||
map({ sprintf '%7d', $val{$_} } qw{
|
||
available earned spent promised arrears
|
||
}), $val{even_until};
|
||
print "\n";
|
||
}
|
||
}
|
||
|
||
sub _balance_report {
|
||
my ($id) = @_;
|
||
print "Report of account $id:\n", "=" x 76, "\n";
|
||
my $rs = $db->resultset("Account")->find($id)->report();
|
||
my ($i, $state) = (0, 1);
|
||
|
||
my $c = 0;
|
||
|
||
my $print_subline = sub {
|
||
my $row = shift;
|
||
$row->{value} /= 100;
|
||
my $tab = " " x (2 + length $c);
|
||
print wrap( $row->{value} > 0 ? "$c. " : $tab, $tab, sprintf(
|
||
"\t%+f\t%s @ %s\n", @{$row}{qw/value purpose date/}
|
||
));
|
||
};
|
||
my $print_remainder = sub {
|
||
my $c = $db->resultset("AvailableCredits")->find($c) // return;
|
||
print " " x length( $c->credId ), " (+", $c->difference,
|
||
" left available.)";
|
||
};
|
||
|
||
while ( my $row = $rs->next ) {
|
||
$i++;
|
||
my %d = $row->get_columns();
|
||
if ( $c && !defined $d{credId} ) {
|
||
print "--- Current arrears: ---\n";
|
||
$c = 0;
|
||
redo;
|
||
}
|
||
|
||
$d{credId} //= 0;
|
||
if ( $d{value} > 0 ) {
|
||
$print_remainder->() if $c;
|
||
$c = $d{credId};
|
||
}
|
||
elsif( $d{credId} != $c ) {
|
||
die "Unexpected transfer for credId $d{credId}!\n";
|
||
}
|
||
|
||
$print_subline->(\%d);
|
||
|
||
}
|
||
|
||
if ( !$i ) {
|
||
print "Account is evened out, alright.\n";
|
||
}
|
||
}
|
||
|
||
} # End of package Commands
|
||
|
||
return 1 if caller;
|
||
|
||
package main;
|
||
|
||
use Getopt::Long;
|
||
use FindBin qw($Bin);
|
||
use lib $Bin;
|
||
BEGIN {
|
||
if (!( $ARGV[0] eq 'makedb'
|
||
|| $ARGV[0] eq 'server'
|
||
|| $ARGV[0] eq 'sql'
|
||
)) {
|
||
require TrsrDB;
|
||
TrsrDB->import(\$db);
|
||
}
|
||
elsif ( $ARGV[0] eq 'makedb' && -e $ENV{TRSRDB_SQLITE_FILE} ) {
|
||
die "$ENV{TRSRDB_SQLITE_FILE} does exist.\n";
|
||
}
|
||
}
|
||
|
||
Commands::set_txn_mode(undef, "each");
|
||
|
||
%OPTS = (
|
||
'account' => \$ACCOUNT,
|
||
'target-credit' => \%targets,
|
||
'txn-mode' => \&Commands::set_txn_mode,
|
||
);
|
||
GetOptions( \%OPTS,
|
||
'txn-mode=s', 'account|a=s', 'target|t=s', 'target-credit|tcr=i', 'source|s=s',
|
||
'date|d=s', 'value|v=i', 'purpose|p=s', 'bill-id|b=s'
|
||
);
|
||
delete @OPTS{'account', 'target-credit', 'txn-mode'};
|
||
|
||
my %dispatcher = (
|
||
charge => \&Commands::charge_account,
|
||
ct => sub {
|
||
Commands::charge_account();
|
||
Commands::make_transfers();
|
||
},
|
||
cts => sub {
|
||
Commands::charge_account();
|
||
Commands::make_transfers();
|
||
Commands::balance_status();
|
||
},
|
||
ctr => sub {
|
||
Commands::charge_account();
|
||
Commands::make_transfers();
|
||
Commands::balance_status(1);
|
||
},
|
||
makedb => sub {
|
||
chdir($Bin);
|
||
exec q[cat schema/tables.sql schema/*/*.sql]
|
||
. q[| sqlite3 $TRSRDB_SQLITE_FILE];
|
||
},
|
||
report => sub {
|
||
Commands::balance_status(1);
|
||
},
|
||
server => sub {
|
||
exec qw{morbo server -w TrsrDB -w templates/};
|
||
},
|
||
sql => sub {
|
||
exec "sqlite3",
|
||
-cmd => "PRAGMA foreign_keys=ON; PRAGMA recursive_triggers=ON;",
|
||
'-line', $ENV{TRSRDB_SQLITE_FILE};
|
||
},
|
||
status => \&Commands::balance_status,
|
||
transfer => \&Commands::make_transfers,
|
||
tr => sub {
|
||
Commands::make_transfers();
|
||
Commands::balance_status(1);
|
||
},
|
||
ts => sub {
|
||
Commands::make_transfers();
|
||
Commands::balance_status();
|
||
}
|
||
);
|
||
|
||
my $cmd = shift;
|
||
if ( my $sref = $dispatcher{ $cmd } ) {
|
||
$sref->();
|
||
}
|
||
else {
|
||
die qq{Command not supported: $cmd\n};
|
||
}
|
||
|