tests/run-program.impure.lisp

   1 ;;;; various RUN-PROGRAM tests with side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (cl:in-package :cl-user)
  15
  16 ;; Actually there's no real side-effect here. (But see below.) The
  17 ;; impurity we're avoiding is the sigchld handler that RUN-PROGRAM
  18 ;; sets up, which interfers with the manual unix process control done
  19 ;; by the test framework (sometimes the handler will manage to WAIT3 a
  20 ;; process before run-tests WAITPIDs it).
  21
  22 (let* ((process (sb-ext:run-program "/bin/cat" '() :wait nil
  23                                     :output :stream :input :stream))
  24        (out (process-input process))
  25        (in (process-output process)))
  26   (unwind-protect
  27        (loop for i from 0 to 255 do
  28              (write-byte i out)
  29              (force-output out)
  30              (assert (= (read-byte in) i)))
  31     (process-close process)))
  32
  33 ;;; Test driving an external program (ed) through pipes wrapped in
  34 ;;; composite streams.
  35
  36 (require :sb-posix)
  37
  38 (defvar *tmpfile* "run-program-ed-test.tmp")
  39
  40 (with-open-file (f *tmpfile*
  41                    :direction :output
  42                    :if-exists :supersede)
  43   (write-line "bar" f))
  44
  45 (defun make-pipe ()
  46   (multiple-value-bind (in out) (sb-posix:pipe)
  47     (let ((input (sb-sys:make-fd-stream in
  48                                         :input t
  49                                         :external-format :ascii
  50                                         :buffering :none :name "in"))
  51           (output (sb-sys:make-fd-stream out
  52                                          :output t
  53                                          :external-format :ascii
  54                                          :buffering :none :name "out")))
  55       (make-two-way-stream input output))))
  56
  57 (defvar *in-pipe* (make-pipe))
  58 (defvar *in* (make-synonym-stream '*in-pipe*))
  59 (defvar *out-pipe* (make-pipe))
  60 (defvar *out* (make-synonym-stream '*out-pipe*))
  61
  62 (defvar *ed*
  63   (run-program "/bin/ed" (list *tmpfile*) :input *in* :output *out* :wait nil))
  64
  65 (defun real-input (stream)
  66   (two-way-stream-input-stream (symbol-value (synonym-stream-symbol stream))))
  67
  68 (defun magic-read-line (stream)
  69   ;; KLUDGE 1: The otherwise out :buffering :none is worth nothing,
  70   (let ((input (real-input stream)))
  71     (with-output-to-string (s)
  72       ;; KLUDGE 2: Something funny going on with buffering, as plain
  73       ;; READ-CHAR will hang here waiting for the newline, also
  74       ;; -NO-HANG will return too early without the sleep.
  75       ;;
  76       ;; Shoot me now. --NS 2006-06-09
  77       (loop for c = (progn (sleep 0.2) (read-char-no-hang input))
  78          while (and c (not (eq #\newline c)))
  79          do (write-char c s)))))
  80
  81 (defun assert-ed (command response)
  82   (when command
  83     (write-line command *in*)
  84     (force-output *in*))
  85   (let ((got (magic-read-line *out*)))
  86     (unless (equal response got)
  87       (error "wanted ~S from ed, got ~S" response got)))
  88   *ed*)
  89
  90 (assert-ed nil "4")
  91 (assert-ed ".s/bar/baz/g" "")
  92 (assert-ed "w" "4")
  93 (assert-ed "q" "")
  94 (process-wait *ed*)
  95
  96 (with-open-file (f *tmpfile*)
  97   (assert (equal "baz" (read-line f))))
  98
  99 ;(delete-file *tmp*)