From 6391b0498cae09d0248f31b1bbfd73fcfa48ef47 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Florian=20=22flowdy=22=20He=C3=9F?= Date: Sun, 5 Mar 2017 14:09:58 +0100 Subject: [PATCH] Various fixes and UX optimizations in trsr --- TrsrDB/Category.pm | 2 +- trsr | 192 ++++++++++++++++++++++++++++++++++----------- 2 files changed, 148 insertions(+), 46 deletions(-) diff --git a/TrsrDB/Category.pm b/TrsrDB/Category.pm index 11e6bd2..bd0020e 100644 --- a/TrsrDB/Category.pm +++ b/TrsrDB/Category.pm @@ -3,7 +3,7 @@ use strict; package TrsrDB::Category; use base qw/DBIx::Class::Core/; -__PACKAGE__->table('category'); +__PACKAGE__->table('Category'); __PACKAGE__->add_columns(qw/ID label/); __PACKAGE__->set_primary_key('ID'); diff --git a/trsr b/trsr index f1c14fb..d7e00b7 100755 --- a/trsr +++ b/trsr @@ -1,5 +1,6 @@ #!/usr/bin/env perl use strict; +use utf8; my ($db, %OPTS, $ACCOUNT, %targets); @@ -52,7 +53,7 @@ sub single_charge { # charge interactively my $what = $billId ? 'add_to_debits' : 'add_to_credits'; return $account->$what({ $billId ? ( - billId => $billId, + billId => sprintf($billId, $account->ID), targetCredit => delete( $OPTS{target} ), ) : (), map { $_ => $OPTS{$_} } qw(value purpose date), @@ -61,19 +62,27 @@ sub single_charge { # charge interactively if ( $ACCOUNT ) { my $account = $accounts->find({ ID => $ACCOUNT }); + my ($record, $transf_count); cond_txn_each { - my $record = $charger->($account, $billId); + $record = $charger->($account, $billId); 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 ) { - $accounts = $accounts->search({ type => $1 }); + 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, sprintf $billId ); } + cond_txn_each { $charger->( $account, $billId ); } } }; } @@ -86,7 +95,7 @@ sub single_charge { # charge interactively sub _require_value { 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} = ); } $_ = integer_money_value($_) for $OPTS{value}; @@ -153,7 +162,7 @@ sub _require_target { chomp( my $t = ); } 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; - exists $_[0] - and local *ARGV = ( - openhandle($_[0]) - // croak "charge_account() expects open file handle to read from" - ) - and my $abort_on_exception = 1 - ; + local *ARGV = ( + openhandle($_[0]) + // croak "charge_account() expects open file handle to read from" + ) if my $abort_on_exception = exists $_[0]; # Possible line formats: # ------------------------------------------------------- @@ -188,18 +194,36 @@ sub charge_account { _strip_comment_from($line) // next; + my ($sep) = $line =~ m{([,; \t|])}; + my @columns - = split /[, \t][ ]*/, $line, + = split /[$sep][ ]*/, $line, defined($ACCOUNT) ? 4 : 5; 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 ( $@ ) { 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 + ); } } @@ -213,26 +237,69 @@ sub _inner_charge { 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; + { # 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 (? ["'] ) }{}xms + && $purpose =~ m{ : \s* \z }xms; } + else { + $has_more = 1; + ($purpose = ) =~ 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 + (?) # 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 @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 $billId = $purpose =~ s{ \A ([[:print:]]+?) : \s* }{}xms + my $billId = $purpose =~ s{ \A ([[:graph:]]+?) : \s* }{}xms ? $1 : croak qq{Missing ID in debit purpose: $purpose} ; @@ -244,7 +311,7 @@ sub _inner_charge { } 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} ) ) { @@ -263,18 +330,20 @@ sub _inner_charge { $tgt = $targets{ $tgt } // croak "Target credit not assigned: $tgt!\n"; } + else { $tgt = undef; } - $account->add_to_debits({ + $record = $account->add_to_debits({ billId => $billId, date => $date, purpose => $purpose, value => integer_money_value($debit), targetCredit => $tgt, + category => $category }); } - elsif ( $credit =~ /^\d/ ) { + elsif ( $credit =~ /\b\d/ ) { my $tgt = $purpose =~ s{ \s* >> \s* (.+) \r? \n? \z }{}xms && $1; @@ -282,7 +351,8 @@ sub _inner_charge { date => $date, account => $account, purpose => $purpose, - value => integer_money_value($credit) + value => integer_money_value($credit), + category => $category }); if ( $debit =~ /^[a-z]/i ) { $targets{ $debit } = $c->credId; } @@ -292,13 +362,14 @@ sub _inner_charge { push @transfer, $c->credId => $tgt if $tgt; + $record = $c; } else { 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 { + my $val = shift; - die "Not a positive money value (cent): $val" if $val =~ /[^\d.]/; - if ( $val =~ s{ ( \. (\d\d)? ) \z }{}xms ) { - ($val *= 100) += $2 // 0; - } + + # 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; } @@ -417,9 +499,10 @@ sub balance_status { 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 join "\t", $with_report ? "Balance:\n$header" : $val{ID}, + map({ sprintf '%7d', $val{$_} } qw{ + available earned spent promised arrears + }), $val{even_until}; print "\n"; } } @@ -480,7 +563,22 @@ return 1 if caller; package main; 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 = ( 'account' => \$ACCOUNT, @@ -491,7 +589,6 @@ 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 = ( @@ -510,6 +607,11 @@ my %dispatcher = ( 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); },