[Help-smalltalk] [PATCH] gst-remote tool

[Paolo Bonzini]

This patch implements the beginnings of a remote control tool for GNU 
Smalltalk.  It is based on Mike Anderson's GSTI project from 
http://www.mail-archive.com/address@hidden/msg00339.html though 
in practice I rewrote all the code.  Still, the credit for the 
multiplexing transcript idea, and especially for using the Compiler 
package to have a working multiplexing transcript in the first place 
(!), goes to him.

I like a lot the way options like --snapshot, --pid, --kill are 
implemented: instead of having a complicated protocol, I just send 
Smalltalk commands like "ObjectMemory quit" or "Smalltalk getpid 
printNl".  getpid(2) is accessed via DLD.

I found a typo in Compiler; that's been backported to the 3.0 branch.

Startup is slow mostly because the TCP package has to be loaded.  You 
can improve that with a pre-prepared image that has the TCP package in 
it; I'll see if I can do something else.

There is still no interface to Swazoo, but that's a minor improvement 
compared to having the tool in the first place.

Paolo

diff --git a/Makefile.am b/Makefile.am
index 013a7fe..0e03028 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -118,7 +118,8 @@ gst_tool_LDADD = libgst/libgst.la lib-src/library.la
 gst_tool_DEPENDENCIES = libgst/libgst.la lib-src/library.la
 gst_tool_LDFLAGS = -export-dynamic
 
-GST_EXTRA_TOOLS = gst-reload gst-sunit gst-blox gst-package gst-convert gst-doc
+GST_EXTRA_TOOLS = gst-reload gst-sunit gst-blox gst-package gst-convert \
+       gst-doc gst-remote
 
 uninstall-local::
        @for i in gst-load $(GST_EXTRA_TOOLS); do \
diff --git a/NEWS b/NEWS
index 097363e..03b552f 100644
--- a/NEWS
+++ b/NEWS
@@ -8,8 +8,12 @@ o   ObjectMemory>>#snapshot and ObjectMemory>>#snapshot: 
return false in
     snapshot.  Note that this does not apply to CallinProcesses, since
     those are stopped in saved images (will this be true in 3.1?).
 
+o   New tool gst-remote allows remote control of a GNU Smalltalk VM
+    via a TCP socket.
+
 o   Unbuffered sockets available from class TCP.StreamSocket.
 
+
 New goodies:
 
 o   Swazoo web server
diff --git a/kernel/ExcHandling.st b/kernel/ExcHandling.st
index ae2a9bd..b758de0 100644
--- a/kernel/ExcHandling.st
+++ b/kernel/ExcHandling.st
@@ -751,8 +751,7 @@ Object extend [
 
        <category: 'built ins'>
        | debugger debuggerClass context |
-       Transcript initialize.
-       stdout flush.
+       Transcript flush.
        debugger := Processor activeDebugger.
        debugger isNil ifFalse: [^debugger stopInferior: message].
        debuggerClass := thisContext debuggerClass.
@@ -761,7 +760,7 @@ Object extend [
 
        "Default behavior - print backtrace"
        RegressionTesting ifFalse: [self basicPrint].
-       stdout
+       Transcript
            nextPutAll: ' error: ';
            display: message;
            nl.
@@ -771,7 +770,6 @@ Object extend [
                [context isInternalExceptionHandlingContext] 
                    whileTrue: [context := context parentContext].
                context backtraceOn: stdout].
-       stdout flush.
        ContextPart unwind
     ]
 
diff --git a/packages/stinst/compiler/StartCompiler.st 
b/packages/stinst/compiler/StartCompiler.st
index 133e109..06367b7 100644
--- a/packages/stinst/compiler/StartCompiler.st
+++ b/packages/stinst/compiler/StartCompiler.st
@@ -318,7 +318,7 @@ Behavior extend [
        ^STInST.STEvaluationDriver new 
            parseSmalltalk: aString
            with: self evaluatorClass
-           errorBlock: 
+           onError: 
                [:l :m | 
                ^aBlock 
                    value: 'a Smalltalk String'
diff --git a/gst-tool.c b/gst-tool.c
index c2bec1f..8b3aeb2 100644
--- a/gst-tool.c
+++ b/gst-tool.c
@@ -63,10 +63,16 @@
 #include <stdio.h>
 #include <errno.h>
 
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
 const char *program_name;
 const char *kernel_dir;
 const char *image_file;
 int flags = GST_NO_TTY;
+int run_as_daemon;
+int usage;
 
 struct tool {
   const char *name;
@@ -120,6 +126,12 @@ struct tool tools[] = {
         -n|--namespace: -o|--output: --kernel-directory:",
     NULL
   },
+  {
+    "gst-remote", "scripts/Remote.st",
+    "-h|--help --version --daemon --server -p|--port -f|--file: -e|--eval: \
+        --pid --kill --snapshot:: -I|--image-file: --kernel-directory:",
+    NULL
+  },
   { NULL, NULL, NULL, NULL }
 };
 
@@ -243,7 +255,61 @@ parse_option (int short_opt, const char *long_opt, const 
char *arg)
        option_error ("duplicate --kernel-directory option");
       kernel_dir = arg;
     }
+
+  if (long_opt && !strcmp (long_opt, "daemon"))
+    {
+#ifdef HAVE_FORK
+      run_as_daemon = 1;
+#else
+      fprintf (stderr, "Daemon operation not supported.");
+      exit (77);
+#endif
+    }
+
+  if (long_opt && !strcmp (long_opt, "version"))
+    usage = 1;
+
+  if (short_opt == 'h'
+      || (long_opt && !strcmp (long_opt, "help")))
+    usage = 1;
+}
+
+#ifdef HAVE_FORK
+static void
+fork_daemon (void)
+{
+  int child_pid;
+
+#ifdef SIGHUP
+  signal (SIGHUP, SIG_IGN);
+#endif
+
+  child_pid = fork();
+  if (child_pid < 0)
+    {
+      perror("Failed to fork daemon");
+      exit(1);
+    }
+
+  /* Stop parent.  */
+  if (child_pid != 0)
+    exit (0);
+
+  /* Detach and spawn server.
+     Create a new SID for the child process */
+#ifdef HAVE_SETSID
+  if (setsid() < 0)
+    {
+      perror("setsid failed");
+      exit(1);
+    }
+#endif
+
+#ifdef SIGHUP
+  signal (SIGHUP, SIG_DFL);
+#endif
 }
+#endif
 
 int
 parse_short_options (const char *name, const char *arg)
@@ -395,6 +461,11 @@ main(int argc, const char **argv)
   setup_options (tools[i].options);
   parse_options (&argv[1]);
 
+#ifdef HAVE_FORK
+  if (run_as_daemon && !usage)
+    fork_daemon ();
+#endif
+
   if (tools[i].force_opt)
     {
       smalltalk_argv = alloca (sizeof (const char *) * (argc + 1));
diff --git a/scripts/Remote.st b/scripts/Remote.st
new file mode 100644
index 0000000..d4a29ab
--- /dev/null
+++ b/scripts/Remote.st
@@ -0,0 +1,203 @@
+"======================================================================
+|
+|   GNU Smalltalk remote control script
+|
+|
+ ======================================================================"
+
+
+"======================================================================
+|
+| Copyright 1999, 2000, 2002, 2004 Free Software Foundation, Inc.
+| Written by Paolo Bonzini.
+|
+| This file is part of GNU Smalltalk.
+|
+| GNU Smalltalk is free software; you can redistribute it and/or modify it
+| under the terms of the GNU General Public License as published by the Free
+| Software Foundation; either version 2, or (at your option) any later version.
+| 
+| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
+| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+| FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
+| details.
+| 
+| You should have received a copy of the GNU General Public License along with
+| GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
+| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.  
+|
+ ======================================================================"
+
+PackageLoader fileInPackage: 'TCP'.
+DLD addLibrary: 'libc'.
+
+SystemDictionary extend [
+    getpid [
+        <cCall: 'getpid' returning: #int args: #()>
+    ]
+]
+
+TextCollector subclass: MultiplexingTextCollector [
+    | default outputs |
+    initialize [
+       outputs := LookupTable new.
+       super initialize
+    ]
+
+    register: aStream [
+       semaphore critical: [ outputs at: Processor activeProcess put: aStream ]
+    ]
+
+    unregister [
+       semaphore critical: [ outputs removeKey: Processor activeProcess ]
+    ]
+
+    primNextPutAll: aString [
+        | dest |
+        dest := outputs at: Processor activeProcess ifAbsent: [ nil ].
+       dest isNil
+           ifTrue: [ super primNextPutAll: aString ]
+           ifFalse: [ dest nextPutAllFlush: aString ]
+    ]
+]
+
+| helpString commands server port host |
+commands := OrderedCollection new.
+server := false.
+port := 5432.
+host := nil.
+
+helpString :=
+'Usage:
+    gst-load [ flag ... ] package ...
+
+Options:
+       --daemon           start background server
+       --server           start daemon
+    -p --port=PORT        connect/listen on given port (default 5432)
+    -f --file=FILE        file in FILE
+    -e --eval=CODE        evaluate CODE
+       --kill             kill daemon
+       --snapshot[=FILE]  save image
+       --pid              print daemon pid
+    -h --help             show this message
+       --version          print version information and exit
+'.
+
+"Parse the command-line arguments."
+Smalltalk
+    arguments: '-h|--help --version --daemon --server -p|--port -f|--file:
+               -e|--eval: --pid --kill --snapshot::
+               -I|--image: --kernel-directory:'
+    do: [ :opt :arg |
+
+    opt = 'help' ifTrue: [
+       helpString displayOn: stdout.
+       ObjectMemory quit: 0 ].
+
+    opt = 'version' ifTrue: [
+       ('gst-remote - %1' % {Smalltalk version}) displayNl.
+       ObjectMemory quit: 0 ].
+
+    opt = 'daemon' ifTrue: [
+       server := true ].
+
+    opt = 'server' ifTrue: [
+       server := true ].
+
+    opt = 'port' ifTrue: [
+       port := arg asInteger ].
+
+    opt = 'file' ifTrue: [
+       commands add: 'FileStream fileIn: ',
+                     (Directory append: arg to: Directory working) storeString 
].
+
+    opt = 'eval' ifTrue: [
+       commands add: arg ].
+
+    opt = 'pid' ifTrue: [
+       commands add: 'Smalltalk getpid printNl' ].
+
+    opt = 'kill' ifTrue: [
+       commands add: 'ObjectMemory quit: 0' ].
+
+    opt = 'snapshot' ifTrue: [
+       arg isNil
+           ifTrue: [ commands add: 'ObjectMemory snapshot' ]
+           ifFalse: [ commands add: 'ObjectMemory snapshot: ',
+                                    (Directory append: arg to: Directory 
working) storeString ] ].
+
+    opt isNil ifTrue: [
+       host isNil ifFalse: [
+           helpString displayOn: stderr.
+           ObjectMemory quit: 1 ].
+       host := arg ] ]
+
+    ifError: [
+       helpString displayOn: stderr.
+       ObjectMemory quit: 1 ].
+
+server ifTrue: [
+    PackageLoader fileInPackage: 'Compiler'.
+    "PackageLoader fileInPackage: 'Swazoo'."
+    s := TCP.ServerSocket port: port bindTo: host.
+    Transcript := MultiplexingTextCollector message: Transcript message.
+    [
+       [
+           [
+               s waitForConnection.
+               conn := s accept.
+               [
+                   [ conn isPeerAlive ] whileTrue: [
+                       Transcript register: conn.
+                       Behavior
+                           evaluate: (conn upTo: $<0>)
+                           to: nil
+                           ifError: [ :fname :line :msg |
+                               conn nextPutAll: ('Error at line %1: %2
+' % { line. msg }) ].
+                       conn nextPut: $<0>; flush.
+                       Transcript unregister.
+                   ].
+                   [ conn close ] on: Error do: [ :ex | ex return ]
+               ] fork
+           ] repeat
+       ]
+           on: Error
+           do: [ :ex |
+               ('gst-remote server: ', ex messageText, '
+') displayOn: stderr.
+               ex pass.
+               ObjectMemory quit: 1 ].
+    ] fork.
+    Transcript nextPutAll: 'gst-remote server started.'; nl ].
+
+[
+    commands isEmpty ifFalse: [
+       s := host isNil
+           ifTrue: [ TCP.Socket remote: TCP.IPAddress anyLocalAddress port: 
port ]
+           ifFalse: [ TCP.Socket remote: host port: port ].
+       commands do: [ :each |
+           s nextPutAll: each; nextPut: $<0>; flush.
+           [ s peekFor: $<0> ] whileFalse: [
+               stdout nextPut: s next; flush.
+               s available
+                   ifFalse: [ stdout flush ].
+               s isPeerAlive
+                   ifFalse: [ self nextPutAll: 'gst-remote: server 
unavailable' ] ]
+       ].
+       s close ]
+]
+    on: Error
+    do: [ :ex |
+       s isPeerAlive ifFalse: [ s close. ex return ].
+        ('gst-remote: ', ex messageText, '
+') displayOn: stderr.
+        "ex pass."
+       server
+           ifTrue: [ stderr flush ]
+           ifFalse: [ ObjectMemory quit: 1 ] ].
+
+server
+    ifTrue: [ Processor activeProcess suspend ]
+    ifFalse: [ ObjectMemory quit ]