chiark / gitweb /
Infra: Rudimentary setup system.
[clg] / gio / streams.lisp
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