[PATCH] gst-remote tool

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/help-smalltalk@.../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 ]

_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk

I attached an older version of the patch; I just want to point out that
the copyright notice in the committed file is:

| Copyright 2008 Free Software Foundation, Inc.
| Written by Paolo Bonzini and Mike Anderson.

Paolo


_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk