chiark - git - mdw - clg/blob - 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