279 lines
11 KiB
Perl
Executable file
279 lines
11 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
# License: AGPLv3-or-later
|
|
# see files COPYRIGHT, LICENSE, and AGPL-3.0.txt included in canonical repository for details.
|
|
# https://k.sfconservancy.org/NPO-Accounting/beancount-tools-in-Perl
|
|
|
|
use strict;
|
|
use warnings;
|
|
use autodie qw(:all);
|
|
|
|
use sigtrap 'handler' => \&CleanupEvertything, 'normal-signals', 'stack-trace' => 'error-signals';
|
|
|
|
use Carp;
|
|
|
|
use Getopt::Long;
|
|
use File::Spec::Functions;
|
|
use File::Temp qw/:mktemp tempdir/;
|
|
use Git::Repository 'Log';
|
|
|
|
use POSIX qw(mkfifo);
|
|
use IPC::Shareable;
|
|
use Expect;
|
|
|
|
my $RSYNC_CMD = '/usr/bin/rsync';
|
|
|
|
# We have to set the PAGER to a passthrough text program to assure that
|
|
# output does not get paused
|
|
$ENV{PAGER} = "/usr/bin/cat";
|
|
|
|
my $BEANCOUNT_QUERY_CMD = "/usr/bin/bean-query";
|
|
|
|
my($VERBOSE, $BEANCOUNT_DIR, $LOAD_FILE, $BRANCH_NAME, $FIFO_DIR) = (0, undef, undef, undef, undef);
|
|
|
|
GetOptions("verbose=i" => \$VERBOSE, "beancountDir=s" => \$BEANCOUNT_DIR,
|
|
"loadFile=s" => \$LOAD_FILE, "branchName=s" => \$BRANCH_NAME, 'fifoDir=s' => \$FIFO_DIR);
|
|
|
|
sub UsageAndExit($) {
|
|
print STDERR "usage: $0 --loadFile=/path/to/file.beancount --beancountDir=/path/to/beancountdir --fifoDir=/path/to/directory/for/fifos [ --branchName=BRANCH_NAME --verbose=N ]\n";
|
|
print STDERR "\n $_[0]\n";
|
|
exit 2;
|
|
}
|
|
UsageAndExit("/path/to/direcotry/for/fifos must be provided and be an existing directory")
|
|
unless (defined $FIFO_DIR and -d $FIFO_DIR);
|
|
|
|
UsageAndExit("/path/to/file.beancount/path/to/beancountdir must be provided and be an existing directory")
|
|
unless (defined $BEANCOUNT_DIR and -d $BEANCOUNT_DIR);
|
|
chdir $BEANCOUNT_DIR;
|
|
|
|
UsageAndExit("/path/to/file.beancount must a relative path to a file that exists in $BEANCOUNT_DIR")
|
|
unless (defined $LOAD_FILE and -r $LOAD_FILE);
|
|
|
|
my($tempRepository, $tempRepositoryDirectory);
|
|
|
|
sub CleanupEvertything {
|
|
$tempRepository = undef if (defined $tempRepository);
|
|
$tempRepositoryDirectory = undef if (defined $tempRepositoryDirectory);
|
|
StopRunningBeanQuery();
|
|
croak @_;
|
|
}
|
|
if (defined $BRANCH_NAME) {
|
|
my $absGitRepositoryDirectory = File::Spec->rel2abs( $BEANCOUNT_DIR );
|
|
$tempRepositoryDirectory = tempdir('beancountquerygoofydaemongit_' . $$ . '_XXXXXXXXXXX',
|
|
TMPDIR => 1, CLEANUP => 1);
|
|
print STDERR "Copy Git repository to $tempRepositoryDirectory...." if $VERBOSE > 2;
|
|
system($RSYNC_CMD, '-Ha', "$absGitRepositoryDirectory/", "$tempRepositoryDirectory/");
|
|
print STDERR "copy completed.\n" if $VERBOSE > 2;
|
|
$tempRepository = Git::Repository->new( work_tree => $tempRepositoryDirectory );
|
|
|
|
chdir $tempRepositoryDirectory;
|
|
$tempRepository->run(clean => '-fx', { quiet => 1 });
|
|
$tempRepository->run(reset => '--hard', { quiet => 1 });
|
|
$tempRepository->run(clean => '-fx', { quiet => 1 });
|
|
$tempRepository->run(checkout => '$BRANCH_NAME', { quiet => 1 });
|
|
}
|
|
|
|
sub CheckUpstreamAndPull {
|
|
# Returns true iff. a pull was required and the files have changed.
|
|
return 0 unless (defined $tempRepository);
|
|
my $options = { quiet => 1 };
|
|
if ($VERBOSE > 5) {
|
|
print STDERR "...clean & git pull...";
|
|
$options = {};
|
|
}
|
|
print STDERR "...check if upstream Git changed..." if $VERBOSE > 5;
|
|
my $updateOutput = $tempRepository->run(remote => 'update', $options);
|
|
print "$updateOutput" if defined $updateOutput and $updateOutput !~ /^\s*$/ and $VERBOSE > 5;
|
|
my $curRev = $tempRepository->run('rev-parse' => '@');
|
|
my $remoteRev = $tempRepository->run('rev-parse' => '@{u}');
|
|
my $baseRev = $tempRepository->run('merge-base' => '@', '@{u}');
|
|
print STDERR "...$curRev is current, $remoteRev is remote Rev $baseRev is base...\n" if $VERBOSE > 6;
|
|
if ($curRev eq $remoteRev) {
|
|
print STDERR "no change..." if $VERBOSE > 5;
|
|
return 0;
|
|
} elsif ($curRev eq $baseRev) {
|
|
$tempRepository->run(clean => '-fx', $options);
|
|
$tempRepository->run(reset => '--hard', $options);
|
|
$tempRepository->run(clean => '-fx', $options);
|
|
my $pullOutput = $tempRepository->run('pull');
|
|
print STDERR "\nPerformed pull since remote updated:\n $pullOutput\n" if ($VERBOSE > 0);
|
|
return 1;
|
|
} else {
|
|
CleanupEvertything();
|
|
die("our local Git has $curRev, upstream is at $remoteRev, and the base is $baseRev " .
|
|
"so give up entirely on trying to make this work.");
|
|
}
|
|
}
|
|
my $glue = 'BeAn';
|
|
my %options = (
|
|
create => 'yes',
|
|
exclusive => 0,
|
|
mode => 0600,
|
|
destroy => 'yes',
|
|
);
|
|
my %query;
|
|
tie %query, 'IPC::Shareable', $glue, { %options } or
|
|
die "server: tie failed for $glue\n";
|
|
|
|
%query = ();
|
|
|
|
my %beancountData;
|
|
tie %beancountData, 'IPC::Shareable', $glue, { %options } or
|
|
die "server: tie failed\n";
|
|
|
|
my ($currentFormat, $runningBeanQuery);
|
|
|
|
sub StartRunningBeanQuery {
|
|
my($format) = @_;
|
|
$format = $currentFormat unless defined $format;
|
|
$currentFormat = $format;
|
|
|
|
if (defined $tempRepository) {
|
|
print STDERR "Clearing temp files from repository..." if $VERBOSE > 4;
|
|
$tempRepository->run(clean => '-fx', { quiet => 1 });
|
|
$tempRepository->run(reset => '--hard', { quiet => 1 });
|
|
$tempRepository->run(clean => '-fx', { quiet => 1 });
|
|
} else {
|
|
my(@findCmd) = ("/usr/bin/find", '.', '-name', '*.picklecache');
|
|
if ($VERBOSE > 4) {
|
|
print STDERR "Cleared the following picklecache files (none listed means none existed)...\n";
|
|
push(@findCmd, '-ls');
|
|
}
|
|
push(@findCmd, '-exec', '/usr/bin/rm', '-f', '{}', ';');
|
|
system(@findCmd);
|
|
print STDERR "...done clearing picklecache files.\n" if ($VERBOSE > 4);
|
|
}
|
|
my @cmd = ($BEANCOUNT_QUERY_CMD);
|
|
push(@cmd, '-f', $format) if defined $format;
|
|
push(@cmd, $LOAD_FILE);
|
|
print STDERR "Starting beancount..." if $VERBOSE > 4;
|
|
$runningBeanQuery = Expect->spawn(@cmd);
|
|
print STDERR "...spawned & loading data..." if $VERBOSE > 4;
|
|
$runningBeanQuery->log_stdout(0);
|
|
$runningBeanQuery->expect(undef, -re => '^\s*beancount\s*\>\s*')
|
|
or die("Unable to find beancount prompt, output was instead: ".
|
|
$runningBeanQuery->before() . $runningBeanQuery->after());
|
|
print STDERR "now ready." if $VERBOSE > 4;
|
|
print STDERR "Beancount started with output of:\n", $runningBeanQuery->before(),
|
|
$runningBeanQuery->match(), $runningBeanQuery->after(), "\n"
|
|
if ($VERBOSE > 3);
|
|
}
|
|
sub StopRunningBeanQuery {
|
|
return if not defined $runningBeanQuery;
|
|
$runningBeanQuery->send("exit\n");
|
|
$runningBeanQuery->soft_close();
|
|
}
|
|
CheckUpstreamAndPull();
|
|
StartRunningBeanQuery('text');
|
|
print STDERR "Beancount started. Main loop begins." if $VERBOSE > 0;
|
|
while (1) {
|
|
if (not defined $query{question}) {
|
|
print STDERR "No question posed..." if $VERBOSE > 5;
|
|
if (CheckUpstreamAndPull()) {
|
|
StopRunningBeanQuery();
|
|
StartRunningBeanQuery();
|
|
}
|
|
if (defined $query{fifoName}) {
|
|
print STDERR "fifo still active; locking to clear it..." if $VERBOSE > 5;
|
|
(tied %query)->shlock;
|
|
print STDERR "clearing fifo, $query{fifoName}..." if $VERBOSE > 5;
|
|
no autodie 'unlink'; unlink($query{fifoName});
|
|
%query = ();
|
|
(tied %query)->shunlock;
|
|
print STDERR "fifo cleared & lock released." if $VERBOSE > 5;
|
|
}
|
|
print STDERR "sleep for 2 seconds\n" if $VERBOSE > 5;
|
|
sleep 2;
|
|
next;
|
|
# } elsif ($query{question} !~ /^[\,\=\~\-\@\w.\s\"\'\_\(\)\<\>\*\.\!\^\:\$\|]+$/) {
|
|
} elsif ($query{question} !~ /^[\s\S]+$/) {
|
|
print STDERR "Query string $query{question} looks suspicious, not running beancount query!\n";
|
|
(tied %query)->shlock;
|
|
$query{fifoName} = mktemp("REJECTED_beancount-query-fifo-this-file-does-not-exist_${$}_XXXXXXXXX");
|
|
(tied %query)->shunlock;
|
|
sleep 2;
|
|
} elsif (defined $query{format} and $query{format} !~ /^(?:csv|text)$/) {
|
|
print STDERR "format string $query{format} is not text or csv, not running beancount query!\n";
|
|
(tied %query)->shlock;
|
|
$query{question} = $query{format} = undef;
|
|
$query{fifoName} = mktemp("REJECTED_beancount-query-fifo-this-file-does-not-exist_${$}_XXXXXXXXX");
|
|
(tied %query)->shunlock;
|
|
} elsif (not defined $query{fifoName}) {
|
|
if (defined $query{format}) {
|
|
unless ($query{format} =~ /^(?:text|csv)$/) {
|
|
print STDERR "format string $query{format} is not supported yet!\n";
|
|
(tied %query)->shlock;
|
|
$query{question} = $query{format} = undef;
|
|
$query{fifoName} = mktemp("REJECTED_beancount-$query{format}_not_supported_${$}_XXXXXXXXX");
|
|
(tied %query)->shunlock;
|
|
next;
|
|
}
|
|
if ($currentFormat ne $query{format}) {
|
|
$runningBeanQuery->send("set format $query{format}\n");
|
|
$runningBeanQuery->expect(undef, 'beancount>') # *Don't* use regex here!
|
|
or die("Unable to find beancount prompt, output was instead: ".
|
|
$runningBeanQuery->before() . $runningBeanQuery->after());
|
|
$currentFormat = $query{format};
|
|
print STDERR "Switched formats to the $currentFormat..." if $VERBOSE > 3;
|
|
my $rbcBefore = $runningBeanQuery->before();
|
|
die("Unable to change format to $currentFormat")
|
|
unless $rbcBefore =~ /format\s*:\s*$currentFormat/ixm;
|
|
}
|
|
}
|
|
print STDERR "Runing query: $query{question}\n" if $VERBOSE > 0;
|
|
my $ques = $query{question};
|
|
$ques =~ s/\n/ /gm;
|
|
$runningBeanQuery->send("$ques\n");
|
|
$runningBeanQuery->expect(undef, 'beancount>') # *Don't* use regex here!
|
|
# See `git annotate` on this line for why no regex.
|
|
or die("Unable to find beancount prompt, output was instead: ".
|
|
$runningBeanQuery->before() . $runningBeanQuery->after());
|
|
(tied %query)->shlock;
|
|
print STDERR "Acquired shlock on tied variable.\n" if $VERBOSE > 2;
|
|
$query{fifoName} = undef;
|
|
my $cnt = 0;
|
|
my $fifoFileName = mktemp(catfile($FIFO_DIR, "beancount-query-fifo_${$}_XXXXXXXXX"));
|
|
mkfifo($fifoFileName, 0700);
|
|
die "unable to create fifo in $fifoFileName: $!" unless -p $fifoFileName;
|
|
print STDERR "Created $fifoFileName..." if $VERBOSE > 2;
|
|
$query{fifoName} = $fifoFileName;
|
|
my $getAllOutput = $query{getAllOutput};
|
|
(tied %query)->shunlock;
|
|
print STDERR "unlocked tied query..." if $VERBOSE > 2;
|
|
open(my $fifoFH, ">", $fifoFileName);
|
|
print STDERR "and began write to fifo." if $VERBOSE > 2;
|
|
my($seenSeperator, $prevLine) = ( ((defined $getAllOutput) and $getAllOutput), "");
|
|
my $rbcOut = $runningBeanQuery->before();
|
|
foreach my $line (split /\n/, $rbcOut) {
|
|
# Occasionally, some of the SELECT statement is printed back to
|
|
# $rbcOut. Avoid reproducing this in output by waiting for the line
|
|
# of ----'s. Thus, this only works in text mode right now.
|
|
print "Line found \"$line\"\n" if $VERBOSE > 9;
|
|
unless ($seenSeperator) {
|
|
if ($line =~ /^\s*$/) {
|
|
$seenSeperator = 1;
|
|
} elsif (($currentFormat eq 'text' and $line =~ /^\s*[\-\s]+\s*$/)
|
|
or ($currentFormat eq 'csv' and $line =~ /^\s*(\S+,)*\S+\s*$/)){
|
|
$seenSeperator = 1;
|
|
}
|
|
$prevLine = $line;
|
|
next;
|
|
}
|
|
last if $line =~ /^\s*beancount\s*\>\s*/;
|
|
print STDERR "." unless ($cnt++ % 500) or ($VERBOSE <= 1);
|
|
print $fifoFH "$line\n";
|
|
$prevLine = $line;
|
|
}
|
|
close $fifoFH;
|
|
(tied %query)->shlock; $query{question} = undef; (tied %query)->shunlock;
|
|
print STDERR "...done! Data now in $fifoFileName\n" if $VERBOSE > 0;
|
|
}
|
|
}
|
|
finish $runningBeanQuery;
|
|
|
|
###############################################################################
|
|
#
|
|
# Local variables:
|
|
# compile-command: "perl -c bean-query-goofy-daemon.plx"
|
|
# perl-indent-level: 2
|
|
# End:
|
|
|