flow/treasuredb
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Various fixes and UX optimizations in trsr

Browse Source
This commit is contained in:
Florian "flowdy" Heß 2017-03-05 14:09:58 +01:00
parent 5299966837
commit 6391b0498c
2 changed files with 148 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
TrsrDB/Category.pm
View File

@ -3,7 +3,7 @@ use strict;
package TrsrDB::Category; package TrsrDB::Category;
use base qw/DBIx::Class::Core/; use base qw/DBIx::Class::Core/;
__PACKAGE__->table('category'); __PACKAGE__->table('Category');
__PACKAGE__->add_columns(qw/ID label/); __PACKAGE__->add_columns(qw/ID label/);
__PACKAGE__->set_primary_key('ID'); __PACKAGE__->set_primary_key('ID');

184
trsr
View File

@ -1,5 +1,6 @@
#!/usr/bin/env perl #!/usr/bin/env perl
use strict; use strict;
use utf8;
my ($db, %OPTS, $ACCOUNT, %targets); my ($db, %OPTS, $ACCOUNT, %targets);
@ -52,7 +53,7 @@ sub single_charge { # charge interactively
my $what = $billId ? 'add_to_debits' : 'add_to_credits'; my $what = $billId ? 'add_to_debits' : 'add_to_credits';
return $account->$what({ return $account->$what({
$billId ? ( $billId ? (
billId => $billId, billId => sprintf($billId, $account->ID),
targetCredit => delete( $OPTS{target} ), targetCredit => delete( $OPTS{target} ),
) : (), ) : (),
map { $_ => $OPTS{$_} } qw(value purpose date), map { $_ => $OPTS{$_} } qw(value purpose date),
@ -61,19 +62,27 @@ sub single_charge { # charge interactively
if ( $ACCOUNT ) { if ( $ACCOUNT ) {
my $account = $accounts->find({ ID => $ACCOUNT }); my $account = $accounts->find({ ID => $ACCOUNT });
my ($record, $transf_count);
cond_txn_each { cond_txn_each {
my $record = $charger->($account, $billId); $record = $charger->($account, $billId);
if ( !$billId and my $t = $OPTS{target} ) { if ( !$billId and my $t = $OPTS{target} ) {
$db->make_transfers( $record->ID => $t ); $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{ @(\w+) }{ %s }xms ) { elsif ( $billId =~ s{ @ (\{)? ((?(1)\S+|\w+)) (?(1)\}) }{ %s }xms ) {
$accounts = $accounts->search({ type => $1 }); # ^^ 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 { cond_txn_all {
while ( my $account = $accounts->next ) { while ( my $account = $accounts->next ) {
cond_txn_each { $charger->( $account, sprintf $billId ); } cond_txn_each { $charger->( $account, $billId ); }
} }
}; };
} }
@ -86,7 +95,7 @@ sub single_charge { # charge interactively
sub _require_value { sub _require_value {
until ( $OPTS{value} && $OPTS{value} =~ m{^\d+(\.\d\d)?$} ) { until ( $OPTS{value} && $OPTS{value} =~ m{^\d+(\.\d\d)?$} ) {
print "Charge value (cent part omittable): "; print "Charge value in cent (or use decimal point): ";
chomp( $OPTS{value} = <STDIN> ); chomp( $OPTS{value} = <STDIN> );
} }
$_ = integer_money_value($_) for $OPTS{value}; $_ = integer_money_value($_) for $OPTS{value};
@ -153,7 +162,7 @@ sub _require_target {
chomp( my $t = <STDIN> ); chomp( my $t = <STDIN> );
} }
if ( $t =~ m{ \A \? (\w+) \z } ) { if ( $t =~ m{ \A \? (\w+) \z } ) {
$OPTS{target} = _select_target_credit_from($t); $OPTS{target} = select_target_credit_from($t);
} }
} }
} }
@ -163,13 +172,10 @@ sub charge_account {
print "Enter records ...\n" if -t STDIN; print "Enter records ...\n" if -t STDIN;
exists $_[0] local *ARGV = (
and local *ARGV = (
openhandle($_[0]) openhandle($_[0])
// croak "charge_account() expects open file handle to read from" // croak "charge_account() expects open file handle to read from"
) ) if my $abort_on_exception = exists $_[0];
and my $abort_on_exception = 1
;
# Possible line formats: # Possible line formats:
# ------------------------------------------------------- # -------------------------------------------------------
@ -188,18 +194,36 @@ sub charge_account {
_strip_comment_from($line) // next; _strip_comment_from($line) // next;
my ($sep) = $line =~ m{([,; \t|])};
my @columns my @columns
= split /[, \t][ ]*/, $line, = split /[$sep][ ]*/, $line,
defined($ACCOUNT) ? 4 : 5; defined($ACCOUNT) ? 4 : 5;
splice @columns, 1, 0, $ACCOUNT // (); splice @columns, 1, 0, $ACCOUNT // ();
eval { cond_txn_each { _inner_charge(@columns) } } // do { # 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 ( $@ ) { if ( $@ ) {
die $@ if $abort_on_exception; die $@ if $abort_on_exception;
warn $@; 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
);
} }
} }
@ -213,26 +237,69 @@ sub _inner_charge {
chomp $credit if !defined $purpose; chomp $credit if !defined $purpose;
{ # Append any consecutive lines { # In order to slurp any consecutive lines take two cases into account:
my ($has_more, $line); # 1) Purpose has not begun next from value on initial line ->
for ( $purpose //= do { $has_more = 1; <ARGV> } ) { # Grab every line before the next empty one (must have no length).
(s/^"// .. s/(?<!")(")(?=\s|$)//) || $has_more or last; # Consider any quotes to be literal.
last if $1; # 2) Grab everything until closing quote is recognized.
$line = <ARGV> or last; # This is the case when the quote is the same as the opening one,
last if $line eq $/; # 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{^\s+}{};
$_ .= $line; $line =~ s{$quot{2}}{$quot}g if $quot; # merge consecutive quotes
redo; $purpose .= $line;
} }
chomp $purpose;
_strip_comment_from($purpose); _strip_comment_from($purpose);
} }
my @transfer; my ($record, @transfer, $category);
if ( $debit =~ /^\d/ ) { 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 $tgt = $credit;
my $billId = $purpose =~ s{ \A ([[:print:]]+?) : \s* }{}xms my $billId = $purpose =~ s{ \A ([[:graph:]]+?) : \s* }{}xms
? $1 ? $1
: croak qq{Missing ID in debit purpose: $purpose} : croak qq{Missing ID in debit purpose: $purpose}
; ;
@ -244,7 +311,7 @@ sub _inner_charge {
} }
if ( my ($var, $op, $assigned) if ( my ($var, $op, $assigned)
= $tgt =~ m{^([A-Za-z]\w+)([?=])(\w+)$} = $tgt =~ m{ \A ([A-Za-z]\w+) ([?=]) (\w+) \z }xms
) { ) {
if ( defined( my $c = $targets{$var} ) ) { if ( defined( my $c = $targets{$var} ) ) {
@ -263,18 +330,20 @@ sub _inner_charge {
$tgt = $targets{ $tgt } $tgt = $targets{ $tgt }
// croak "Target credit not assigned: $tgt!\n"; // croak "Target credit not assigned: $tgt!\n";
} }
else { $tgt = undef; }
$account->add_to_debits({ $record = $account->add_to_debits({
billId => $billId, billId => $billId,
date => $date, date => $date,
purpose => $purpose, purpose => $purpose,
value => integer_money_value($debit), value => integer_money_value($debit),
targetCredit => $tgt, targetCredit => $tgt,
category => $category
}); });
} }
elsif ( $credit =~ /^\d/ ) { elsif ( $credit =~ /\b\d/ ) {
my $tgt = $purpose =~ s{ \s* >> \s* (.+) \r? \n? \z }{}xms && $1; my $tgt = $purpose =~ s{ \s* >> \s* (.+) \r? \n? \z }{}xms && $1;
@ -282,7 +351,8 @@ sub _inner_charge {
date => $date, date => $date,
account => $account, account => $account,
purpose => $purpose, purpose => $purpose,
value => integer_money_value($credit) value => integer_money_value($credit),
category => $category
}); });
if ( $debit =~ /^[a-z]/i ) { $targets{ $debit } = $c->credId; } if ( $debit =~ /^[a-z]/i ) { $targets{ $debit } = $c->credId; }
@ -292,13 +362,14 @@ sub _inner_charge {
push @transfer, $c->credId => $tgt if $tgt; push @transfer, $c->credId => $tgt if $tgt;
$record = $c;
} }
else { else {
croak "Cannot be parsed: $debit $credit\n"; croak "Cannot be parsed: $debit $credit\n";
} }
$db->make_transfers(@transfer) if @transfer; return $record, @transfer ? $db->make_transfers(@transfer) : 0;
} }
@ -310,11 +381,22 @@ sub _strip_comment_from {
} }
sub integer_money_value { sub integer_money_value {
my $val = shift; my $val = shift;
die "Not a positive money value (cent): $val" if $val =~ /[^\d.]/;
if ( $val =~ s{ ( \. (\d\d)? ) \z }{}xms ) { # Strip currency signs and space.
($val *= 100) += $2 // 0; $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; return $val;
} }
@ -417,9 +499,10 @@ sub balance_status {
while ( my $r = $results->next ) { while ( my $r = $results->next ) {
my %val = $r->get_columns(); my %val = $r->get_columns();
if ($with_report) { _balance_report( $val{ID} ) } if ($with_report) { _balance_report( $val{ID} ) }
print join "\t", $with_report ? "Balance:\n$header" : $val{ID}, @val{qw{ print join "\t", $with_report ? "Balance:\n$header" : $val{ID},
available earned spent promised arrears even_until map({ sprintf '%7d', $val{$_} } qw{
}}; available earned spent promised arrears
}), $val{even_until};
print "\n"; print "\n";
} }
} }
@ -480,7 +563,22 @@ return 1 if caller;
package main; package main;
use Getopt::Long; use Getopt::Long;
use TrsrDB \$db; 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 = ( %OPTS = (
'account' => \$ACCOUNT, 'account' => \$ACCOUNT,
@ -491,7 +589,6 @@ GetOptions( \%OPTS,
'txn-mode=s', 'account|a=s', 'target|t=s', 'target-credit|tcr=i', 'source|s=s', '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' 'date|d=s', 'value|v=i', 'purpose|p=s', 'bill-id|b=s'
); );
$DB::single=1;
delete @OPTS{'account', 'target-credit', 'txn-mode'}; delete @OPTS{'account', 'target-credit', 'txn-mode'};
my %dispatcher = ( my %dispatcher = (
@ -510,6 +607,11 @@ my %dispatcher = (
Commands::make_transfers(); Commands::make_transfers();
Commands::balance_status(1); Commands::balance_status(1);
}, },
makedb => sub {
chdir($Bin);
exec q[cat schema/tables.sql schema/*/*.sql]
. q[| sqlite3 $TRSRDB_SQLITE_FILE];
},
report => sub { report => sub {
Commands::balance_status(1); Commands::balance_status(1);
}, },