diff --git a/scsh/interaction/inspect-exception.scm b/scsh/interaction/inspect-exception.scm new file mode 100644 index 0000000..f7bb938 --- /dev/null +++ b/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)) diff --git a/scsh/interaction/interfaces.scm b/scsh/interaction/interfaces.scm new file mode 100644 index 0000000..4e0124e --- /dev/null +++ b/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)) diff --git a/scsh/interaction/packages.scm b/scsh/interaction/packages.scm new file mode 100644 index 0000000..f599ab4 --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/scsh/interaction/repl.scm b/scsh/interaction/repl.scm new file mode 100644 index 0000000..54ab52b --- /dev/null +++ b/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)))) diff --git a/scsh/interaction/socket2stdport.scm b/scsh/interaction/socket2stdport.scm new file mode 100644 index 0000000..bbe9f9a --- /dev/null +++ b/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))))) + +