79 print STDERR $message
if $pref_debug;
84 print STDERR $message
if ($pref_verbose || $pref_debug);
87 my $elapsed_offset = 0;
91 my($user,$system) = times;
92 $elapsed_offset = $user + $system;
93 print STDERR $prefix .
" ... " if $prefix;
97 print STDERR $prefix
if $prefix;
98 my($user,$system) = times;
99 print STDERR
'(elapsed time: ' . ($user + $system - $elapsed_offset) .
")\n";
102 package CBBlib::Sink;
117 my $ledger = $self->get_ledger_();
119 $self->build_ledger_();
120 print STDERR
"Building ledger\n";
122 $self->set_ledger_usage_count_($self->get_ledger_usage_count_() + 1);
123 return $self->get_ledger_();
128 my $ledger = $self->get_ledger_();
130 print STERR
"Big problem. Released ledger that didn't exist!\n";
134 my $usage_count = $self->get_ledger_usage_count_();
137 "Big problem. Released ledger that no-one could be holding!\n";
141 $self->set_ledger_usage_count_($usage_count - 1);
142 if($usage_count == 1) {
143 print STDERR
"Killing ledger\n";
144 $self->set_ledger_(undef);
150 my $db = $self->get_db();
151 my $transactions = $db->get_txns();
152 my $ledger = $self->get_ledger_();
154 $self->set_ledger_([]);
155 $ledger = $self->get_ledger_();
159 my $cleared_balance = 0;
162 foreach $txn (@$transactions) {
163 my($debit, $credit, $applicable_txn) = $txn->totals_wrt($self);
164 if($applicable_txn) {
165 $total += ($credit - $debit);
166 if($txn->cleared_wrt_p($self)) {
167 $cleared_balance += ($credit - $debit);
169 push @$ledger, [ $txn, $total ];
172 $self->set_cleared_balance_($cleared_balance);
173 $self->set_final_balance_($total);
176 sub compare_ledger_and_txn_ {
177 my($ledger, $txn) = @_;
178 return($$ledger[0]->get_date() cmp $txn->get_date());
181 sub match_ledger_and_txn_ {
182 my($ledger, $txn) = @_;
183 return($$ledger[0] == $txn);
188 my $cleared_balance_diff_tmp;
190 sub handle_ledger_entry_merge_ {
191 my($ledger, $index, $new_p) = @_;
193 if($new_p || $started_mods_p) {
196 my $txn = $$ledger[$index];
197 $$ledger[$index] = [$txn, 0.0];
201 my $entry = $$ledger[$index];
202 my $txn = $$entry[0];
203 my($debit, $credit, $applicable_txn) = $txn->totals_wrt($mods_acct);
206 if($txn->cleared_wrt_p($mods_acct)) {
207 $cleared_balance_diff_tmp += ($credit - $debit);
212 my $prev_entry = $$ledger[$index - 1];
214 $prev_total = $$prev_entry[1];
216 $$entry[1] = $prev_total + ($credit - $debit);
220 my $ledger_removal_diff;
222 sub handle_ledger_entry_removal_ {
223 my($killed_p, $ledger, $index, $old_item) = @_;
225 if($killed_p || $started_mods_p) {
226 my $txn = $$ledger[$index]; $txn = $$txn[0];
228 my($debit, $credit, $applicable_txn) = $txn->totals_wrt($mods_acct);
229 $ledger_removal_diff += ($credit - $debit);
230 if($txn->cleared_wrt_p($mods_acct)) {
231 $cleared_balance_diff_tmp -= ($credit - $debit);
236 my $prev_entry = $$ledger[$index - 1];
237 if($prev_entry) { $prev_total = $$prev_entry[1]; }
238 my $entry = $$ledger[$index];
239 $$entry[1] = $prev_total - $ledger_removal_diff;
244 sub ledger_add_txns_ {
245 my($self, $txns) = @_;
247 my $ledger = $self->get_ledger_();
253 $cleared_balance_diff_tmp = 0;
256 CBBlib::debug(
"There are " . scalar(@$ledger) .
" ledger entries\n");
257 CBBlib::debug(
" adding " . scalar(@$txns) .
" ledger entries\n");
258 $$txns[0]->print(\*STDERR);
260 main::destructive_merge_mangle($ledger, $txns,
261 \&compare_ledger_and_txn_,
262 \&handle_ledger_entry_merge_);
263 $self->set_cleared_balance_($self->get_cleared_balance() +
264 $cleared_balance_diff_tmp);
265 my $final = $$ledger[$
266 $self->set_final_balance_($$final[1]);
267 return $added_indices;
270 sub ledger_modify_txns_ {
271 my($self, $txn_date_changed, $txns) = @_;
274 my $ledger = $self->get_ledger_();
280 my @txns_w_date_changes = grep {
281 $$txn_date_changed{$_};
286 if(@txns_w_date_changes) {
287 print STDERR
"Handling ledger mods for date changes\n";
291 my @candidates = @txns_w_date_changes;
292 my $candidate = shift @candidates;
297 print STDERR
"Looking for candidate $candidate\n";
298 my $initial_value = $candidate;
300 for($i=0; $candidate && $i < scalar(@$ledger); $i++) {
301 my $entry = $$ledger[$i];
302 my $txn = $$entry[0];
303 print STDERR
"[$txn] [$candidate]\n";
304 if($txn == $candidate) {
307 $move_from_txn{$txn} = $move;
308 $candidate = shift @candidates;
311 if($initial_value == $candidate) {
312 die
"Couldn't find transaction in ledger during ledger modify";
318 $self->build_ledger_();
323 @candidates = @txns_w_date_changes;
324 $candidate = shift @candidates;
326 my $initial_value = $candidate;
328 for($i=0; $candidate && $i < scalar(@$ledger); $i++) {
329 my $entry = $$ledger[$i];
330 my $txn = $$entry[0];
331 if($txn == $candidate) {
332 my $move = $move_from_txn{$txn};
333 die
"FATAL: Couldn't find move in ledger search" if ! $move;
335 $candidate = shift @candidates;
338 if($initial_value == $candidate) {
339 die
"Couldn't find transaction in ledger during ledger modify";
344 my @modified_indices = ();
345 my $current_index = 0;
348 my @mod_txns = @$txns;
349 my $next_mod_txn = shift @mod_txns;
350 my $prev_ledger_value = 0;
351 my $started_mods = 0;
352 my $cleared_balance_diff = 0;
355 foreach $entry (@$ledger) {
356 my $txn = $$entry[0];
357 if(defined($next_mod_txn) && $next_mod_txn == $txn) {
359 my $prev_value = $$entry[1];
360 my($debit, $credit, $applicable_txn) = $txn->totals_wrt($self);
361 my $new_value = $prev_ledger_value + ($credit - $debit);
362 my $local_change = $new_value - $prev_value;
363 if($txn->cleared_wrt_p($self)) {
364 $cleared_balance_diff -= ($credit - $debit);
366 $diff += $local_change;
367 $$entry[1] = $new_value;
368 $next_mod_txn = shift @mod_txns;
369 push @modified_indices, $current_index;
370 } elsif ($started_mods) {
373 $prev_ledger_value = $$entry[1];
376 $self->set_cleared_balance_($self->get_cleared_balance() +
377 $cleared_balance_diff);
379 my $final = $$ledger[$
380 $self->set_final_balance_($$final[1]);
381 return (\@modified_indices, \@moves);
384 sub ledger_remove_txns_ {
385 my($self, $txns) = @_;
389 my $ledger = $self->get_ledger_();
395 $ledger_removal_diff = 0;
396 $cleared_balance_diff_tmp = 0;
400 my $removed_indices =
401 main::destructive_remove_mangle($ledger,
403 \&match_ledger_and_txn_,
404 \&handle_ledger_entry_removal_);
407 "Finished removing ledger items (" . join(
" ", @$removed_indices) .
410 $self->set_cleared_balance_($self->get_cleared_balance() +
411 $cleared_balance_diff_tmp);
412 my $final = $$ledger[$
413 $self->set_final_balance_($$final[1]);
415 my @txns_tmp = @$txns;
417 my $txn = shift @txns_tmp;
424 package CBBlib::Acct;
430 unshift @ISA, qw(CBBlib::Sink);
434 my ($db, $name, $notes) = @_;
435 my $self = make_internals_();
439 $self->set_name_($name);
440 $self->set_notes_($notes);
446 my($self, $fh, $prefix, $id_map) = @_;
447 my $name = $self->get_name();
448 my $notes = $self->get_notes();
449 $notes =
"" if ! $notes;
450 $prefix =
"" unless $prefix;
452 print $fh $prefix . $$id_map{$self} .
"\t$name\t$notes\n";
454 print $fh $prefix .
"$self\t$name\t$notes\n";
465 unshift @ISA, qw(CBBlib::Sink);
469 my ($db, $name, $notes) = @_;
470 my $self = make_internals_();
474 $self->set_name_($name);
475 $self->set_notes_($notes);
481 my($self, $fh, $prefix, $id_map) = @_;
482 my $name = $self->get_name();
483 my $notes = $self->get_notes();
484 $notes =
"" if ! $notes;
485 $prefix =
"" unless $prefix;
487 print $fh $prefix . $$id_map{$self} .
"\t$name\t$notes\n";
489 print $fh $prefix .
"$self\t$name\t$notes\n";
500 my ($date, $source, $checkno, $desc, $status) = @_;
501 $status =
"" if !$status;
503 my $self = make_internals_();
506 $self->set_date_($date);
508 die
"CBBlib::Txn new: source must be a CBBlib::Acct."
509 unless (ref($source) eq
'CBBlib::Acct');
511 $self->set_source_($source);
513 $self->set_checkno_($checkno);
514 $self->set_desc_($desc);
515 $self->set_status_($status);
524 my $clone = $self->get_clone_();
526 $self->set_clone_($self->copy_obj_());
527 $clone = $self->get_clone_();
547 my($self, $sink) = @_;
549 if($self->get_source() == $sink) {
550 $result = $self->get_status();
552 $result = $self->get_transfer_status($sink);
554 if(!defined($result)) {
555 print STDERR
"Undefined status wrt $sink for\n";
556 $self->print(\*STDERR,
" ");
561 sub set_status_wrt_ {
562 my($self, $sink, $val) = @_;
563 if($self->get_source() == $sink) {
564 $self->set_status($val);
566 $self->set_transfer_status_($sink, $val);
574 my $copy_ref = \@copy;
575 bless $copy_ref, ref($self);
577 my $splits = $copy_ref->get_splits_();
580 my @splits_copy = @$splits;
582 $copy_ref->set_splits_(\@splits_copy);
587 sub get_transfer_status {
588 my($self, $sink) = @_;
589 my $splits = $self->get_splits_();
592 foreach $split (@$splits) {
593 if($split->get_dest() == $sink) {
603 return $result->get_status();
608 sub set_transfer_status_ {
609 my($self, $acct, $new_status) = @_;
610 my $splits = $self->get_splits_();
613 foreach $split (@$splits) {
614 my $dest = $split->get_dest();
615 if($split->get_dest() == $acct) {
616 $split->set_status($new_status);
623 return $self->get_status() eq
'x';
627 my($self, $acct) = @_;
628 return $self->get_status_wrt($acct) eq
'x';
632 my($self, $acct) = @_;
633 $self->set_status_wrt_($acct,
'x');
636 sub clear_pending_wrt_p {
637 my($self, $acct) = @_;
638 return $self->get_status_wrt($acct) eq
'*';
641 sub clear_pending_wrt {
642 my($self, $acct) = @_;
643 $self->set_status_wrt_($acct,
'*');
646 sub uncleared_wrt_p {
647 my($self, $acct) = @_;
648 return $self->get_status_wrt($acct) eq
' ';
652 my($self, $acct) = @_;
653 $self->set_status_wrt_($acct,
' ');
661 my($self, $split, $insert_position) = @_;
668 $split->set_txn_($self);
670 my $db = $self->get_db();
673 $db->begin_txn_modifications();
675 my $clone = $self->make_clone_();
676 $splits = $clone->get_splits_();
678 if($insert_position) {
679 splice @$splits, $insert_position, 0, ($split);
681 push @$splits, $split;
685 $splits = $self->get_splits_();
687 if($insert_position) {
688 splice @$splits, $insert_position, 0, ($split);
690 push @$splits, $split;
696 for($i = $insert_position; $i < scalar(@$splits); $i++) {
697 $$splits[$i]->set_pos_($i);
701 $db->record_txn_modification_($self);
702 $db->end_txn_modifications();
707 my($self, $split) = @_;
712 my $db = $self->get_db();
715 $db->begin_txn_modifications();
717 my $clone = $self->make_clone_();
718 $splits = $clone->get_splits_();
720 $splits = $self->get_splits_();
726 foreach $candidate (@$splits) {
727 if($candidate == $split) {
734 die
"Failed to find split in Txn::remove_split";
736 splice @$splits, $old_index, 0;
739 for($i = $old_index; $i < scalar(@$splits); $i++) {
740 $$splits[$i]->set_pos_($i);
744 my $txn = $split->get_txn_();
745 $split->set_txn_(undef);
746 $db->record_txn_modification_($txn);
747 $db->end_txn_modifications();
752 my($self, $sink) = @_;
756 my($total_debit, $total_credit, $applicability) = (0, 0, 0);
757 my $splits = $self->get_splits_();
760 foreach $split (@$splits) {
761 my $dest = $split->get_dest();
763 if($self->get_source() == $sink) {
764 $total_debit += $split->get_debit();
765 $total_credit += $split->get_credit();
767 } elsif($dest == $sink) {
769 $total_debit += $split->get_credit();
770 $total_credit += $split->get_debit();
774 return($total_debit, $total_credit, $applicability);
783 my $source = $self->get_source();
784 my %result = ($source => $source);
785 my $splits = $self->get_splits_();
788 my $dest = $_->get_dest();
790 die
"\nNo dest in $_\n";
792 $result{$dest} = $dest;
794 return(values(%result));
799 my($self, $fh, $prefix, $id_map) = @_;
800 $prefix =
"" if ! $prefix;
802 print $fh $prefix . $self->get_date() .
"\t";
804 print $fh $$id_map{$self->get_source()} .
"\t";
806 print $fh $self->get_source() .
"\t";
808 print $fh $self->get_checkno() .
"\t";
809 print $fh $self->get_desc() .
"\t";
810 print $fh $self->get_status() .
"\n";
811 my $splits = $self->get_splits_();
813 foreach $split (@$splits) {
814 $split->print($fh, $prefix .
' ', $id_map);
819 my($self, $fh, $prefix) = @_;
820 $prefix =
"" if ! $prefix;
822 print $fh $prefix . $self->get_date() .
":";
823 print $fh ($self->get_source())->get_name() .
":";
824 print $fh $self->get_checkno() .
":";
825 print $fh $self->get_desc() .
":";
826 print $fh $self->get_status() .
"\n";
827 my $splits = $self->get_splits_();
829 foreach $split (@$splits) {
830 $split->print_pretty($fh, $prefix .
" ");
834 package CBBlib::Split;
841 my ($dest, $notes, $debit, $credit, $status) = @_;
842 my $self = make_internals_();
845 $status =
'' if ! $status;
847 $self->set_dest_($dest);
848 $self->set_notes_($notes);
849 $self->set_debit_($debit);
850 $self->set_credit_($credit);
851 $self->set_status_($status);
860 my $copy_ref = \@copy;
861 bless $copy_ref, ref($self);
868 my $clone = $self->get_clone_();
870 my $txn = $self->get_txn_();
874 $self->set_clone_($self->copy_obj_());
875 $clone = $self->get_clone_();
882 my $txn = $self->get_txn();
884 return $txn->get_db();
892 my $status = $self->get_status();
894 return $status eq
'x';
902 my($self, $fh, $prefix, $id_map) = @_;
903 $prefix =
"" if ! $prefix;
907 print $fh $$id_map{$self->get_dest()} .
"\t";
909 print $fh $self->get_dest() .
"\t";
911 print $fh $self->get_notes() .
"\t";
912 print $fh $self->get_debit() .
"\t";
913 print $fh $self->get_credit() .
"\t";
914 print $fh $self->get_status() .
"\n";
924 my($
class, $default_sink) = @_;
925 my $self = make_internals_();
929 $self->add_sinks([$default_sink]);
931 $default_sink = new CBBlib::Cat($self,
'<<unitemized>>',
'');
932 $self->add_sinks([$default_sink]);
934 $self->set_default_sink($default_sink);
945 my($self, $sinks) = @_;
947 my $accts = $self->get_accts_();
948 my $cats = $self->get_cats_();
951 if(ref($_) eq
'CBBlib::Acct') {
953 } elsif(ref($_) eq
'CBBlib::Cat') {
956 die
"Unknown sink type in CBBlib::Db::add_sinks()";
961 sub record_txn_modification_ {
962 my($self, $txn) = @_;
964 my $mod_level = $self->get_modified_txns_level_();
966 die
"Tried to record_txn_modification_ when not in update region.";
968 my $modified_txns = $self->get_modified_txns_();
972 if(ref($txn) eq
'CBBlib::Split') {
973 $txn = $txn->get_txn_();
975 $$modified_txns{$txn} = $txn;
978 sub update_dirty_txns_hash_ {
979 my($self, $dirty_hash, $txn) = @_;
981 my @affected_sinks = $txn->affected_sinks();
985 if(!$$dirty_hash{$sink}) {
986 $$dirty_hash{$sink} = [$sink, [$txn]];
988 my $list = $$dirty_hash{$sink};
996 sub debug_txns_modified_data {
997 my($self, $modifications, $dirty_sinks) = @_;
998 CBBlib::debug(
"CBBlib CALLBACK: txns-modified\n");
1000 CBBlib::debug(
" Modifications:\n");
1004 CBBlib::debug(
" [$txn");
1006 CBBlib::debug(
"\n [");
1015 print "<<undefined>>";
1022 CBBlib::debug(
"]\n");
1025 CBBlib::debug(
" Affected sinks:\n");
1027 my ($sink, $mod_txns, $indices) = @$_;
1028 $sink->print(\*STDERR,
" ");
1029 } values(%$dirty_sinks);
1033 sub post_modification_notices_ {
1035 CBBlib::debug(
"CBBlib::post_modification_notices_: checking for changes.\n");
1037 my $modified_txns_hash = $self->get_modified_txns_();
1038 my @sorted_txns = sort {
1039 $a->get_date <=> $b->get_date();
1040 } values(%$modified_txns_hash);
1041 my @modifications = ();
1052 my %txn_date_changed;
1056 foreach $txn (@sorted_txns) {
1057 my $new_txn = $txn->get_clone_();
1058 my $old_splits = $txn->get_splits_();
1059 my $new_splits = $new_txn->get_splits_();
1063 for($i=0; $i < scalar(@$old_splits); $i++) {
1064 my $old_item = $$old_splits[$i];
1065 if(! grep { $_ == $old_item } @$new_splits) {
1067 push @txn_mods, [
'split-removed', $old_item, $old_index];
1071 for($i=0; $i < scalar(@$new_splits); $i++) {
1072 my $new_item = $$new_splits[$i];
1073 if(! grep { $_ == $new_item } @$old_splits) {
1075 push @txn_mods, [
'split-added', $new_item, $new_index];
1080 my @modified_splits = grep { $_->get_clone_() } @$new_splits;
1082 if($new_txn->get_date_ ne $txn->get_date_()) {
1083 push @txn_mods, [
'date', $txn->get_date_()];
1084 $txn->set_date_($new_txn->get_date_());
1086 $txn_date_changed{$txn} = $txn;
1088 if($new_txn->get_checkno_ ne $txn->get_checkno_()) {
1089 push @txn_mods, [
'checkno', $txn->get_checkno_()];
1090 $txn->set_checkno_($new_txn->get_checkno_());
1092 if($new_txn->get_desc_ ne $txn->get_desc_()) {
1093 push @txn_mods, [
'desc', $txn->get_desc_()];
1094 $txn->set_desc_($new_txn->get_desc_());
1096 if($new_txn->get_status_ ne $txn->get_status_()) {
1097 push @txn_mods, [
'status', $txn->get_status_()];
1098 $txn->set_status_($new_txn->get_status_());
1102 foreach $split (@modified_splits) {
1103 my $new_split = $split->get_clone_();
1105 my $old_txn = $split->get_txn();
1106 if(defined($old_txn) && ($old_txn == $new_split->get_txn())) {
1110 my $old_pos = $split->get_pos__();
1111 my $new_pos = $new_split->get_pos__();
1112 if((defined($new_pos) != defined($old_pos)) ||
1113 ($new_pos != $old_pos)) {
1114 push @txn_mods, [
'split-modified', $split,
'pos',
1115 $split->get_pos__()];
1116 $split->set_pos__($new_split->get_pos__());
1118 if($new_split->get_dest_ != $split->get_dest_()) {
1119 push @txn_mods, [
'split-modified', $split,
'dest',
1120 $split->get_dest_()];
1121 $split->set_dest_($new_split->get_dest_());
1123 if($new_split->get_notes_ ne $split->get_notes_()) {
1124 push @txn_mods, [
'split-modified', $split,
'notes',
1125 $split->get_notes_()];
1126 $split->set_notes_($new_split->get_notes_());
1128 if($new_split->get_debit_ != $split->get_debit_()) {
1129 push @txn_mods, [
'split-modified', $split,
'debit',
1130 $split->get_debit_()];
1131 $split->set_debit_($new_split->get_debit_());
1133 if($new_split->get_credit_ != $split->get_credit_()) {
1134 push @txn_mods, [
'split-modified', $split,
'credit',
1135 $split->get_credit_()];
1136 $split->set_credit_($new_split->get_credit_());
1138 if($new_split->get_status_ ne $split->get_status_()) {
1139 push @txn_mods, [
'split-modified', $split,
'status',
1140 $split->get_status_()];
1141 $split->set_status_($new_split->get_status_());
1144 $split->set_clone_(undef);
1146 $txn->set_splits_($new_splits);
1147 $txn->set_clone_(undef);
1150 $self->update_dirty_txns_hash_(\%dirty_sinks, $txn);
1151 push @modifications, [ $txn, \@txn_mods ];
1158 print STDERR
"Re-sorting txns\n";
1159 my $txns = $self->get_txns();
1161 $a->get_date <=> $b->get_date();
1167 foreach $acct_data (values %dirty_sinks) {
1168 my $acct = $$acct_data[0];
1169 my $acct_txns = $$acct_data[1];
1170 my ($txn_indices, $moves) =
1171 $acct->ledger_modify_txns_(\%txn_date_changed,
1173 push @$acct_data, $txn_indices, $moves;
1176 if(@modifications) {
1178 debug_txns_modified_data($self, \@modifications, \%dirty_sinks);
1181 my $callbacks_hash = $self->get_callbacks_hash_();
1182 my $callbacks = $$callbacks_hash{
'txns-modified'};
1184 foreach $callback (@$callbacks) {
1185 my $func = $$callback[0];
1186 my $args = $$callback[1];
1197 &$func($self, \@modifications, \%dirty_sinks, $args);
1204 sub begin_txn_modifications {
1206 my $mod_level = $self->get_modified_txns_level_();
1208 $self->set_modified_txns_({});
1211 $self->set_modified_txns_level_($mod_level + 1);
1214 sub end_txn_modifications {
1216 my $mod_level = $self->get_modified_txns_level_();
1217 if($mod_level == 1) {
1218 $self->post_modification_notices_();
1219 } elsif(!$mod_level) {
1221 "Big problem. Db::end_txn_modifications called when not modifying.\n";
1223 $self->set_modified_txns_level_($mod_level - 1);
1226 sub get_accts_by_name {
1227 my($self, $name) = @_;
1228 my $accts = $self->get_accts();
1229 my @matches = grep {
1231 $_->get_name() eq $name;
1239 sub get_cats_by_name {
1240 my($self, $name) = @_;
1241 my $cats = $self->get_cats();
1242 my @matches = grep {
1244 $_->get_name() eq $name;
1252 sub extract_accounts_ {
1253 my($text, $hash) = @_;
1254 my @accounts = split(
"\n", $text);
1257 my @fields = split(
"\t", $acct);
1258 (scalar(@fields) < 4)
or die
"Wrong number of fields in account.";
1260 my $name = $fields[1];
1261 my $notes = $fields[2];
1262 $acct = new CBBlib::Acct(undef, $name, $notes);
1263 $$hash{$fields[0]} = $acct;
1268 sub extract_categories_ {
1269 my($text, $hash) = @_;
1270 my @categories = split(
"\n", $text);
1273 my @fields = split(
"\t", $cat);
1274 (scalar(@fields) < 4)
or die
"Wrong number of fields in category.";
1276 my $name = $fields[1];
1277 my $notes = $fields[2];
1278 $cat = new CBBlib::Cat(undef, $name, $notes);
1279 $$hash{$fields[0]} = $cat;
1284 sub calc_account_totals_only_ {
1286 my $transactions = $self->get_txns();
1287 my $accts = $self->get_accts();
1290 $_->set_cleared_balance_(0);
1291 $_->set_final_balance_(0);
1299 foreach $txn (@$transactions) {
1300 my $splits = $txn->get_splits_();
1303 foreach $split (@$splits) {
1305 my $source = $txn->get_source();
1306 my $dest = $split->get_dest();
1307 my $debit = $split->get_debit();
1308 my $credit = $split->get_credit();
1312 my $diff = $credit - $debit;
1314 if($txn->cleared_p_()) {
1315 $cleared_bal = $source->get_cleared_balance() + $diff;
1316 $source->set_cleared_balance_($cleared_bal);
1318 $final_bal = $source->get_final_balance() + $diff;
1319 $source->set_final_balance_($final_bal);
1321 if(ref($dest) eq
'CBBlib::Acct' && ($source != $dest)) {
1322 if($split->cleared_p_()) {
1323 $cleared_bal = $dest->get_cleared_balance();
1324 $dest->set_cleared_balance_($cleared_bal - $diff);
1326 $final_bal = $dest->get_final_balance() - $diff;
1327 $dest->set_final_balance_($final_bal);
1335 my($self, $name, $callback, $user_data) = @_;
1336 my $data = [$callback, $user_data];
1337 my $callbacks_hash = $self->get_callbacks_hash_();
1338 my $txn_callbacks = $$callbacks_hash{$name};
1339 if(!$txn_callbacks) {
1340 $$callbacks_hash{$name} = [];
1341 $txn_callbacks = $$callbacks_hash{$name};
1343 push @$txn_callbacks, $data;
1347 sub remove_callback_ {
1348 my($self, $name, $callback_id) = @_;
1349 my $callbacks_hash = $self->get_callbacks_hash_();
1350 my $callbacks = $$callbacks_hash{$name};
1351 if(scalar(@$callbacks)) {
1352 @$callbacks = grep { !($_ == $callback_id) } @$callbacks;
1360 sub add_txns_added_callback {
1361 my($self, $callback, $user_data) = @_;
1362 return $self->add_callback_(
'txns-added', $callback, $user_data);
1366 sub remove_txns_added_callback {
1367 my($self, $callback_id) = @_;
1368 $self->remove_callback_(
'txns-added', $callback_id);
1376 sub add_txns_removed_callback {
1377 my($self, $callback, $user_data) = @_;
1378 return $self->add_callback_(
'txns-removed', $callback, $user_data);
1382 sub remove_txns_removed_callback {
1383 my($self, $callback_id) = @_;
1384 $self->remove_callback_(
'txns-removed', $callback_id);
1387 sub add_txns_modified_callback {
1388 my($self, $callback, $user_data) = @_;
1389 return $self->add_callback_(
'txns-modified', $callback, $user_data);
1392 sub remove_txns_modified_callback {
1393 my($self, $callback_id) = @_;
1394 $self->remove_callback_(
'txns-modified', $callback_id);
1397 sub merge_new_txns_into_main_list_ {
1398 my($self, $new_txns) = @_;
1399 my $txns = $self->get_txns();
1402 main::destructive_merge_mangle($txns, $new_txns, sub {
1403 return $_[0]->get_date() cmp $_[1]->get_date();
1406 map { $_->set_db_($self); } @$new_txns;
1410 foreach $txn (@$new_txns) {
1411 my @accts = $txn->affected_sinks();
1413 foreach $acct (@accts) {
1414 my $data = $affected_sinks{$acct};
1415 if(!$data) { $data = $affected_sinks{$acct} = [$acct, []]; }
1416 my $list = $$data[1];
1421 return (\%affected_sinks, $added_indices);
1424 sub merge_new_txns_into_ledger_lists_ {
1425 my($self, $new_txns, $affected_accts) = @_;
1436 foreach $data (values(%$affected_accts)) {
1437 my $acct_ref = $$data[0];
1438 my $txns = $$data[1];
1439 my $added_indices = $acct_ref->ledger_add_txns_($txns);
1440 push @$data, $added_indices;
1445 my($self, $new_txns) = @_;
1448 $a->get_date() <=> $b->get_date();
1451 my ($affected_accts, $added_indices) =
1452 $self->merge_new_txns_into_main_list_($new_txns);
1454 $self->merge_new_txns_into_ledger_lists_($new_txns, $affected_accts);
1456 my $callbacks_hash = $self->get_callbacks_hash_();
1457 my $txn_callbacks = $$callbacks_hash{
'txns-added'};
1459 foreach $callback (@$txn_callbacks) {
1460 my $func = $$callback[0];
1461 my $args = $$callback[1];
1463 if($main::pref_debug) {
1467 ' added-indices: (' . join(
"\n" .
1468 ' ', @$added_indices) .
")\n" .
1469 " (affected-accts\n";
1471 foreach $acct_data (values(%$affected_accts)) {
1472 my $acct = $$acct_data[0];
1473 my $txns = $$acct_data[1];
1474 my $indices = $$acct_data[2];
1477 ' txns: (' . join(
"\n" .
1478 ' ', @$txns) .
")\n" .
1479 ' indices: (' . join(
"\n" .
1480 ' ', @$indices) .
")\n";
1482 CBBlib::debug(
' args: ' . $args .
"))\n");
1484 &$func($self, $added_indices, $affected_accts, $args);
1488 sub remove_txns_from_ledger_lists_ {
1489 my($self, $dead_txns, $affected_accts) = @_;
1500 foreach $acct (keys(%$affected_accts)) {
1501 my $data = $$affected_accts{$acct};
1502 my $acct_ref = $$data[0];
1503 my $txns = $$data[1];
1504 my $removal_info = $acct_ref->ledger_remove_txns_($txns);
1505 $result{$acct} = [$acct, $removal_info];
1510 sub remove_txns_from_main_list_ {
1511 my($self, $dead_txns) = @_;
1512 my $txns = $self->get_txns();
1514 my $removed_indices =
1515 main::destructive_remove_mangle($txns, $dead_txns, sub {
1516 return $_[0] == $_[1];
1519 map { $_->set_db_($self); } @$dead_txns;
1523 foreach $txn (@$dead_txns) {
1524 my @accts = $txn->affected_sinks();
1526 foreach $acct (@accts) {
1527 my $data = $affected_accts{$acct};
1528 if(!$data) { $data = $affected_accts{$acct} = [$acct, []]; }
1529 my $list = $$data[1];
1534 return (\%affected_accts, $removed_indices);
1538 my($self, $dead_txns) = @_;
1540 @$dead_txns = sort {
1541 $a->get_date() cmp $b->get_date();
1544 my ($affected_accts, $removed_db_indices) =
1545 $self->remove_txns_from_main_list_($dead_txns);
1547 my $ledger_removal_info =
1548 $self->remove_txns_from_ledger_lists_($dead_txns, $affected_accts);
1550 my $callbacks_hash = $self->get_callbacks_hash_();
1551 my $txn_callbacks = $$callbacks_hash{
'txns-removed'};
1553 foreach $callback (@$txn_callbacks) {
1554 my $func = $$callback[0];
1555 my $args = $$callback[1];
1556 &$func($self, $dead_txns,
1557 $removed_db_indices,
1558 $ledger_removal_info,
1564 my ($self, $fh, $id_map) = @_;
1566 print $fh
"#### Accounts ####\n";
1567 my $accts = $self->get_accts();
1568 map { $_->print($fh,
'', $id_map); } @$accts;
1572 print $fh
"#### Categories ####\n";
1573 my $cats = $self->get_cats();
1574 map { $_->print($fh,
'', $id_map); } @$cats;
1580 my ($self, $fh, $id_map) = @_;
1581 print $fh
"#### Transactions ####\n\n";
1582 my $txns = $self->get_txns();
1584 foreach $txn (@$txns) {
1585 $txn->print($fh,
'',$id_map);
1591 my($self, $fh) = @_;
1595 my $accts = $self->get_accts();
1597 $id_map{$_} =
"a$i";
1601 my $cats = $self->get_cats();
1603 $id_map{$_} =
"c$i";
1607 print $fh
"# CBB data file\n";
1608 print $fh
"Version: 1.0\n";
1609 print $fh
'Default-sink: ' . $id_map{$self->get_default_sink()} .
"\n";
1612 $self->print_sinks($fh, \%id_map);
1613 $self->print_txns($fh, \%id_map);
1618 sub key_colon_value_to_hash {
1622 my @lines = split(
"\n", $text);
1626 if($_ =~ m/\s*([^:]+):\s*(.*)$/o) {
1629 die
'Bad line in database file, first "key: value" section.';
1638 elapsed_reset(
"Starting load");
1642 my @transactions = ();
1643 my $fh = new IO::File;
1646 $fh->open($name)
or die
"Can't open input data file $file.";
1647 $fh->input_record_separator(
'');
1652 $text =~ s/^\n//mgo;
1653 my $file_data = key_colon_value_to_hash($text);
1655 die
"Couldn't determine data file version"
1656 unless $$file_data{
'Version'};
1657 die
"Couldn't find default sink in $text."
1658 unless $$file_data{
'Default-sink'};
1665 my @sinks = CBBlib::Db::extract_accounts_($text, \%sink_map);
1670 push @sinks, CBBlib::Db::extract_categories_($text, \%sink_map);
1672 my $default_sink = $sink_map{$$file_data{
'Default-sink'}};
1673 die
"Default sink " . $$file_data{
'Default-sink'} .
1674 " not in database file." unless $default_sink;
1676 my $self = new CBBlib::Db($default_sink);
1678 $self->add_sinks(\@sinks);
1688 print "\rLoading record $count";
1691 my @lines = split(
'\n', $_);
1692 my $transaction_info = shift @lines;
1693 my($date, $source, $checknum, $description, $status) =
1694 split(
"\t", $transaction_info);
1695 $source = $sink_map{$source};
1697 if(!defined($status) || $status eq
'') { $status =
' '; }
1700 new CBBlib::Txn($date, $source, $checknum, $description, $status);
1704 foreach $split_line (@lines) {
1705 $split_line =~ s/^\s*//o;
1706 my($destination, $note, $debit, $credit, $status) =
1707 split(
"\t", $split_line);
1709 my $old_dest = $destination;
1710 $destination = $sink_map{$destination};
1712 die
"No destination for key [$old_dest]\n";
1715 $destination = $self->get_default_sink();
1718 $transaction->add_split(new CBBlib::
Split($destination, $note,
1719 $debit, $credit, $status));
1721 push @new_txns, $transaction;
1725 elapsed_reset(
" Now adding transactions");
1726 $self->add_txns(\@new_txns);
1728 elapsed_reset(
" Calculating totals");
1729 $self->calc_account_totals_only_();
1731 $fh->close()
or die
"Can't open close file $name.";
1732 print STDERR
"finished load\n";