#!/usr/bin/perl -w
########################################################################
#
# TITLE:
#	planb
#
# AUTHOR:
#	Scott Maxwell
#
# DESCRIPTION:
#	PlanB, the budget planner for Linux.
#
# TO DO:
#
#	1. Column widths -- particularly for the category column --
#	should arguably be computed from the input file, probably with
#	some minimum.  At least it should be possible to explicitly
#	set them in the input file.
#
#	2. Rows aren't deleted properly (the fault of the Tk::Table
#	widget?).
#
#	3. PlanB should understand when you make extra payments to
#	cards -- it should apply the payment toward that card's
#	balance.
#
#	4. Should understand multiple accounts, and maybe also compute
#	interest on interest-bearing checking accounts and such.
#
#	5. Too slow!  Unfortunately, most of the time appears to go
#	into unavoidable (?) X and/or Tk overhead.  (On my system,
#	starting up with 1000 rows takes about 1 minute with the
#	financial computations turned off; it takes about 1:05 with
#	them turned on.  They're clearly not the time sink.)  Being
#	aggressive about computing in the background could help this a
#	lot.
#
#	6. Print-preview a large table and exit GhostView without
#	looking at all the pages.  You'll get a SIGPIPE and planb will
#	exit.  Fix.
#
#				CHANGE HISTORY
#
# $Log: planb,v $
# Revision 1.1  2005/08/27 00:32:55  maxwell
# Initial revision
#
########################################################################

require 5.004;
use strict;
no strict qw(refs);

$[ = 0;				# Set array base to 0.
$\ = "\n";			# Set output record separator.
select(STDERR); $| = 1;		# Flush output buffer (STDERR).
select(STDOUT); $| = 1;		# Flush output buffer (STDOUT).

use Tk;
use Tk::Table;
use Time::Local;
require "$ENV{HOME}/pm/MaxUtil.pm";




################
#
# "Constants."
#
################

my $COL_DATE    = 0;		# Record's date.
my $COL_EXPENSE = 1;		# Expense category.
my $COL_CHANGE  = 2;		# Amount of change to main balance.
my $COL_ITSBAL  = 3;		# Balance remaining in this category.
my $COL_NEWBAL  = 4;		# New balance in main account.
my $COL_MAXCOL  = 4;		# Not a column -- the max column value.
my $COL_NCOLS   = $COL_MAXCOL + 1; # Not a column -- the # of columns.

my @COLS = (0 .. $COL_MAXCOL);	# All valid column indices.

my $NROWS = 250;		# Number of rows in the sheet, initially.
				# Will eventually have to become a variable.

my $DATE_FMT = 'yyyy/mm/dd';	# What dates look like.
my $DATE_WIDTH = length($DATE_FMT);
my $COL_WIDTH  = 16;		# Width of columns other than the date column.

my %HEAD = (			# Heading for each column.
	    $COL_DATE    => 'Date',
	    $COL_EXPENSE => 'Expense',
	    $COL_CHANGE  => 'Change',
	    $COL_ITSBAL  => 'Its Balance',
	    $COL_NEWBAL  => 'New Balance',
	   );

my %BTN3 = (			# Callback for button 3 press over each column.
	    $COL_DATE    => \&PmDate,
	    $COL_EXPENSE => \&PmExpense,
	    $COL_CHANGE  => \&PmChange,
	    $COL_ITSBAL  => \&PmItsBal,
	    $COL_NEWBAL  => \&PmNewBal,
	   );

my $TOP = new MainWindow();	# Main window (well, duh).

my $STATUS = $TOP->Label(	# Status widget.
			 -text   => 'Initializing ...', # This value is not seen.
			 -anchor => 'n',
			 -relief => 'groove',
			 -width  => 10,
			 -height =>  1,
			);

my $TBL = $TOP->Table(	# The table displaying the budget info.
		      -rows         => 25, # Initially.
		      -columns      => $COL_NCOLS,
		      -scrollbars   => 'e',
		      -takefocus    => 1,
#		      -anchor       => 'n',
		      -fixedrows    => 1,
		     );

# This is not a constant but may be changed by &InitBudget(), so it
# must precede the initialization of $BUDGET.
my $BaseTitle = 'PlanB: Our Budget'; # Title bar contents.

my $BUDGET = &InitBudget();	# A stream that returns entries for the table.

my $BAL_DANGER  = 0;		# If balance is <= this, DANGER, Will Robinson!
my $BAL_WARNING = 1000;		# If balance is <= this, watch it, getting low.
my $BAL_NORMAL  = -1;		# Must != the other 2 but otherwise unimportant.

my %BAL_LVL = (			# Color or text to indicate balance level.
	       $BAL_DANGER  => [ 'Red',    '****' ],
	       $BAL_WARNING => [ 'Yellow', '*' ],
	       $BAL_NORMAL  => [ 'Green',  ''  ],
	      );




################
#
# Globals.
#
################

# None!  (Except $BaseTitle, defined above.)




################
#
# Initialize table.
#
################

foreach (keys %HEAD) {
    $TBL->put(0, $_, $HEAD{$_});
}

if (int(@ARGV)) {
    &AppendRow($ARGV[0], 'Initializing ...');

} else {
    foreach my $row (1 .. $NROWS) {
	&AppendRow();
    }
}




################
#
# Place the widgets, do packing and final initialization, and enter
# main loop.
#
################

$TBL->pack(
	   -expand => 1,
	   -fill   => 'both',
	  )
  ->focus();

# A row of widgets (the "extend forecast" stuff).
my $f = $TOP->Frame()->pack(-side => 'top',
			    -fill => 'x');
$f->Label(-text => "Extend Forecast To This Date ($DATE_FMT):")
  ->pack(-side => 'left');
my $until = $f->Entry()->pack(-side   => 'left',
			      -fill   => 'x',
			      -expand => 'x');
$until->bind('<Return>' =>	# What to do when user chooses a forecast date.
	     sub {
		 my $w = shift(@_);
		 my ($whine, $date) = &DateComplaint($w->get());
		 if (defined($whine)) {
		     &SetStatus($whine);
		     $w->focus();

		 } else {
		     my $s = 'Extending Forecast ...';
		     &SetStatus($s, 1);
		     &AppendRow($date, $s);
		     &SetStatus();
		 }
	     });

# Another row (the control buttons).
$f = $TOP->Frame()->pack(-side => 'top',
			 -fill => 'x');
foreach my $lbl ('Quit', 'Save', 'Print', 'Print Preview', 'Reload', 'Undo',
		 'Low Point') {
    my $noSpaces = $lbl;
    $noSpaces =~ s/ //g;

    $f->Button(
	       -text    => $lbl,
	       -command => eval "\\&Btn$noSpaces",
	      )->pack(-side   => 'left',
		      -fill   => 'x',
		      -expand => 'x');
}
$STATUS->pack(-fill => 'x');

&SetStatus('Initializing ...', 1);

$SIG{__WARN__} = sub {		# Hide bogus Tk-related warnings.
    my $msg = shift(@_);

    unless ($msg =~
	    /^Use of inherited AUTOLOAD for non-method Tk::.* is deprecated/) {
	chomp($msg);
	print STDERR $msg;
    }
};

&SetStatus();
&MainLoop();
exit(0);




################################################################
#
# Add a new, blank row at the supplied row index, moving other rows
# down if necessary.
#
################################################################

sub AddRowAt {
    my $row = shift(@_);

    my $was = &TblGetVal($row, $COL_DATE);
    my $n = $TBL->totalRows();

    &TblPutRow($n,		# Create a row number $n.
	       {
		$COL_DATE    => &RefTo(0),
		$COL_EXPENSE => &RefTo(0),
		$COL_CHANGE  => &RefTo(0),
		$COL_ITSBAL  => &RefTo(0),
		$COL_NEWBAL  => &RefTo(0),
	       });
    for ( ; $n > $row; --$n) {	# Note: iterates at least once.
	&Editable($n, $COL_EXPENSE,
		  $TBL->get($n - 1, $COL_EXPENSE)->cget('-state') eq 'normal');
	foreach my $col (@COLS) {
	    &TblSetVal($n, $col, &TblGetVal($n - 1, $col));
	}
    }
    foreach my $col (@COLS) {
	&TblSetVal($n, $col, '')  unless ($col == $COL_DATE);
    }

    my $w = $TBL->get($row, $COL_EXPENSE);
    $w->configure(&Editable(1));
    $w->focus();

    &UpdateTitle();
}




################################################################
#
# Append one or more rows to the table.  If no args are given, append
# only one row; else the arg is a date to use as a limit.
#
################################################################

sub AppendRow {
    my @limit = scalar(@_)  ?  shift(@_)  :  ();
    my $prefix = scalar(@_)  ?  shift(@_) . ' '  :  '';

    my $freq = 50;
    my $countdown = $freq;

    while (1) {
	my $line = $BUDGET->(@limit);
	last  unless (defined($line));
	my $row = $TBL->totalRows();

	if ($line !~
	    m!(\d{4}/\d\d/\d\d)\s+	# Date.
	      (.+?)\s*			# Category.
	      =>\s*			# Separator.
	      ([-\d.]+)\s+		# Delta.
	      ([-\d.]+)\s+		# New balance for this category.
	      \(\s*([-\d.]+)\)!x) {	# New bank balance.

	    print STDERR "Malformed line: \"$line\".";

	} else {
	    my ($date, $expense, $change, $itsBal, $newBal) =
	      ($1, $2, $3, $4, $5);

	    &TblPutRow($row,
		       {
			$COL_DATE    => \$date,
			$COL_EXPENSE => \$expense,
			$COL_CHANGE  => \$change,
			$COL_ITSBAL  => \$itsBal,
			$COL_NEWBAL  => \$newBal
		       });

	    unless (--$countdown) {
		&SetStatus("$prefix$date", 1);
		$countdown = $freq;
	    }
	}

	last  unless (scalar(@limit));
    }

    &UpdateTitle();
}




################################################################
#
# Calculate background color for a New Balance cell when its balance
# is the supplied value.  If flag is given and is 1, then return some
# text rather than a color name (for printing).
#
################################################################

sub BgCol {
    my $bal = shift(@_)  ||  0;
    my $i = (scalar(@_) && shift(@_))  ?  1  :  0;

    return $BAL_LVL{$BAL_DANGER}->[$i]   if ($bal <= $BAL_DANGER);
    return $BAL_LVL{$BAL_WARNING}->[$i]  if ($bal <= $BAL_WARNING);
    return $BAL_LVL{$BAL_NORMAL}->[$i];
}




BEGIN {
    my $printBasic = '| enscript -2rG 2>/dev/null';


################################################################
#
# Callback for the Print button.
#
################################################################

sub BtnPrint {
    &PrintCmn('Print', $printBasic);
}




################################################################
#
# Callback for the Print Preview button.
#
################################################################

sub BtnPrintPreview {
    &PrintCmn('Preview', "$printBasic -p - | ghostview -");
}

}				# End of the BtnPrint*s' BEGIN.




################################################################
#
# Callback for the Quit button.
#
################################################################

sub BtnQuit {
    &SetStatus('Exiting (if there are many rows, this takes a while)', 1);
    $TOP->exit();
}




################################################################
#
# Callback for the Reload button.
#
################################################################

sub BtnReload {
    &SetStatus('Sorry, can\'t reload yet.');
}




################################################################
#
# Callback for the Save button.
#
################################################################

sub BtnSave {
    &SetStatus('Sorry, can\'t save yet.');
}




################################################################
#
# Callback for the Undo button.
#
################################################################

sub BtnUndo {
    &SetStatus("You should have thought of that before.  (Can't undo yet.)");
}




################################################################
#
# On the first click, show the lowest balance in the whole projection.
# On the next click, show the lowest point below that, etc.
#
################################################################

BEGIN {
    my $last = 0;		# (Re)start search at row # (1 + $last).

sub BtnLowPoint {
    my $n = $TBL->totalRows();

    my ($low, $row, $date) = (undef, undef, undef);
    for (my $i = $last + 1; $i < $n; ++$i) {
	my $curr = &TblGetVal($i, $COL_NEWBAL);
	if (!defined($low) || ($curr < $low)) {
	    ($low, $row, $date) = ($curr, $i, &TblGetVal($i, $COL_DATE));
	}
    }

    if (defined($row)) {
	my $w = $TBL->get($row, $COL_NEWBAL);
	$TBL->see($w);
	$w->focus();
    }

    $last = (defined($row) && ($row < $n))  ?  $row  :  0;
    &SetStatus($last
	       ? "Next low point: \$$low on $date"
	       : 'No more; will restart from top on next click');
}
}



################################################################
#
# If date changed, move event to new sorted position.  If flag exists
# and is set, focus should move with the event.
#
################################################################

sub DateChanged {
    my ($row, $col) = $TBL->Posn(shift(@_));
    my $val = &TblGetVal($row, $COL_DATE);
    my $origRow = $row;

    my ($whine, $normalizedDate) = &DateComplaint($val);
    if (defined($whine)) {
	&SetStatus($whine);
	$TBL->see($row, $col);	# 'Cuz you can scroll away and click elsewhere.
	$TBL->get($row, $col)->focus();
	return;
    }

    # Save current row's original values.
    my @r = map { &TblGetVal($row, $_) } @COLS;
    $val = $r[$COL_DATE] = $normalizedDate;

    # If no change, be lazy.  This should stay *after* the correctness
    # checks.
    my $n = $TBL->totalRows();
    my $leNext = (($row + 1) > $n) || ($val le &TblGetVal($row + 1, $col));
    my $gePrev = ($row <= 1)       || ($val ge &TblGetVal($row - 1, $col));

    return  if ($leNext && $gePrev);

    if (!$leNext && !$gePrev) {
	&SetStatus("Warning: confused while trying to sort $val.");
	return;
    }

    &SetStatus('Moving ...', 1);

    my ($dir, $limit) = $gePrev
      ? (1, $n - 1)		# Move down.
      : (-1, 1);		# Move up.

    until ($row == $limit) {	# Another important condition is inside loop.
	my $nextRow = $row + $dir;
	my $valHere = &TblGetVal($nextRow, $COL_DATE);

	if ($dir > 0) {		# Moving down; stop when moved value is later.
	    last  if ($val le $valHere);
	} else {		# Moving up; stop when moved value is earlier.
	    last  if ($val ge $valHere);
	}

	my $thisE = &Editable($row, $COL_EXPENSE);
	my $nextE = &Editable($nextRow, $COL_EXPENSE);
	&Editable($row, $COL_EXPENSE, $nextE);
	&Editable($nextRow, $COL_EXPENSE, $thisE);

	foreach my $col (@COLS) {
	    &TblSetVal($row, $col, &TblGetVal($nextRow, $col));
	}
	$row = $nextRow;
    }

    # Place original row's values in new destination row.
    foreach my $col (@COLS) {
	&TblSetVal($row, $col, $r[$col]);
    }

    $TBL->get($row, $col)->focus()  if (scalar(@_) && shift(@_));
    &RecalcFrom($row < $origRow  ?  $row  :  $origRow);

    &SetStatus();
}




################################################################
#
# Ever had a complaint about your date?
#
################################################################

sub DateComplaint {
    my $date = shift(@_);
    my @whine = ("Invalid date \"$date\": want $DATE_FMT", undef);

    return @whine  if ($date !~ m!^(\d{4})/(\d{1,2})/(\d{1,2})$!);

    # Loose date checking: any 4-digit year passes, and we enforce 1
    # <= dd <= 31, but we don't ensure that dd and mm are consistent.
    my ($yyyy, $mm, $dd) = ($1, $2, $3);
    return @whine  if (($mm < 1) || ($mm > 12) || ($dd < 0) || ($dd > 31));

    return (undef, sprintf("%04d/%02d/%02d", $yyyy, $mm, $dd));
}




################################################################
#
# Delete the indicated row, moving other rows up if necessary.
#
################################################################

sub DeleteRow {
    my $row = shift(@_);
    my $origRow = $row;
    my $n = $TBL->totalRows() - 1;

    &SetStatus("Deleting row $row ...", 1);

    # Move everything up one row over $row ...
    for (; $row < $n; ++$row) {
	&Editable($row, $COL_EXPENSE,
		  $TBL->get($row + 1, $COL_EXPENSE)->cget('-state') eq 'normal');
	foreach my $col (@COLS) {
	    &TblSetVal($row, $col, &TblGetVal($row + 1, $col));
	}
    }

    # ... and destroy the last row.
    foreach my $col (@COLS) {
	if (0) {
	    $TBL->get($n, $col)->destroy();
	} else {
	    &TblSetVal($n, $col, '');
	}
    }

    &RecalcFrom($origRow);
    &SetStatus();
}




################################################################
#
# Call with one argument, a flag, to find out how to enable/disable an
# Entry widget.
#
# Call with two arguments, a row and column, to find out whether the
# Entry widget at that position is editable.
#
# Call with three arguments, a row and column and flag, to say whether
# that Entry widget should be enabled or disabled.
#
################################################################

BEGIN {
my @props = ( [ -state => 'disabled', -relief => 'groove', ],
	      [ -state => 'normal'  , -relief => 'sunken', ] );
sub Editable {
    return @{ $props[shift(@_)] }  if (scalar(@_) == 1);

    my ($row, $col, $flag) = @_;
    my $w = $TBL->get($row, $col);

    return $w->cget('-state') eq 'normal'  ?  1  :  0  if (scalar(@_) == 2);

    $flag = 0  unless (defined($flag));
    $w->configure(@{$props[$flag]});
}
}




################################################################
#
# Create and return the budget stream.  Makes heavy use of closures
# and anonymous subs.
#
################################################################

sub InitBudget {
    my $file = &GetEnv('PLANB_CONFIG', "$ENV{HOME}/.planb");

    my $alternating = sub {
	my @a = @_;
	my $i = 0;

	return sub {
	    $i = 0  if ($i >= scalar(@a));
	    return $a[$i++];
	};
    };

    my $card = sub {
	my ($pmt, $bal, $rate) = @_;

	$rate /= 1200.0;	# Monthly rate is 1/12 of APR, then -> decimal.
	return sub {
	    my $interest = $rate * $bal;
	    my $balBefore = $bal + $interest;

	    $bal = $balBefore - $pmt;

	    if ($bal <= 0) {	# Paid off: must pay only $balBefore, not $pmt.
		$bal = '0.00';
		return ($balBefore, $bal);
	    }

	    # Else round balance to nearest penny and make a full
	    # payment.
	    $bal = sprintf("%.2f", $bal);
	    return ($pmt, $bal);
	};
    };

    my ($cYyyy, $cMm, $cDd, $cPmt, $cBal) = (0 .. 4); # Only $cBal is now used.
    my %bills = ();
    my %pay = ();

    my $balance = 0;		# Running balance.
    my $initBal = 0;		# Actual starting balance.
    my $fieldWidth = 0;
    my $fmt = '';
    my $time = 0;
    my ($currYy, $currMm, $currDd, $currWd) = (0, 0, 0, 0);
    my @entries = ();

    my $bux = '(\d+\.\d\d)';
    &SafeOpen($file);
    while (<$file>) {
	chomp;

	if ($_ =~ /^\s*(\#.*)?$/) {
	    next;		# Blank line or comment line.

	} elsif ($_ =~ /^TITL\s+(.+)\s*$/) {
	    $BaseTitle = $1;

	} elsif ($_ =~ /^INIT\s+$bux\s*$/) {
	    $initBal = $1;

	} elsif ($_ =~ /^DATE\s+(\d{4})\s+(\d{1,2})\s+(\d{1,2})\s*$/) {
	    ($currYy, $currMm, $currDd) = ($1, $2, $3);

	} elsif ($_ =~ /^INCM\s+(.+?)\s*=>\s*(\w{3}|\d+)\s+$bux\s*(.*)$/) {
	    # Note that we switch $3 and $4 here.
	    my ($lbl, $when, $rest, @amt) = ($1, $2, $4, $3);

	    while ($rest ne '') {
		if ($rest =~ /^$bux\s*(.*)$/) {
		    push(@amt, $1);
		    $rest = $2;
		} else {
		    goto BADREC;
		}
	    }

	    $pay{$when} = []  unless(exists($pay{$when}));
	    push(@{ $pay{$when} }, [ $lbl, $alternating->(@amt) ]);

	} elsif ($_ =~
		 /^CARD\s+	# Type.
		 (.+?)\s*	# Label.
		 =>\s*		# Separator.
		 (\d{1,2}|Sun|Mon|Tue|Wed|Thu|Fri|Sat)\s+ # Day of month|week.
		 $bux\s+	# Payment.
		 $bux\s+	# Card balance.
		 $bux\s*$/x) {	# Usurious interest rate.
	    my ($lbl, $dd, $pmt, $bal, $rate) = ($1, $2, $3, $4, $5);

	    if (exists($bills{$lbl})) {
		&Fatal("$file:$.: Repeated label '$lbl'.");
	    }
	    $bills{$lbl} = [ 0, 0, $dd, $card->($pmt, $bal, $rate) ];

	} elsif ($_ =~
		 /^BILL\s+	# Type.
		 (.+?)\s*	# Label.
		 =>\s*		# Separator.
		 (0|\d{4})\s+	# 0 or year.
		 (\d{1,2})\s+	# 0 or month number.
		 (\d{1,2}|Sun|Mon|Tue|Wed|Thu|Fri|Sat)\s+ # Day of month|week.
		 $bux\s+	# Amount.
		 (.+)$/x) {	# Expression for limit (may be "undef").
	    my ($lbl, $yyyy, $mm, $dd, $amt, $expr) = ($1, $2, $3, $4, $5, $6);

	    my $limit = eval $expr;
	    if (defined($@) && length($@)) {
		print STDERR "$file:$.: $@.";
		goto BADREC;
	    }

	    if (exists($bills{$lbl})) {
		&Fatal("$file:$.: Repeated label '$lbl'.");
	    }
	    $bills{$lbl} = [ $yyyy, $mm, $dd, $amt, $limit ];

	} else {
BADREC:
	    &Fatal("Malformed record on line $. of $file.");
	}
    }
    close($file);

    &Fatal('No DATE record.')  if (!$currYy);

    # The C (and perl) time routines use 0-based months, we use 1-based.
    $time = timelocal(0, 0, 0, $currDd, $currMm - 1, $currYy);

    foreach (keys %bills) {
	$fieldWidth = length($_)  if (length($_) > $fieldWidth);
    }
    $fmt = "%4d/%02d/%02d %${fieldWidth}s => %9.2f %9.2f (%9.2f)\n";

    my $rpt = sub {
	my ($desc, $amt, $itsBal) = @_;

	$itsBal = 0  unless (defined($itsBal));
	$balance += $amt;
	my $s =
	  sprintf $fmt,
		  $currYy, $currMm, $currDd, $desc, $amt, $itsBal, $balance;

	return [(split(' ', $s))[0], $s];
    };

    my @dow = qw(Sun Mon Tue Wed Thu Fri Sat);

    return sub {
	my $limit = scalar(@_)  ?  shift(@_)  :  undef;

	until (scalar(@entries)) {
	    ($currYy, $currMm, $currDd, $currWd) =
	      (localtime($time))[5, 4, 3, 6];
	    $currYy += 1900;
	    ++$currMm;

	    if ($initBal) {
		push(@entries, $rpt->('Initially', $initBal, undef));
		$initBal = 0;	# Do this only once, naturally.
	    }

	    if (exists($pay{$dow[$currWd]}) || exists($pay{$currDd})) {
		foreach my $when (keys %pay) {
		    foreach my $entry (@{ $pay{$when} }) {
			next  unless (($when eq $dow[$currWd]) ||
				      ($when eq $currDd));

			my ($lbl, $pay) = @$entry;

			$pay = $pay->()  if (ref($pay));
			if ($pay > 0) {
			    push(@entries, $rpt->($lbl, $pay, undef));
			}
		    }
		}
	    }

	    my @bills = sort keys %bills;
	    foreach (@bills) {
		my ($yy, $mm, $dd, $pmt, $bal) = @{ $bills{$_} };

		# If non-numeric, convert to numeric: 0 if it's the
		# current DOW (so it will pass the next if), -1 if not
		# (so it won't).
		if ($dd =~ /^\D/) {
		    $dd = ($dd eq $dow[$currWd])  ?  0  :  -1;
		}
		if ((!$dd || ($currDd == $dd)) &&
		    (!$mm || ($currMm == $mm)) &&
		    (!$yy || ($currYy == $yy))) {

		    my $ref = ref($pmt);
		    if (defined($ref) && ($ref eq 'CODE')) {
			($pmt, $bal) = $pmt->();

		    } elsif (defined($bal)) {
			$pmt = $bal  if ($pmt > $bal);
			$bal -= $pmt;
		    }

		    push(@entries, $rpt->($_, -$pmt, $bal));

		    if (defined($bal)) {
			if ($bal <= 0) {
			    delete $bills{$_};
			} else {
			    $bills{$_}->[$cBal] = sprintf "%.2f", $bal;
			}
		    }
		}
	    }

	    $time += 60 * 60 * 24;	# Advance to next day.
	}

	return (defined($limit) &&
		($limit ne '-1') &&
		($limit lt $entries[0]->[0]))
	  ? undef
	  : shift(@entries)->[1];
    };
}




################################################################
#
# Pop up menu on each field.  Not implemented yet, obviously.
#
################################################################

BEGIN {

my $m = undef;			# Menu shared by all these fns.




################################################################
#
# Pop up menu on the (amount of) Change field.
#
################################################################

sub PmChange {
    &PmUtilNewMenu(@_);
    &PmUtilPostMenu();
}




################################################################
#
# Pop up menu on the Date field.
#
################################################################

sub PmDate {
    &PmUtilNewMenu(@_);
    &PmUtilPostMenu();
}




################################################################
#
# Pop up menu on the Expense Category field.
#
################################################################

sub PmExpense {
    &PmUtilNewMenu(@_);

    # If $w is editable, give the user a popup menu with all known
    # expense types.
    my $w = shift(@_);
    my ($wr, $wc) = $TBL->Posn($w);

    if ($w->cget('-state') eq 'normal') {
	my %expenses = ();
	my $n = $TBL->totalRows();

	for (my $row = 1; $row < $n; ++$row) {
	    $expenses{&TblGetVal($row, $COL_EXPENSE)} = 1;
	}

	$m->add('separator');
	foreach my $lbl (sort keys %expenses) {
	    next  if ($lbl =~ /^\s*$/);
	    $m->add('command',
		    label   => $lbl,
		    command => sub { &TblSetVal($wr, $wc, $lbl); });
	}
    }

    &PmUtilPostMenu();
}




################################################################
#
# Pop up menu on the Its Balance field.
#
################################################################

sub PmItsBal {
    &PmUtilNewMenu(@_);
    &PmUtilPostMenu();
}




################################################################
#
# Pop up menu on the New Balance field.
#
################################################################

sub PmNewBal {
    &PmUtilNewMenu(@_);
    &PmUtilPostMenu();
}




################################################################
#
# Utility fn for the other Pm* fns.  This is the part of the menu that
# all the popups have in common.
#
################################################################

sub PmUtilNewMenu {
    my $w = shift(@_);

    $m->unpost()  if (defined($m));
    $m = $TOP->Menu(tearoff => 0);

    # Add stuff that should appear on each of the popup menus.
    $m->add('command',
	    label   => 'Add Row After This One',
	    command => sub { &AddRowAt(($TBL->Posn($w))[0] + 1); });

    $m->add('command',
	    label   => 'Add Row Before This One',
	    command => sub { &AddRowAt(($TBL->Posn($w))[0]); });

    $m->add('command',
	    label   => 'Delete Row',
	    command => sub { &DeleteRow(($TBL->Posn($w))[0]); });

    $m->add('separator');

    $m->add('command',
	    label   => 'Oops!  Just Close This Menu',
	    command => sub { $m->unpost(); });
}




################################################################
#
# Utility function for the Pm* functions.  Pops up the finished menu
# where the mouse pointer is.
#
################################################################

sub PmUtilPostMenu {
    $m->post($TOP->winfo('pointerx'), $TOP->winfo('pointery'));
}

}				# End of the Pm*s' BEGIN.




################################################################
#
# Common code for the BtnPrint* callbacks.
#
################################################################

sub PrintCmn {
    my ($prefix, $print) = @_;

    &SetStatus("${prefix}ing ...", 1);

    my $n = $TBL->totalRows();
    my $fmt = "%${DATE_WIDTH}s" . (" %${COL_WIDTH}s" x $COL_MAXCOL) . " %s\n";

    # It's absurdly difficult to customize the header string, so I'm
    # not doing that for now.
    &SafeOpen($print);
    printf $print ($fmt,
		   (map { $TBL->get(0, $_)->cget('-text') } @COLS),
		   '');
    for (my $i = 1; $i < $n; ++$i) {
	printf $print ($fmt,
		       (map { &TblGetVal($i, $_) } @COLS),
		       &BgCol(&TblGetVal($i, $COL_NEWBAL), 1)
		      );
    }
    close($print);

    &SetStatus();
}




################################################################
#
# A value in the Change column may have changed.  See whether this is
# so and recalculate the balances.
#
################################################################

sub Recalc {
    my ($row, $col) = $TBL->Posn(shift(@_));

    # Validate/normalize cell's value.
    my $val = &TblGetVal($row, $COL_CHANGE);
    if ($val !~ /^\s*(-|\+)?(\d+)(\.\d\d)?\s*$/) {
	&SetStatus('Invalid money format: want [+/-]123.45');
	$TBL->get($row, $col)->focus();
	$TBL->see($row, $col);
	return;
    }
    &TblSetVal($row, $col, $val = sprintf("%.2f", $val));

    # If given the lazy-flag, be lazy.  Since the table entries may be
    # '' when a new row has just been added manually, we turn '' into
    # 0 here.
    my $prevBal = (($row > 1)  ?  &TblGetVal($row - 1, $COL_NEWBAL)  :  0) || 0;
    my $thisBal = (&TblGetVal($row, $COL_NEWBAL)) || 0;
    return  if (scalar(@_) && shift(@_) && (($prevBal + $val) == $thisBal));

    &RecalcFrom($row);
}




################################################################
#
# Recalculate from row $row down.
#
################################################################

sub RecalcFrom {
    &SetStatus('Recalculating ...', 1);

    my $row = shift(@_);
    my $bal = undef; # ($row == 1)  ?  0  :  &TblGetVal($row - 1, $COL_NEWBAL);

    for (my $i = $row; ($i > 1) && !defined($bal); --$i) {
	my $thisBal = &TblGetVal($i - 1, $COL_NEWBAL);
	$bal = $thisBal  unless ($thisBal eq '');
    }
    $bal = 0  unless (defined($bal));

    foreach my $row ($row .. $TBL->totalRows() - 1) {
	my $change = &TblGetVal($row, $COL_CHANGE) || 0; # Sometimes ''.
	&TblSetVal($row, $COL_NEWBAL, sprintf("%.2f", $bal += $change));
    }

    &SetStatus();
}




################################################################
#
# Return a reference to a scalar whose value is the supplied one.
#
################################################################

sub RefTo {
    my $val = shift(@_);
    return \$val;
}




################################################################
#
# Set the status text.  If called without an argument, the status text
# defaults to "Ready."  Also sets the cursor to watch (if flag is
# given and nonzero) or normal (otherwise).
#
################################################################

BEGIN {
    my $cursorWas = undef;

sub SetStatus {
    $STATUS->configure(-text => scalar(@_)  ?  shift(@_)  :  'Ready');

    my $cursor = (scalar(@_) && shift(@_))  ?  'watch'  :  'left_ptr';

    # Only set the cursor if it has changed since last time.  Since
    # this avoids redundantly setting the cursor over all table
    # elements, it generally speeds things up.  Still, the loop can
    # really cause a lag -- maybe I could loop over only the displayed
    # subset?
    if (!defined($cursorWas) || ($cursorWas ne $cursor)) {
	$cursorWas = $cursor;

	$TOP->configure(-cursor => $cursor);

	# Now set the cursor over the table's elements.  This could
	# get really slow ....
	my @r = (0 .. $TBL->totalRows() - 1);
	my @c = (0 .. $TBL->totalColumns() - 1);
	for my $c (@c) {
	    for my $r (@r) {
		$TBL->get($r, $c)->configure(-cursor => $cursor);
	    }
	}
    }

    $STATUS->update();		# Ensure the change appears immediately.
}

}				# End the BEGIN.




################################################################
#
# Get the text entered in the given (row, col) of the sheet.
#
################################################################

sub TblGetVal {
    $TBL->get(shift(@_), shift(@_))->get();
}




################################################################
#
# Insert a table row at $row.  $h is a ref to a hash from $COL_XXX to a
# value for that column.
#
################################################################

sub TblPutRow {
    my ($row, $h) = @_;
    my @nonEditable = &Editable(0);

    $TBL->put($row, $COL_DATE,
	      $TOP->Entry(-textvariable=> $h->{$COL_DATE},
			  -width	=> $DATE_WIDTH));
    $TBL->put($row, $COL_EXPENSE,
	      $TOP->Entry(-textvariable=> $h->{$COL_EXPENSE},
			  @nonEditable,
			  -width	=> $COL_WIDTH));
    $TBL->put($row, $COL_CHANGE,
	      $TOP->Entry(-textvariable=> $h->{$COL_CHANGE},
			  -width	=> $COL_WIDTH,
			  -justify	=> 'right'));
    $TBL->put($row, $COL_ITSBAL,
	      $TOP->Entry(-textvariable=> $h->{$COL_ITSBAL},
			  -width	=> $COL_WIDTH,
			  -justify	=> 'right',
			  @nonEditable));
    $TBL->put($row, $COL_NEWBAL,
	      $TOP->Entry(-textvariable=> $h->{$COL_NEWBAL},
			  -width	=> $COL_WIDTH,
			  -justify	=> 'right',
			  @nonEditable,
			  -background  => &BgCol($ {$h->{$COL_NEWBAL}})));

    # Add the appropriate popup menu for each cell in the row.
    foreach my $col (@COLS) {
	my $w = $TBL->get($row, $col);
	$w->bind('<Button-3>' => $BTN3{$col});

	if ($col == $COL_DATE) {
	    $w->bind('<Return>'   => [ \&DateChanged, 1 ]);
	    $w->bind('<FocusOut>' => [ \&DateChanged, 0 ]);

	} elsif ($col == $COL_CHANGE) {
	    # Recalculate when user hits ENTER and when we lose focus.
	    # We always recalc when the user hits ENTER, but when we
	    # lose focus we only recalculate if the cell's value has
	    # changed.
	    $w->bind('<Return>'   => [ \&Recalc, 0 ]);
	    $w->bind('<FocusOut>' => [ \&Recalc, 1 ]);
	}
    }
}




################################################################
#
# Get the text entered in the given (row, col) of the sheet.
#
################################################################

sub TblSetVal {
    my ($row, $col, $val) = @_;
    my $w = $TBL->get($row, $col);
    my $r = ref($val)  ?  $val  :  \$val;

    $w->configure(-textvariable => $r);
    $w->configure(-background => &BgCol($ { $r }))  if ($col == $COL_NEWBAL);
}




################################################################
#
# Update the main window's title bar.
#
################################################################

sub UpdateTitle {
    $TOP->title("$BaseTitle (@{[$TBL->totalRows() - 1]} rows)");
}