Compare commits
10 commits
11628b4333
...
a5967d4cf9
| Author | SHA1 | Date | |
|---|---|---|---|
|
a5967d4cf9 | ||
|
|
f43e0000d1 | ||
|
|
20ac3c5ef7 | ||
|
|
10d809c180 | ||
|
|
ee82738f0a | ||
|
|
bd38cf6198 | ||
|
|
c4e5664bb5 | ||
|
|
72559aa8d6 | ||
|
|
ce4c406fe6 | ||
|
|
e1857dc63f |
3 changed files with 207 additions and 47 deletions
57
bean-query-cli.plx
Executable file
57
bean-query-cli.plx
Executable file
|
|
@ -0,0 +1,57 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Term::ReadLine;
|
||||
use Term::ReadKey;
|
||||
use File::Spec::Functions;
|
||||
use IPC::Shareable;
|
||||
|
||||
require 'bean-query-daemon-lib.pl';
|
||||
|
||||
my $term = new Term::ReadLine 'bean-query-d';
|
||||
my $prompt = 'bqd> ';
|
||||
|
||||
my $dir = $ENV{HOME};
|
||||
$dir = "~$ENV{USER}" if not defined $dir and defined $ENV{USER};
|
||||
$dir = "~$ENV{LOGNAME}" if not defined $dir and defined $ENV{LOGNAME};
|
||||
|
||||
my $pager = $ENV{PAGER} || '/usr/bin/less';
|
||||
my ($isPaging, $saveOut) = (0, undef);
|
||||
sub startpage {
|
||||
return if $isPaging;
|
||||
open($saveOut, '>&', STDOUT);
|
||||
open(STDOUT, "|-", $pager);
|
||||
$isPaging = 1;
|
||||
}
|
||||
sub endpage {
|
||||
return unless $isPaging;
|
||||
close(STDOUT);
|
||||
open(STDOUT, '>&', $saveOut);
|
||||
$isPaging = 0;
|
||||
}
|
||||
BeancountQueryInitialize();
|
||||
|
||||
my $histfile = catfile($dir, '.bean-shell-history');
|
||||
$term->ReadHistory($histfile);
|
||||
|
||||
my $cmd = "";
|
||||
while ( (defined ($cmd = $term->readline($prompt))) and $cmd ne 'exit') {
|
||||
next if $cmd =~ /^\s*$/;
|
||||
chomp $cmd;
|
||||
$term->AddHistory($cmd);
|
||||
$term->WriteHistory($histfile);
|
||||
|
||||
my $fileName = BeancountQuerySubmit($cmd, 'text', 1);
|
||||
open(my $fh, "<", $fileName);
|
||||
my($beanOutput, $lineCount) = ("", 0);
|
||||
my($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize();
|
||||
while (my $line = <$fh>) { $beanOutput .= $line; $lineCount++; print STDERR ".";}
|
||||
close $fh;
|
||||
BeancountQueryComplete();
|
||||
startpage() if ($lineCount >= $hchar);
|
||||
print $beanOutput;
|
||||
endpage();
|
||||
}
|
||||
print "\n";
|
||||
|
|
@ -5,18 +5,22 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
|
||||
use IPC::Shareable;
|
||||
|
||||
our %BEANCOUNT_QUERY;
|
||||
|
||||
my $IPC_GLUE = 'BeAn';
|
||||
|
||||
sub BeancountQueryInitialize {
|
||||
sub BeancountQueryInitialize (;$) {
|
||||
$IPC_GLUE = $_[0] if (defined $_[0]);
|
||||
die "Glue must be exactly four characters" unless defined $IPC_GLUE and length($IPC_GLUE) == 4;
|
||||
my %options = (create => 0, exclusive => 0, mode => 0600, destroy => 0);
|
||||
tie %BEANCOUNT_QUERY, 'IPC::Shareable', $IPC_GLUE, { %options } or
|
||||
die "BEANCOUNT_QUERY: tie failed: is the goffy beancount server running?\n";
|
||||
}
|
||||
|
||||
sub BeancountQuerySubmit($;$) {
|
||||
my($question, $format) = @_;
|
||||
sub BeancountQuerySubmit($;$$) {
|
||||
my($question, $format, $getAllOutput) = @_;
|
||||
while (defined $BEANCOUNT_QUERY{fifoName} or defined $BEANCOUNT_QUERY{question}) { sleep 1; }
|
||||
(tied %BEANCOUNT_QUERY)->shlock;
|
||||
if (defined $BEANCOUNT_QUERY{fifoName} or defined $BEANCOUNT_QUERY{question}) {
|
||||
|
|
@ -28,15 +32,21 @@ sub BeancountQuerySubmit($;$) {
|
|||
}
|
||||
$BEANCOUNT_QUERY{question} = $question;
|
||||
$BEANCOUNT_QUERY{format} = $format if defined $format;
|
||||
$BEANCOUNT_QUERY{getAllOutput} = $getAllOutput if defined $getAllOutput;
|
||||
(tied %BEANCOUNT_QUERY)->shunlock;
|
||||
my $cnt = 0;
|
||||
while (not defined $BEANCOUNT_QUERY{fifoName}) {
|
||||
sleep 1;
|
||||
die "Unable to initiate query to beancount server\n" if ($cnt++ >= (5 * 60));
|
||||
if ($cnt++ >= (5 * 60)) {
|
||||
(tied %BEANCOUNT_QUERY)->shlock;
|
||||
$BEANCOUNT_QUERY{question} = undef;
|
||||
(tied %BEANCOUNT_QUERY)->shunlock;
|
||||
die "Unable to initiate query to beancount server\n" ;
|
||||
}
|
||||
}
|
||||
unless (-p $BEANCOUNT_QUERY{fifoName}) {
|
||||
(tied %BEANCOUNT_QUERY)->shlock;
|
||||
$BEANCOUNT_QUERY{question} = $BEANCOUNT_QUERY{format} = undef;
|
||||
$BEANCOUNT_QUERY{question} = $BEANCOUNT_QUERY{format} = $BEANCOUNT_QUERY{getAllOutput} = undef;
|
||||
(tied %BEANCOUNT_QUERY)->shunlock;
|
||||
die "Ceci n'est pas une pipe: BEANCOUNT_QUERY{fifoName}, $BEANCOUNT_QUERY{fifoName}:$!"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -7,27 +7,34 @@ 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/;
|
||||
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, $REPOSITORY_URL, $FIFO_DIR) = (0, undef, undef, undef, undef);
|
||||
my($VERBOSE, $BEANCOUNT_DIR, $LOAD_FILE, $BRANCH_NAME, $FIFO_DIR, $CLEAR_FILES, $GLUE) = (0, undef, undef, undef, undef, 1, 'BeAn');
|
||||
|
||||
GetOptions("verbose=i" => \$VERBOSE, "beancountDir=s" => \$BEANCOUNT_DIR,
|
||||
"loadFile=s" => \$LOAD_FILE, "repositoryURL=s" => \$REPOSITORY_URL, 'fifoDir=s' => \$FIFO_DIR);
|
||||
GetOptions("verbose=i" => \$VERBOSE, "beancountDir=s" => \$BEANCOUNT_DIR, 'glue=s' => \$GLUE, 'clearFiles!', \$CLEAR_FILES,
|
||||
"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 [ --repositoryURL=URL_OF_REPOSITORY --verbose=N ]\n";
|
||||
print STDERR "usage: $0 --loadFile=/path/to/file.beancount --beancountDir=/path/to/beancountdir --fifoDir=/path/to/directory/for/fifos [ --glue=FOUR_CHAR_STRING --branchName=BRANCH_NAME --verbose=N ]\n";
|
||||
print STDERR "\n $_[0]\n";
|
||||
exit 2;
|
||||
}
|
||||
|
|
@ -41,23 +48,64 @@ 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);
|
||||
|
||||
if (defined $REPOSITORY_URL) {
|
||||
UsageAndExit("if --repositoryURL is provided, $BEANCOUNT_DIR must be a checkout of a Git repository, but there is no $BEANCOUNT_DIR/.git/config.")
|
||||
unless (-r '.git/config');
|
||||
UsageAndExit("glue must be at exactly four characters")
|
||||
unless (defined $GLUE and length($GLUE) == 4);
|
||||
|
||||
open(my $gitFH, "<", ".git/config");
|
||||
my $repoString;
|
||||
while (my $line = <$gitFH>) {
|
||||
chomp $line;
|
||||
$repoString = $1
|
||||
if $line =~ /^\s*url\s*=\s*(\S+)\s*$/;
|
||||
}
|
||||
close $gitFH;
|
||||
UsageAndExit("if --repositoryURL is provided, the checkout found in $BEANCOUNT_DIR must be of that repository, but .git/config does not list a URL.") unless defined $REPOSITORY_URL;
|
||||
UsageAndExit("if --repositoryURL is provided, the checkout found in $BEANCOUNT_DIR must be of that repository, but it instead appears to be a checkout of $repoString.")
|
||||
unless ($repoString eq $REPOSITORY_URL);
|
||||
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,
|
||||
|
|
@ -65,13 +113,13 @@ my %options = (
|
|||
destroy => 'yes',
|
||||
);
|
||||
my %query;
|
||||
tie %query, 'IPC::Shareable', $glue, { %options } or
|
||||
die "server: tie failed for $glue\n";
|
||||
tie %query, 'IPC::Shareable', $GLUE, { %options } or
|
||||
die "server: tie failed for $GLUE\n";
|
||||
|
||||
%query = ();
|
||||
|
||||
my %beancountData;
|
||||
tie %beancountData, 'IPC::Shareable', $glue, { %options } or
|
||||
tie %beancountData, 'IPC::Shareable', $GLUE, { %options } or
|
||||
die "server: tie failed\n";
|
||||
|
||||
my ($currentFormat, $runningBeanQuery);
|
||||
|
|
@ -81,37 +129,65 @@ sub StartRunningBeanQuery {
|
|||
$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 });
|
||||
} elsif ($CLEAR_FILES) {
|
||||
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 > 2;
|
||||
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 > 2;
|
||||
print STDERR "fifo still active; locking to clear it..." if $VERBOSE > 5;
|
||||
(tied %query)->shlock;
|
||||
print STDERR "clearing fifo, $query{fifoName}..." if $VERBOSE > 2;
|
||||
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 > 2;
|
||||
print STDERR "fifo cleared & lock released." if $VERBOSE > 5;
|
||||
}
|
||||
print STDERR "sleep for 2 seconds\n" if $VERBOSE > 2;
|
||||
print STDERR "sleep for 2 seconds\n" if $VERBOSE > 5;
|
||||
sleep 2;
|
||||
next;
|
||||
} elsif ($query{question} !~ /^[\,\=\~\-\@\w.\s\"\'\_\(\)\<\>\*\.\!]+$/) {
|
||||
# } 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");
|
||||
|
|
@ -124,7 +200,8 @@ while (1) {
|
|||
$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} and $query{format} ne 'text') {
|
||||
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;
|
||||
|
|
@ -132,6 +209,18 @@ while (1) {
|
|||
(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;
|
||||
|
|
@ -141,27 +230,31 @@ while (1) {
|
|||
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 > 1;
|
||||
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 > 1;
|
||||
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 beginning write to it." if $VERBOSE > 1;
|
||||
my($seenSeperator, $prevLine) = (0, "");
|
||||
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*$/) {
|
||||
} elsif (($currentFormat eq 'text' and $line =~ /^\s*[\-\s]+\s*$/)
|
||||
or ($currentFormat eq 'csv' and $line =~ /^\s*(\S+,)*\S+\s*$/)){
|
||||
$seenSeperator = 1;
|
||||
}
|
||||
$prevLine = $line;
|
||||
|
|
|
|||
Loading…
Reference in a new issue