tests/common.scm (start-server/exec): New procedure

* tests/common.scm (start-server/exec): New procedure.
* tests/client-server.scm ("open-remote-pipe", "open-remote-pipe*")
  ("open-remote-input-pipe"): Use it.

1 files changed, 28 insertions, 0 deletions

diff --git a/tests/common.scm b/tests/common.scm
index 82e0e1e..1f93d65 100644
--- a/tests/common.scm
+++ b/tests/common.scm
@@ -46,6 +46,7 @@
             make-libssh-log-printer
             start-server/dt-test
             start-server/dist-test
+            start-server/exec
             setup-libssh-logging!
             setup-error-logging!
             setup-test-suite-logging!
@@ -166,6 +167,33 @@
                (message-reply-success msg)))))))
   (primitive-exit))
 
+(define (start-server/exec server)
+  "Start SERVER for a command execution test."
+  (server-listen server)
+  (let ((session (server-accept server))
+        (channel #f))
+    (server-handle-key-exchange session)
+    (make-session-loop session
+      (let ((msg-type (message-get-type msg)))
+        (case (car msg-type)
+          ((request-channel-open)
+           (set! channel (message-channel-request-open-reply-accept msg)))
+          ((request-channel)
+           (if (equal? (cadr msg-type) 'channel-request-exec)
+               (let ((cmd (exec-req:cmd (message-get-req msg))))
+                 (cond
+                  ((string=? cmd "ping")
+                   (write-line "pong" channel)
+                   (message-reply-success msg))
+                  ((string=? cmd "uname") ; For exit status testing
+                   (message-reply-success msg)
+                   (channel-request-send-exit-status channel 0)
+                   (message-reply-success msg))))
+               (message-reply-success msg)))
+          (else
+           (message-reply-success msg)))))
+    (primitive-exit)))
+
 (define (start-server/dist-test server)
   (server-listen server)
   (let ((session (server-accept server)))