chiark / gitweb /
Infra: Rudimentary setup system.
[clg] / gio / streams.lisp
CommitLineData
ad4a2c4e 1;; Common Lisp bindings for GTK+ 2.x
2;; Copyright 2008 Espen S. Johnsen <espen@users.sf.net>
3;;
4;; Permission is hereby granted, free of charge, to any person obtaining
5;; a copy of this software and associated documentation files (the
6;; "Software"), to deal in the Software without restriction, including
7;; without limitation the rights to use, copy, modify, merge, publish,
8;; distribute, sublicense, and/or sell copies of the Software, and to
9;; permit persons to whom the Software is furnished to do so, subject to
10;; the following conditions:
11;;
12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
14;;
15;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
23;; $Id: streams.lisp,v 1.1 2008-12-10 02:58:13 espen Exp $
24
25
26(in-package "GIO")
27
28(use-prefix "g")
29
30;;; Input streams
31
32(defbinding input-stream-read (stream buffer &key length cancellable) gssize
33 (stream input-stream)
34 (buffer pointer)
35 (length gsize)
36 (cancellable (or null cancellable))
37 (nil gerror-signal :out))
38
39(defbinding input-stream-read-all (stream buffer &key length cancellable) boolean
40 (stream input-stream)
41 (buffer pointer)
42 (length gsize)
43 (bytes-read gsize :out)
44 (cancellable (or null cancellable))
45 (nil gerror-signal :out))
46
47(defbinding input-stream-skip (stream length &key cancellable) gssize
48 (stream input-stream)
49 (length gsize)
50 (cancellable (or null cancellable))
51 (nil gerror-signal :out))
52
53(defbinding input-stream-close (stream &key cancellable) boolean
54 (stream input-stream)
55 (cancellable (or null cancellable))
56 (nil gerror-signal :out))
57
58
59;;; Output streams
60
61(defbinding output-stream-write (stream buffer &key length cancellable) gssize
62 (stream output-stream)
63 (buffer (or (unboxed-vector (unsigned-byte 8)) pointer))
64 ((or length (length buffer)) gsize)
65 (cancellable (or null cancellable))
66 (nil gerror-signal :out))
67
68(defbinding output-stream-write-all (stream buffer &key length cancellable) boolean
69 (stream output-stream)
70 (buffer (or (unboxed-vector (unsigned-byte 8)) pointer))
71 ((or length (length buffer)) gsize)
72 (bytes-written gsize :out)
73 (cancellable (or null cancellable))
74 (nil gerror-signal :out))
75
76(defbinding output-stream-flush (stream &key cancellable) boolean
77 (stream output-stream)
78 (cancellable (or null cancellable))
79 (nil gerror-signal :out))
80
81(defbinding output-stream-close (stream &key cancellable) boolean
82 (stream output-stream)
83 (cancellable (or null cancellable))
84 (nil gerror-signal :out))
85
86
87;;; Unix streams
88
89(defbinding %unix-input-stream-new () pointer
90 (fd int)
91 (close-fd-p boolean))
92
93(defmethod allocate-foreign ((stream unix-input-stream) &key fd close-fd)
94 (%unix-input-stream-new fd close-fd))
95
96(defbinding %unix-output-stream-new () pointer
97 (fd int)
98 (close-fd-p boolean))
99
100(defmethod allocate-foreign ((stream unix-output-stream) &key fd close-fd)
101 (%unix-output-stream-new fd close-fd))
102
103
104;;; Callback streams (clg extension)
105
106(define-callback callback-stream-read-func gssize
107 ((buffer pointer) (count gsize) (cancellable (or null cancellable))
108 (gerror pointer) (stream-id pointer-data))
109 (declare (ignore cancellable))
110 (handler-case
111 (let* ((sequence (make-array count :element-type '(unsigned-byte 8)))
112 (stream (find-user-data stream-id))
113 (bytes-read (read-sequence sequence stream)))
114 (unless (null-pointer-p buffer)
115 (make-c-vector '(unsigned-byte 8) bytes-read
116 :content sequence :location buffer))
117 bytes-read)
118 (serious-condition (condition)
119 (gerror-set-in-callback gerror (file-error-domain)
120 (enum-int :failed 'file-error-enum) (princ-to-string condition))
121 -1)))
122
123(define-callback callback-stream-write-func gssize
124 ((buffer pointer) (count gsize) (cancellable (or null cancellable))
125 (gerror pointer) (stream-id pointer-data))
126 (declare (ignore cancellable))
127 (handler-case
128 (let ((stream (find-user-data stream-id)))
129 (write-sequence
130 (map-c-vector 'vector 'identity buffer '(unsigned-byte 8) count)
131 stream))
132 (serious-condition (condition)
133 (gerror-set-in-callback gerror (file-error-domain)
134 (enum-int :failed 'file-error-enum) (princ-to-string condition))
135 -1)))
136
137(define-callback callback-stream-flush-func boolean
138 ((cancellable (or null cancellable)) (gerror pointer)
139 (stream-id pointer-data))
140 (declare (ignore cancellable))
141 (handler-case (force-output (find-user-data stream-id))
142 (serious-condition (condition)
143 (gerror-set-in-callback gerror (file-error-domain)
144 (enum-int :failed 'file-error-enum) (princ-to-string condition))
145 -1)))
146
147(define-callback callback-stream-close-func boolean
148 ((cancellable (or null cancellable)) gerror (stream-id pointer-data))
149 (declare (ignore cancellable gerror))
150 (destroy-user-data stream-id))
151
152(defbinding %callback-input-stream-new (stream-id) pointer
153 (callback-stream-read-func callback)
154 (callback-stream-close-func callback)
155 (stream-id pointer-data))
156
157(defbinding %callback-output-stream-new (stream-id) pointer
158 (callback-stream-read-func callback)
159 (callback-stream-flush-func callback)
160 (callback-stream-close-func callback)
161 (stream-id pointer-data))
162
163(defmethod allocate-foreign ((stream callback-input-stream) &key base-stream)
164 (%callback-input-stream-new (register-user-data base-stream)))
165
166(defmethod allocate-foreign ((stream callback-output-stream) &key base-stream)
167 (%callback-input-stream-new (register-user-data base-stream)))
168
169
170;;; Lisp integration
171
172(deftype input-stream-designator () '(or stream input-stream integer))
173(deftype output-stream-designator () '(or stream input-stream integer))
174
175(define-type-method alien-type ((type input-stream-designator))
176 (declare (ignore type))
177 (alien-type 'input-stream))
178
179(define-type-method alien-arg-wrapper ((type input-stream-designator) var stream style form &optional copy-in-p)
180 (declare (ignore type))
181 (let ((%stream (make-symbol "STREAM")))
182 `(let ((,%stream (etypecase ,stream
183 (input-stream ,stream)
184 (integer (make-instance 'unix-input-stream :fd ,stream))
185 (stream (make-instance 'callback-input-stream
186 :base-stream ,stream)))))
187 (unwind-protect
188 ,(alien-arg-wrapper 'input-stream var %stream style form copy-in-p)
189 (unless (typep ,stream 'input-stream)
190 (input-stream-close ,%stream))))))
191
192(define-type-method alien-type ((type output-stream-designator))
193 (declare (ignore type))
194 (alien-type 'output-stream))
195
196(define-type-method alien-arg-wrapper ((type output-stream-designator) var stream style form &optional copy-in-p)
197 (declare (ignore type))
198 (let ((%stream (make-symbol "STREAM")))
199 `(let ((,%stream (etypecase ,stream
200 (output-stream ,stream)
201 (integer (make-instance 'unix-output-stream :fd ,stream))
202 (stream (make-instance 'callback-output-stream
203 :base-stream ,stream)))))
204 (unwind-protect
205 ,(alien-arg-wrapper 'input-stream var %stream style form copy-in-p)
206 (unless (typep ,stream 'output-stream)
207 (output-stream-close ,%stream))))))
208
209;; TODO: make GIO streams appear as Lisp streams