File: run-program.impure.lisp

package info (click to toggle)
sbcl 1%3A0.9.16.0-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 19,960 kB
  • ctags: 16,537
  • sloc: lisp: 231,164; ansic: 19,558; asm: 2,539; sh: 1,925; makefile: 308
file content (99 lines) | stat: -rw-r--r-- 3,432 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
;;;; various RUN-PROGRAM tests with side effects

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

(cl:in-package :cl-user)

;; Actually there's no real side-effect here. (But see below.) The
;; impurity we're avoiding is the sigchld handler that RUN-PROGRAM
;; sets up, which interfers with the manual unix process control done
;; by the test framework (sometimes the handler will manage to WAIT3 a
;; process before run-tests WAITPIDs it).

(let* ((process (sb-ext:run-program "/bin/cat" '() :wait nil
                                    :output :stream :input :stream))
       (out (process-input process))
       (in (process-output process)))
  (unwind-protect
       (loop for i from 0 to 255 do
             (write-byte i out)
             (force-output out)
             (assert (= (read-byte in) i)))
    (process-close process)))

;;; Test driving an external program (ed) through pipes wrapped in
;;; composite streams.

(require :sb-posix)

(defvar *tmpfile* "run-program-ed-test.tmp")

(with-open-file (f *tmpfile*
                   :direction :output
                   :if-exists :supersede)
  (write-line "bar" f))

(defun make-pipe ()
  (multiple-value-bind (in out) (sb-posix:pipe)
    (let ((input (sb-sys:make-fd-stream in
                                        :input t
                                        :external-format :ascii
                                        :buffering :none :name "in"))
          (output (sb-sys:make-fd-stream out
                                         :output t
                                         :external-format :ascii
                                         :buffering :none :name "out")))
      (make-two-way-stream input output))))

(defvar *in-pipe* (make-pipe))
(defvar *in* (make-synonym-stream '*in-pipe*))
(defvar *out-pipe* (make-pipe))
(defvar *out* (make-synonym-stream '*out-pipe*))

(defvar *ed*
  (run-program "/bin/ed" (list *tmpfile*) :input *in* :output *out* :wait nil))

(defun real-input (stream)
  (two-way-stream-input-stream (symbol-value (synonym-stream-symbol stream))))

(defun magic-read-line (stream)
  ;; KLUDGE 1: The otherwise out :buffering :none is worth nothing,
  (let ((input (real-input stream)))
    (with-output-to-string (s)
      ;; KLUDGE 2: Something funny going on with buffering, as plain
      ;; READ-CHAR will hang here waiting for the newline, also
      ;; -NO-HANG will return too early without the sleep.
      ;;
      ;; Shoot me now. --NS 2006-06-09
      (loop for c = (progn (sleep 0.2) (read-char-no-hang input))
         while (and c (not (eq #\newline c)))
         do (write-char c s)))))

(defun assert-ed (command response)
  (when command
    (write-line command *in*)
    (force-output *in*))
  (let ((got (magic-read-line *out*)))
    (unless (equal response got)
      (error "wanted ~S from ed, got ~S" response got)))
  *ed*)

(assert-ed nil "4")
(assert-ed ".s/bar/baz/g" "")
(assert-ed "w" "4")
(assert-ed "q" "")
(process-wait *ed*)

(with-open-file (f *tmpfile*)
  (assert (equal "baz" (read-line f))))

;(delete-file *tmp*)