#!/usr/bin/env perl use strict; 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 => $billId, targetCredit => delete( $OPTS{target} ), ) : (), map { $_ => $OPTS{$_} } qw(value purpose date), }); }; if ( $ACCOUNT ) { my $account = $accounts->find({ ID => $ACCOUNT }); cond_txn_each { my $record = $charger->($account, $billId); if ( !$billId and my $t = $OPTS{target} ) { $db->make_transfers( $record->ID => $t ); } }; } elsif ( $billId =~ s{ @(\w+) }{ %s }xms ) { $accounts = $accounts->search({ type => $1 }); cond_txn_all { while ( my $account = $accounts->next ) { cond_txn_each { $charger->( $account, sprintf $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 (cent part omittable): "; chomp( $OPTS{value} = ); } $_ = integer_money_value($_) for $OPTS{value}; } sub _require_purpose { until ( $OPTS{purpose} ) { print "Purpose: "; chomp( $OPTS{purpose} = ); } } 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 = ); 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 = ); 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 = ); 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 = ); } 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; exists $_[0] and local *ARGV = ( openhandle($_[0]) // croak "charge_account() expects open file handle to read from" ) and my $abort_on_exception = 1 ; # 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 = ) ) { _strip_comment_from($line) // next; my @columns = split /[, \t][ ]*/, $line, defined($ACCOUNT) ? 4 : 5; splice @columns, 1, 0, $ACCOUNT // (); eval { cond_txn_each { _inner_charge(@columns) } } // do { if ( $@ ) { die $@ if $abort_on_exception; warn $@; } }; } } } 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; { # Append any consecutive lines my ($has_more, $line); for ( $purpose //= do { $has_more = 1; } ) { (s/^"// .. s/(? or last; last if $line eq $/; $line =~ s{^\s+}{}; $_ .= $line; redo; } _strip_comment_from($purpose); } my @transfer; if ( $debit =~ /^\d/ ) { my $tgt = $credit; my $billId = $purpose =~ s{ \A ([[:print:]]+?) : \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-Za-z]\w+)([?=])(\w+)$} ) { 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"; } $account->add_to_debits({ billId => $billId, date => $date, purpose => $purpose, value => integer_money_value($debit), targetCredit => $tgt, }); } elsif ( $credit =~ /^\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) }); 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; } else { croak "Cannot be parsed: $debit $credit\n"; } $db->make_transfers(@transfer) if @transfer; } sub _strip_comment_from { my $comment; $comment .= $1 while $_[0] =~ s{ \s+ (?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 = ); 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 = ); $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}, @val{qw{ available earned spent promised arrears 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 TrsrDB \$db; %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' ); $DB::single=1; 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); }, 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}; }