Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 118 lines (103 sloc) 4.908 kb
660d5d1 Initial commit. I think it is working.
Zach Kost-Smith authored
1 (in-package :cl-plumbing)
2
3 ;; Gray Stream version
4
5 (defclass pipe (trivial-gray-streams:fundamental-stream
6 trivial-gray-streams:trivial-gray-stream-mixin)
7 ((lock :initform (bordeaux-threads:make-lock) :accessor lock-of)
8 (input :initarg :input :accessor input-of)
9 (output :initarg :output :accessor output-of)))
10
11 ;; (defmethod stream-element-type ((stream pipe))
12 ;; (stream-element-type (output-of stream)))
13
14 (defmethod trivial-gray-streams:stream-write-char ((p pipe) character)
15 (bt:with-lock-held ((lock-of p))
16 (write-char character (output-of p))))
17
dea8c0a Refactor: factor the pipe shuttling into its own function.
Zach Kost-Smith authored
18 (defun flush-in-to-out (pipe)
19 (let ((string (get-output-stream-string (output-of pipe))))
20 (when (> (length string) 0)
21 (setf (input-of pipe)
22 (make-concatenated-stream
23 (input-of pipe)
24 (make-string-input-stream string))))))
25
660d5d1 Initial commit. I think it is working.
Zach Kost-Smith authored
26 (defmethod trivial-gray-streams:stream-read-char ((p pipe))
1a4ddd8 Bug fix: Protect against buffer underflow eof.
Zach Kost-Smith authored
27 (iter
28 (bt:with-lock-held ((lock-of p))
29 (let ((eof (not (open-stream-p (output-of p)))))
30 (flush-in-to-out p)
31 (let ((result (read-char (input-of p) nil :eof)))
32 (cond ((not (equal :eof result)) (return result))
33 ((and eof (equal :eof result)) (return :eof))
34 (t nil)))))
35 ;; Is there a way to remove this polling delay? Perhaps it isn't a big
36 ;; deal.
37 (sleep .01)))
660d5d1 Initial commit. I think it is working.
Zach Kost-Smith authored
38
39 (defmethod trivial-gray-streams:stream-unread-char ((p pipe) character)
40 (bt:with-lock-held ((lock-of p))
41 (unread-char character (input-of p))))
42
1a4ddd8 Bug fix: Protect against buffer underflow eof.
Zach Kost-Smith authored
43 (defparameter *block-size* 1024)
44
660d5d1 Initial commit. I think it is working.
Zach Kost-Smith authored
45 (defmethod trivial-gray-streams:stream-read-line ((p pipe))
1a4ddd8 Bug fix: Protect against buffer underflow eof.
Zach Kost-Smith authored
46 (let ((consumed nil))
47 (unwind-protect
48 (iter
49 (bt:with-lock-held ((lock-of p))
50 (flush-in-to-out p)
51 (let* ((eof (not (open-stream-p (output-of p))))
52 (seq (make-array (list *block-size*)))
53 (n-read (read-sequence seq (input-of p)))
54 (newline-marker (iter (for char in-sequence seq with-index i)
55 (while (< i n-read))
56 (finding i such-that (eql char #\Newline)))))
57 (cond ((and newline-marker (< newline-marker n-read))
58 (setf (input-of p) (make-concatenated-stream
59 (make-string-input-stream
60 (coerce (subseq seq (+ newline-marker 1) n-read)
61 'string))
62 (input-of p)))
63 (let ((c consumed))
64 (setf consumed nil)
65 (return (coerce (apply #'concatenate
66 'string
67 (reverse
68 (cons
69 (subseq seq 0 newline-marker)
70 c)))
71 'string))))
72 (eof (let ((c consumed))
73 (setf consumed nil)
74 (return
75 (values (coerce (apply #'concatenate
76 'string
77 (reverse
78 (cons
79 (subseq seq 0 n-read)
80 c)))
81 'string) t))))
82 (t (push (subseq seq 0 n-read) consumed)))))
83 ;; Block until there is more to read.
84 (unread-char (read-char p) p))
85 (setf (input-of p)
86 (apply
87 'make-concatenated-stream
88 (reverse
89 (cons (input-of p)
90 (mapcar
91 (lambda (x) (make-string-input-stream (coerce x 'string)))
92 consumed))))))))
660d5d1 Initial commit. I think it is working.
Zach Kost-Smith authored
93
94 (defmethod trivial-gray-streams:stream-read-sequence
95 ((p pipe) seq start end &key &allow-other-keys)
96 (bt:with-lock-held ((lock-of p))
dea8c0a Refactor: factor the pipe shuttling into its own function.
Zach Kost-Smith authored
97 (flush-in-to-out p)
660d5d1 Initial commit. I think it is working.
Zach Kost-Smith authored
98 (read-sequence seq (input-of p) :start start :end end)))
99
100 (defmethod trivial-gray-streams:stream-write-sequence
101 ((p pipe) seq start end &key &allow-other-keys)
102 (bt:with-lock-held ((lock-of p))
103 (write-sequence seq (output-of p) :start start :end end)))
104
105 (defmethod trivial-gray-streams:stream-line-column ((p pipe))
106 0)
107
f59612b Added a close method for pipes.
Zach Kost-Smith authored
108 (defmethod close ((p pipe) &key abort)
109 (declare (ignore abort))
110 (close (output-of p)))
111
660d5d1 Initial commit. I think it is working.
Zach Kost-Smith authored
112 (defun make-pipe ()
113 "This makes a stream where you can write your output, then read it out
114 elsewhere."
115 (make-instance 'pipe
116 :input (make-string-input-stream "")
117 :output (make-string-output-stream)))
Something went wrong with that request. Please try again.