Glue for IPC now can be overridden via BeancountQueryInitialize()

Allow a single optional parameter to BeancountQueryInitialize() that
overrides the default glue used for the IPC::Sharable glue.

bean-query-cli.plx

@@ -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";

bean-query-daemon-lib.pl

@@ -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($;$) {
+sub BeancountQuerySubmit($;$$) {
-  my($question, $format) = @_;
+  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}:$!"
   }

bean-query-goofy-daemon.plx

@@ -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,
+GetOptions("verbose=i" => \$VERBOSE, "beancountDir=s" => \$BEANCOUNT_DIR, 'glue=s' => \$GLUE, 'clearFiles!', \$CLEAR_FILES,
-           "loadFile=s" => \$LOAD_FILE, "repositoryURL=s" => \$REPOSITORY_URL, 'fifoDir=s' => \$FIFO_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 [ --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("glue must be at exactly four characters")
-  UsageAndExit("if --repositoryURL is provided, $BEANCOUNT_DIR must be a checkout of a Git repository, but there is no $BEANCOUNT_DIR/.git/config.")
+  unless (defined $GLUE and length($GLUE) == 4);
-  unless (-r '.git/config');
 
-  open(my $gitFH, "<", ".git/config");
+my($tempRepository, $tempRepositoryDirectory);
-  my $repoString;
+
-  while (my $line = <$gitFH>) {
+sub CleanupEvertything {
-    chomp $line;
+  $tempRepository = undef if (defined $tempRepository);
-    $repoString = $1
+  $tempRepositoryDirectory = undef if (defined $tempRepositoryDirectory);
-      if $line =~ /^\s*url\s*=\s*(\S+)\s*$/;
+  StopRunningBeanQuery();
-  }
+  croak @_;
-  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;
+if (defined $BRANCH_NAME) {
-  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.")
+  my $absGitRepositoryDirectory = File::Spec->rel2abs( $BEANCOUNT_DIR );
-    unless ($repoString eq $REPOSITORY_URL);
+  $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
+tie %query, 'IPC::Shareable', $GLUE, { %options } or
-  die "server: tie failed for $glue\n";
+  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;
+    print STDERR "and began write to fifo." if $VERBOSE > 2;
-    my($seenSeperator, $prevLine) =  (0, "");
+    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;