use strict; package TrsrDB; use base qw/DBIx::Class::Schema/; use Carp qw/croak/; __PACKAGE__->load_classes(qw| Account Debit Credit Transfer CurrentArrears AvailableCredits Balance Report ReconstructedBankStatement History User |); sub import { my ($class, $dbh_ref, $filename) = @_; return if @_ == 1; croak "use TrsrDB \$your_db_handle missing" if !defined $dbh_ref; $$dbh_ref = $class->connect( "DBI:SQLite:" . ($filename // $ENV{TRSRDB_SQLITE_FILE} // ":memory:"), "", "", { sqlite_unicode => 1, on_connect_call => 'use_foreign_keys', on_connect_do => 'PRAGMA recursive_triggers = 1', } ); } sub make_transfers { my ($self, @pairs) = @_; my $from_to = [ undef, AvailableCredits => 'credId', suggested_to_pay => 'billId', undef ]; my $to_from = [ undef, CurrentArrears => 'billId', payable_with => 'credId', undef ]; my $transfers = $self->resultset('Transfer'); my @dir = ($from_to, $to_from); my ($rs, $transferred_total, $src_total, $tgt_total); while ( my ($src, $tgt) = splice @pairs, 0, 2 ) { $rs = $self->resultset("AvailableCredits")->search( expand_ids($src => 'credId' ) ); $src = [ $rs->get_column('credId')->all ]; $src_total += $rs->get_column('difference')->sum; $rs = $self->resultset("CurrentArrears")->search( expand_ids( $tgt => 'billId' ) ); $tgt = [ $rs->get_column('billId')->all ]; $tgt_total += $rs->get_column('difference')->sum; @{$to_from}[5,0] = @{$from_to}[0,5] = ($src, $tgt); my $i = 0; while ( @$src && @$tgt ) { my ($item, $thistable, $thisidname, $m2mrel, $otheridname, $otherids) = @{ $dir[ $i ] } ; 1 until $item = $self->resultset($thistable)->find( shift(@$item) // last ); my $diff = $item->difference; my @otherids = $item->$m2mrel({ $otheridname => { -in => $otherids } })->get_column($otheridname)->all ; my $transfer; while ( $diff > 0 ) { $transfer = $transfers->create({ $thisidname => $item->id, $otheridname => shift(@otherids) // last }); $transfer->discard_changes; # sorry, DBIx::Class devs, what a bad name! # how about 'refresh_from_storage' for ( $transfer->amount ) { $diff -= $_; $transferred_total += $_; } } redo if !$diff; } continue { $i = !$i || 0; } } return $src_total, $tgt_total, $transferred_total // 0; } sub expand_ids { my ($ids, $default_slot) = @_; my @ids = map { m{ \A (\d+) - (\d+) \z }xms ? [ $1 .. $2 ] : $_ } ref $ids ? @$ids : split q{,}, $ids ; my (@alternatives, %raws); for my $id ( @ids ) { my $slot = ref $id ? $default_slot : $id =~ s{^p(urpose)?:}{}i ? "purpose" : $id =~ s{^d(ate)?:}{}i ? "date" : $id =~ s{^v(alue)?:}{}i ? "value" : $default_slot ; if ( ref $id eq 'ARRAY' ) { $raws{$slot}{'-in'}, @$ids; } elsif ( $id eq '*' ) { @alternatives = ( $slot => { -not_in => [] }); } elsif ( $id =~ s{([%*_?])}{ $1 eq '*' ? '%' : $1 eq '?' ? '_' : $1 }eg ) { push @alternatives, { $slot => { -like => $id } }; } else { push @{ $raws{$slot}{'-like'} }, $id } } while ( my @v = each %raws ) { push @alternatives, { @v } } return \@alternatives; } sub user { shift->resultset("User")->find(shift); } 1;