Added facility for remote debugging

scsh/interaction/inspect-exception.scm

@@ -0,0 +1,34 @@
+;;; This file is part of the Scheme Untergrund Library.
+
+;;; Copyright (c) 2002-2003 by Martin Gasbichler.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;; From SUnet plus one more call/cc to capture the continuation of the error
+(define (with-fatal-and-capturing-error-handler* handler thunk)
+  (call-with-current-continuation
+   (lambda (accept)
+     ((call-with-current-continuation
+       (lambda (k)
+	 (with-handler 
+	  (lambda (condition more)
+	    (primitive-cwcc
+	     (lambda (condition-continuation)
+	       (if (error? condition)
+		   (call-with-current-continuation
+		    (lambda (decline)
+		      (k (lambda () 
+			   (handler condition condition-continuation decline))))))
+	       (more))))		; Keep looking for a handler.
+	  (lambda () (call-with-values thunk accept)))))))))
+
+(define (with-inspecting-handler port thunk)
+  (with-fatal-and-capturing-error-handler*
+   (lambda (condition condition-continuation more)
+     (let ((res
+	    (remote-repl "Welcome to the command processor of the remote scsh"
+			 condition-continuation
+			 port)))
+       ;; TODO: option to return to continuation of handler (by leaving out the with-continuation)
+       (with-continuation condition-continuation (lambda () res))))
+   thunk))

scsh/interaction/interfaces.scm

@@ -0,0 +1,9 @@
+(define-interface repls-interface
+  (export script-repl
+	  remote-repl))
+
+(define-interface inspect-exception-interface
+  (export with-inspecting-handler))
+
+(define-interface socket2stdports-interface
+  (export socket<->std-ports))

scsh/interaction/packages.scm

@@ -0,0 +1,23 @@
+(define-structure repls repls-interface
+  (open scheme-with-scsh
+	command-levels
+	command-processor
+	environments
+	formats
+	handle)
+  (files repl))
+
+(define-structure inspect-exception inspect-exception-interface
+					    
+  (open scheme-with-scsh
+	conditions
+	escapes
+	handle
+	repls)
+  (files inspect-exception))
+
+(define-structure socket2stdports socket2stdports-interface
+  (open scheme-with-scsh
+	handle
+	threads)
+  (files socket2stdport))

scsh/interaction/repl.scm

@@ -0,0 +1,88 @@
+;;; This file is part of the Scheme Untergrund Library.
+
+;;; Copyright (c) 2002-2003 by Martin Gasbichler.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+(define (bind-listen-accept protocol-family proc arg)
+      (let* ((sock (create-socket protocol-family socket-type/stream))
+	     (addr (cond ((= protocol-family
+			     protocol-family/internet)
+			  (let ((port (cond ((integer? arg) arg)
+					    ((string? arg)
+					     (service-info:port 
+					      (service-info arg "tcp")))
+					    (else
+					     (error "socket-connect: bad arg ~s"
+						    arg)))))
+			    (internet-address->socket-address internet-address/any
+							      arg)))
+			 ((= protocol-family
+			     protocol-family/unix)
+			  (unix-address->socket-address arg))
+			 (else 
+			  (error "bind-listen-accept: unsupported protocol-family ~s"
+				 protocol-family)))))
+	(set-socket-option sock level/socket socket/reuse-address #t)
+	(bind-socket sock addr)
+	(listen-socket sock 5)
+	(with-handler
+	 (lambda (condition more)
+	   (with-handler
+	    (lambda (condition ignore) (more))
+	    (lambda () (close-socket sock)))
+	   (more))
+	 (lambda ()
+	   (with-errno-handler
+	    ;; ECONNABORTED we just ignore
+	    ((errno packet)
+	     ((errno/connaborted) 'fick-dich-ins-knie))
+	    (call-with-values 
+	     (lambda () (accept-connection sock))
+	     proc))))))
+
+(define (remote-repl greeting focus-value port)
+  (let ((old-output (command-output))
+	(old-input (command-input))
+	(old-err (command-error-output)))
+    (bind-listen-accept
+     protocol-family/internet
+     (lambda (socket address)
+       (set-port-buffering (socket:outport socket) bufpol/none)
+       (set-port-buffering (socket:inport socket) bufpol/none)
+       (set-socket-option socket level/socket socket/oob-inline #t)
+       (set-socket-option socket level/socket socket/reuse-address #t)
+       (let ((res (script-repl greeting
+			       focus-value
+			       (socket:inport socket)
+			       (socket:outport socket)
+			       (socket:outport socket))))
+	 (with-handler
+	  (lambda (condition ignore) 'fick-dich-ins-knie)
+	  (lambda () (close-socket socket)))
+	 res))
+     port)))
+
+(define (script-repl greeting focus-value iport oport eport)
+  (with-interaction-environment
+   (environment-for-commands)
+   (lambda ()
+     (let* ((saved-user-context (user-context))
+	    (res
+	     (restart-command-processor
+	      'ignored-focus-value
+	      (user-context)
+	      (lambda ()
+		;; we need to redirect the ports of the command processor
+		(start-new-session saved-user-context
+				   iport
+				   oport
+				   eport
+				   focus-value
+				   #f)	;batch?
+		(display greeting (command-output))
+		(newline (command-output))
+		(display (focus-object) (command-output))
+		(newline (command-output))))))
+       (format (command-output) "Terminating command processor with value ~A ~%" res)
+       res))))

scsh/interaction/socket2stdport.scm

@@ -0,0 +1,33 @@
+;;; This file is part of the Scheme Untergrund Library.
+
+;;; Copyright (c) 2002-2003 by Martin Gasbichler.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+(define (socket<->std-ports host port)
+  (let ((s (socket-connect protocol-family/internet socket-type/stream host port)))
+    (set-port-buffering (socket:outport s) bufpol/none)
+    (set-port-buffering (socket:inport s) bufpol/none)
+    (spawn (lambda () (dynamic-wind
+		       (lambda () #f)
+		       (lambda ()
+			 (dup-port (socket:inport s) (current-output-port)))
+		       (lambda ()
+			 (close (socket:inport s))))))
+
+    (dynamic-wind
+     (lambda () #f)
+     (lambda ()
+       (dup-port (current-input-port) (socket:outport s)))
+     (lambda ()
+       (close s)))))
+
+
+(define (dup-port from to)
+  (let ((c (read-char from)))
+    (if (not (eof-object? c))
+	(begin 
+	  (display c to)
+	  (dup-port from to)))))
+
+