From 46fdd01ccd92a550c19a07e4a4902b4ed5a56a27 Mon Sep 17 00:00:00 2001
From: Pragmatic Software <pragma78@gmail.com>
Date: Sun, 6 Feb 2022 11:33:21 -0800
Subject: [PATCH] compiler_vm: make guest debugging output less verbose

---
 applets/compiler_vm/guest/bin/start-guest     |  58 ++--
 .../guest/lib/Languages/_c_base.pm            |   4 +-
 .../guest/lib/Languages/_default.pm           | 300 +++++++++---------
 3 files changed, 182 insertions(+), 180 deletions(-)

diff --git a/applets/compiler_vm/guest/bin/start-guest b/applets/compiler_vm/guest/bin/start-guest
index d93bbdcb..0cd73b8d 100755
--- a/applets/compiler_vm/guest/bin/start-guest
+++ b/applets/compiler_vm/guest/bin/start-guest
@@ -11,6 +11,7 @@ use English;
 use Encode;
 use File::Basename;
 use JSON::XS;
+use Data::Dumper;
 
 my $USERNAME = 'vm';   # variable for easier string interpolation
 
@@ -22,12 +23,12 @@ use constant {
     OUTPUT    => '/dev/stdout',
 };
 
+my $USE_LOCAL = $ENV{'CC_LOCAL'} // 0;
+
 use lib MOD_DIR;
 
 my %languages;
 
-my $USE_LOCAL = $ENV{'CC_LOCAL'};
-
 sub load_modules {
     my @files = glob MOD_DIR . "/*.pm";
     foreach my $mod (@files){
@@ -42,7 +43,7 @@ sub load_modules {
 sub run_server {
     my ($input, $output, $heartbeat);
 
-    if(not defined $USE_LOCAL or $USE_LOCAL == 0) {
+    if (not $USE_LOCAL) {
         # set serial to 115200 baud instead of 9600
         system('stty -F ' . SERIAL . ' 115200');
 
@@ -65,15 +66,14 @@ sub run_server {
     my $pid = fork;
     die "Fork failed: $!" if not defined $pid;
 
-    if($pid == 0) {
-        my $buffer = "";
-        my $length = 4096;
+    if ($pid == 0) {
+        my $buffer = '';
         my $line;
         my $total_read = 0;
 
         while (1) {
             print "Waiting for input...\n";
-            my $ret = sysread($input, my $buf, $length);
+            my $ret = sysread($input, my $buf, 16384);
 
             if (not defined $ret) {
                 print "Error reading: $!\n";
@@ -83,7 +83,7 @@ sub run_server {
             $total_read += $ret;
 
             if ($ret == 0) {
-                print "input  ded?\n";
+                print "Input closed; exiting...\n";
                 print "got buffer [$buffer]\n";
                 exit;
             }
@@ -92,30 +92,26 @@ sub run_server {
             print "read $ret bytes [$total_read so far] [$buf]\n";
             $buffer.= $buf;
 
-            if ($buffer =~ s/\s*:end:\s*$//m) {
-                $line = $buffer;
-                $buffer = "";
-                $total_read = 0;
-            } else {
-                next;
-            }
+            next if $buffer !~ s/\s*:end:\s*$//m;
 
+            $line = $buffer;
             chomp $line;
 
+            $buffer = '';
+            $total_read = 0;
+
+            $line = encode('UTF-8', $line);
+
             print "-" x 40, "\n";
             print "Got [$line]\n";
 
-            $line = encode('UTF-8', $line);
             my $compile_in = decode_json($line);
 
-            $compile_in->{arguments} //= '';
-            $compile_in->{input} //= '';
-
-            print "Attempting compile [$compile_in->{lang}] ...\n";
-
-            use Data::Dumper;
             print Dumper $compile_in;
 
+            $compile_in->{arguments} //= '';
+            $compile_in->{input}     //= '';
+
             my $pid = fork;
 
             if (not defined $pid) {
@@ -125,6 +121,7 @@ sub run_server {
 
             if ($pid == 0) {
                 my ($uid, $gid, $home) = (getpwnam $USERNAME)[2, 3, 7];
+
                 if (not $uid and not $gid) {
                     print "Could not find user $USERNAME: $!\n";
                     exit;
@@ -153,15 +150,19 @@ sub run_server {
                 $EGID = "$gid $gid";
                 $EUID = $UID = $uid;
 
+                chdir("/home/$USERNAME");
+
                 my $result = interpret(%$compile_in);
 
                 $GID = 0;
                 $UID = 0;
 
                 my $compile_out = { result => $result };
+
                 my $json = encode_json($compile_out);
 
-                print "Done compiling; result: [$result] [$json]\n";
+                print "Done compiling: $json\n";
+
                 print $output "result:$json\n";
                 print $output "result:end\n";
 
@@ -175,9 +176,12 @@ sub run_server {
                 exit;
             } else {
                 waitpid $pid, 0;
+
+                # kill any left-over processes started by $USERNAME
+                system("pkill -u $USERNAME");
             }
 
-            if(not defined $USE_LOCAL or $USE_LOCAL == 0) {
+            if (not $USE_LOCAL) {
                 print "=" x 40, "\n";
                 next;
             } else {
@@ -201,18 +205,12 @@ sub interpret {
 
     $h{lang} = '_default' if not exists $languages{$h{lang}};
 
-    chdir("/home/$USERNAME");
-
     my $mod = $h{lang}->new(%h);
 
     $mod->preprocess;
 
-    #    print "after preprocess: ", Dumper $mod, "\n";
-
     $mod->postprocess if not $mod->{error} and not $mod->{done};
 
-    # print "after postprocess: ", Dumper $mod, "\n";
-
     if (exists $mod->{no_output} or not length $mod->{output}) {
         if ($h{factoid}) {
             $mod->{output} = "";
diff --git a/applets/compiler_vm/guest/lib/Languages/_c_base.pm b/applets/compiler_vm/guest/lib/Languages/_c_base.pm
index 63b90092..8e1de548 100755
--- a/applets/compiler_vm/guest/lib/Languages/_c_base.pm
+++ b/applets/compiler_vm/guest/lib/Languages/_c_base.pm
@@ -12,10 +12,8 @@ use parent '_default';
 sub preprocess {
   my $self = shift;
 
-  my $input = $self->{input};
-  $input = "" if not defined $input;
+  my $input = $self->{input} // '';
 
-  print "writing input [$input]\n";
   open(my $fh, '>', '.input');
   print $fh "$input\n";
   close $fh;
diff --git a/applets/compiler_vm/guest/lib/Languages/_default.pm b/applets/compiler_vm/guest/lib/Languages/_default.pm
index 4f7a77f9..294a30c1 100755
--- a/applets/compiler_vm/guest/lib/Languages/_default.pm
+++ b/applets/compiler_vm/guest/lib/Languages/_default.pm
@@ -9,85 +9,91 @@ use warnings;
 use strict;
 
 use IPC::Run qw/run timeout/;
+
 use Data::Dumper;
 
+$Data::Dumper::Terse    = 1;
+$Data::Dumper::Sortkeys = 1;
+$Data::Dumper::Useqq    = 1;
+
 sub new {
-  my ($class, %conf) = @_;
-  my $self = bless {}, $class;
+    my ($class, %conf) = @_;
+    my $self = bless {}, $class;
 
-  $self->{debug}         = $conf{debug} // 0;
-  $self->{sourcefile}    = $conf{sourcefile};
-  $self->{execfile}      = $conf{execfile};
-  $self->{code}          = $conf{code};
-  $self->{cmdline}       = $conf{cmdline};
-  $self->{input}         = $conf{input};
-  $self->{date}          = $conf{date};
-  $self->{arguments}     = $conf{arguments};
-  $self->{factoid}       = $conf{factoid};
-  $self->{'persist-key'} = $conf{'persist-key'};
+    $self->{debug}         = $conf{debug} // 0;
+    $self->{sourcefile}    = $conf{sourcefile};
+    $self->{execfile}      = $conf{execfile};
+    $self->{code}          = $conf{code};
+    $self->{cmdline}       = $conf{cmdline};
+    $self->{input}         = $conf{input};
+    $self->{date}          = $conf{date};
+    $self->{arguments}     = $conf{arguments};
+    $self->{factoid}       = $conf{factoid};
+    $self->{'persist-key'} = $conf{'persist-key'};
 
-  $self->initialize(%conf);
-  return $self;
+    $self->initialize(%conf);
+    return $self;
 }
 
 sub initialize {
-  my ($self, %conf) = @_;
+    my ($self, %conf) = @_;
 }
 
 sub preprocess {
-  my $self = shift;
+    my $self = shift;
 
-  open(my $fh, '>', $self->{sourcefile}) or die $!;
-  binmode($fh, ':utf8');
-  print $fh $self->{code} . "\n";
-  close $fh;
+    open(my $fh, '>', $self->{sourcefile}) or die $!;
+    binmode($fh, ':utf8');
+    print $fh $self->{code} . "\n";
+    close $fh;
 
-  print "Executing [$self->{cmdline}] with args [$self->{arguments}]\n";
+    my $quoted_args = '';
 
-  my @args = $self->split_line($self->{arguments}, strip_quotes => 1, preserve_escapes => 0);
+    if (length $self->{arguments}) {
+        my @args = $self->split_line($self->{arguments}, strip_quotes => 1, preserve_escapes => 0);
 
-  my $quoted_args = '';
+        foreach my $arg (@args) {
+            $arg =~ s/'/'"'"'/g;
+            $quoted_args .= "'$arg' ";
+        }
+    }
 
-  foreach my $arg (@args) {
-      $arg =~ s/'/'"'"'/g;
-      $quoted_args .= "'$arg' ";
-  }
+    $self->{input} = "ulimit -f 2000; ulimit -t 8; ulimit -u 200; $self->{cmdline} $quoted_args";
 
-  $self->{input} = "ulimit -f 2000; ulimit -t 8; ulimit -u 200; $self->{cmdline} $quoted_args";
+    my ($retval, $stdout, $stderr) = $self->execute(60, $self->{input}, '/bin/sh');
 
-  my ($retval, $stdout, $stderr) = $self->execute(60, $self->{input}, '/bin/sh');
-
-  $self->{output} = $stderr;
-  $self->{output} .= ' ' if length $self->{output};
-  $self->{output} .= $stdout;
-  $self->{error}  = $retval;
+    $self->{output} = $stderr;
+    $self->{output} .= ' ' if length $self->{output};
+    $self->{output} .= $stdout;
+    $self->{error}  = $retval;
 }
 
-sub postprocess {
-  my $self = shift;
-}
+sub postprocess {}
 
 sub execute {
-  my ($self, $timeout, $stdin, @cmdline) = @_;
+    my ($self, $timeout, $stdin, @cmdline) = @_;
 
-  $stdin //= '';
-  print "execute($timeout) [$stdin] ", Dumper \@cmdline, "\n";
+    $stdin //= '';
+
+    print "execute ($timeout) [$stdin] @cmdline\n";
+
+    my ($exitval, $stdout, $stderr) = eval {
+        my ($stdout, $stderr);
+        run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout);
+        my $exitval = $? >> 8;
+        return ($exitval, $stdout, $stderr);
+    };
+
+    if (my $exception = $@) {
+        $exception = "[Timed-out]" if $exception =~ m/timeout on timer/;
+        ($exitval, $stdout, $stderr) = (-1, '', $exception);
+    }
+
+    $Data::Dumper::Indent = 0;
+    print "exitval $exitval stderr [", Dumper($stderr), "] stdout [", Dumper($stdout), "]\n";
+    $Data::Dumper::Indent = 1;
 
-  my ($exitval, $stdout, $stderr) = eval {
-    my ($stdout, $stderr);
-    run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout);
-    my $exitval = $? >> 8;
     return ($exitval, $stdout, $stderr);
-  };
-
-  if ($@) {
-    my $error = $@;
-    $error = "[Timed-out]" if $error =~ m/timeout on timer/;
-    ($exitval, $stdout, $stderr) = (-1, '', $error);
-  }
-
-  print "exitval $exitval stdout [$stdout]\nstderr [$stderr]\n";
-  return ($exitval, $stdout, $stderr);
 }
 
 # splits line into quoted arguments while preserving quotes.
@@ -96,111 +102,111 @@ sub execute {
 # handles unbalanced quotes gracefully by treating them as
 # part of the argument they were found within.
 sub split_line {
-  my ($self, $line, %opts) = @_;
+    my ($self, $line, %opts) = @_;
 
-  my %default_opts = (
-    strip_quotes => 0,
-    keep_spaces => 0,
-    preserve_escapes => 1,
-  );
+    my %default_opts = (
+        strip_quotes => 0,
+        keep_spaces => 0,
+        preserve_escapes => 1,
+    );
 
-  %opts = (%default_opts, %opts);
+    %opts = (%default_opts, %opts);
 
-  my @chars = split //, $line;
+    my @chars = split //, $line;
 
-  my @args;
-  my $escaped = 0;
-  my $quote;
-  my $token = '';
-  my $ch = ' ';
-  my $last_ch;
-  my $next_ch;
-  my $i = 0;
-  my $pos;
-  my $ignore_quote = 0;
-  my $spaces = 0;
+    my @args;
+    my $escaped = 0;
+    my $quote;
+    my $token = '';
+    my $ch = ' ';
+    my $last_ch;
+    my $next_ch;
+    my $i = 0;
+    my $pos;
+    my $ignore_quote = 0;
+    my $spaces = 0;
 
-  while (1) {
-    $last_ch = $ch;
+    while (1) {
+        $last_ch = $ch;
 
-    if ($i >= @chars) {
-      if (defined $quote) {
-        # reached end, but unbalanced quote... reset to beginning of quote and ignore it
-        $i = $pos;
-        $ignore_quote = 1;
-        $quote = undef;
-        $last_ch = ' ';
-        $token = '';
-      } else {
-        # add final token and exit
-        push @args, $token if length $token;
-        last;
-      }
-    }
+        if ($i >= @chars) {
+            if (defined $quote) {
+                # reached end, but unbalanced quote... reset to beginning of quote and ignore it
+                $i = $pos;
+                $ignore_quote = 1;
+                $quote = undef;
+                $last_ch = ' ';
+                $token = '';
+            } else {
+                # add final token and exit
+                push @args, $token if length $token;
+                last;
+            }
+        }
 
-    $ch = $chars[$i++];
-    $next_ch = $chars[$i];
+        $ch = $chars[$i++];
+        $next_ch = $chars[$i];
 
-    $spaces = 0 if $ch ne ' ';
+        $spaces = 0 if $ch ne ' ';
+
+        if ($escaped) {
+            if ($opts{preserve_escapes}) {
+                $token .= "\\$ch";
+            } else {
+                $token .= $ch;
+            }
+            $escaped = 0;
+            next;
+        }
+
+        if ($ch eq '\\') {
+            $escaped = 1;
+            next;
+        }
+
+        if (defined $quote) {
+            if ($ch eq $quote and (not defined $next_ch or $next_ch =~ /[\s,:;})\].+=]/)) {
+                # closing quote
+                $token .= $ch unless $opts{strip_quotes};
+                push @args, $token;
+                $quote = undef;
+                $token = '';
+            } else {
+                # still within quoted argument
+                $token .= $ch;
+            }
+            next;
+        }
+
+        if (($last_ch =~ /[\s:{(\[.+=]/) and not defined $quote and ($ch eq "'" or $ch eq '"')) {
+            if ($ignore_quote) {
+                # treat unbalanced quote as part of this argument
+                $token .= $ch;
+                $ignore_quote = 0;
+            } else {
+                # begin potential quoted argument
+                $pos = $i - 1;
+                $quote = $ch;
+                $token .= $ch unless $opts{strip_quotes};
+            }
+            next;
+        }
+
+        if ($ch eq ' ') {
+            if (++$spaces > 1 and $opts{keep_spaces}) {
+                $token .= $ch;
+                next;
+            } else {
+                push @args, $token if length $token;
+                $token = '';
+                next;
+            }
+        }
 
-    if ($escaped) {
-      if ($opts{preserve_escapes}) {
-        $token .= "\\$ch";
-      } else {
         $token .= $ch;
-      }
-      $escaped = 0;
-      next;
     }
 
-    if ($ch eq '\\') {
-      $escaped = 1;
-      next;
-    }
-
-    if (defined $quote) {
-      if ($ch eq $quote and (not defined $next_ch or $next_ch =~ /[\s,:;})\].+=]/)) {
-        # closing quote
-        $token .= $ch unless $opts{strip_quotes};
-        push @args, $token;
-        $quote = undef;
-        $token = '';
-      } else {
-        # still within quoted argument
-        $token .= $ch;
-      }
-      next;
-    }
-
-    if (($last_ch =~ /[\s:{(\[.+=]/) and not defined $quote and ($ch eq "'" or $ch eq '"')) {
-      if ($ignore_quote) {
-        # treat unbalanced quote as part of this argument
-        $token .= $ch;
-        $ignore_quote = 0;
-      } else {
-        # begin potential quoted argument
-        $pos = $i - 1;
-        $quote = $ch;
-        $token .= $ch unless $opts{strip_quotes};
-      }
-      next;
-    }
-
-    if ($ch eq ' ') {
-      if (++$spaces > 1 and $opts{keep_spaces}) {
-        $token .= $ch;
-        next;
-      } else {
-        push @args, $token if length $token;
-        $token = '';
-        next;
-      }
-    }
-
-    $token .= $ch;
-  }
-
-  return @args;
+    return @args;
 }
 
 1;