chiark - git - mdw - clg/blob - glib/gcallback.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2000 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: gcallback.lisp,v 1.24 2005-04-23 16:48:50 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27 (use-prefix "g")
  28
  29
  30 ;;;; Callback invokation
  31
  32 (defun register-callback-function (function)
  33   (check-type function (or null symbol function))
  34   (register-user-data function))
  35
  36 ;; Callback marshal for regular signal handlers
  37 (defcallback closure-marshal (nil
  38                               (gclosure pointer)
  39                               (return-value gvalue)
  40                               (n-params unsigned-int)
  41                               (param-values pointer)
  42                               (invocation-hint pointer)
  43                               (callback-id unsigned-int))
  44   (declare (ignore gclosure invocation-hint))
  45   (callback-trampoline callback-id n-params param-values return-value))
  46
  47 ;; Callback function for emission hooks
  48 (defcallback signal-emission-hook (nil
  49                                    (invocation-hint pointer)
  50                                    (n-params unsigned-int)
  51                                    (param-values pointer)
  52                                    (callback-id unsigned-int))
  53   (callback-trampoline callback-id n-params param-values))
  54
  55 (defun callback-trampoline (callback-id n-params param-values &optional
  56                             (return-value (make-pointer 0)))
  57   (let* ((return-type (unless (null-pointer-p return-value)
  58                         (gvalue-type return-value)))
  59          (args (loop
  60                 for n from 0 below n-params
  61                 collect (gvalue-get (sap+ param-values (* n +gvalue-size+))))))
  62     (let ((result (apply #'invoke-callback callback-id return-type args)))
  63       (when return-type
  64         (gvalue-set return-value result)))))
  65
  66 (defun invoke-callback (callback-id return-type &rest args)
  67   (restart-case
  68       (apply (find-user-data callback-id) args)
  69     (continue nil :report "Return from callback function"
  70               (when return-type
  71                 (format *query-io* "Enter return value of type ~S: " return-type)
  72                 (force-output *query-io*)
  73                 (eval (read *query-io*))))
  74     (re-invoke nil :report "Re-invoke callback function"
  75                (apply #'invoke-callback callback-id return-type args))))
  76
  77
  78 ;;;; Timeouts and idle functions
  79
  80 (defconstant +priority-high+ -100)
  81 (defconstant +priority-default+ 0)
  82 (defconstant +priority-high-idle+ 100)
  83 (defconstant +priority-default-idle+ 200)
  84 (defconstant +priority-low+ 300)
  85
  86 (defbinding source-remove () boolean
  87   (tag unsigned-int))
  88
  89 (defcallback source-callback-marshal (nil (callback-id unsigned-int))
  90   (callback-trampoline callback-id 0 nil))
  91
  92 (defbinding (timeout-add "g_timeout_add_full")
  93     (interval function &optional (priority +priority-default+)) unsigned-int
  94   (priority int)
  95   (interval unsigned-int)
  96   ((callback source-callback-marshal) pointer)
  97   ((register-callback-function function) unsigned-long)
  98   ((callback user-data-destroy-func) pointer))
  99
 100 (defun timeout-remove (timeout)
 101   (source-remove timeout))
 102
 103 (defbinding (idle-add "g_idle_add_full")
 104     (function &optional (priority +priority-default-idle+)) unsigned-int
 105   (priority int)
 106   ((callback source-callback-marshal) pointer)
 107   ((register-callback-function function) unsigned-long)
 108   ((callback user-data-destroy-func) pointer))
 109
 110 (defun idle-remove (idle)
 111   (source-remove idle))
 112
 113
 114 ;;;; Signal information querying
 115
 116 (defbinding signal-lookup (name type) unsigned-int
 117   ((signal-name-to-string name) string)
 118   ((find-type-number type t) type-number))
 119
 120 (defbinding signal-name () (copy-of string)
 121   (signal-id unsigned-int))
 122
 123 (defbinding signal-list-ids (type) (vector unsigned-int n-ids)
 124   ((find-type-number type t) type-number)
 125   (n-ids unsigned-int :out))
 126
 127 (defun signal-list-names (type)
 128   (map 'list #'signal-name (signal-list-ids type)))
 129
 130 (defun ensure-signal-id-from-type (signal-id type)
 131   (etypecase signal-id
 132     (integer (if (signal-name signal-id)
 133                  signal-id
 134                (error "Invalid signal id: ~D" signal-id)))
 135     ((or symbol string)
 136      (let ((numeric-id (signal-lookup signal-id type)))
 137        (if (zerop numeric-id)
 138            (error "Invalid signal name for ~S: ~D" type signal-id)
 139          numeric-id)))))
 140
 141 (defun ensure-signal-id (signal-id instance)
 142   (ensure-signal-id-from-type signal-id (type-of instance)))
 143
 144 (eval-when (:compile-toplevel :load-toplevel :execute)
 145   (deftype signal-flags ()
 146     '(flags :run-first :run-last :run-cleanup :no-recurse
 147             :detailed :action :no-hooks))
 148
 149   (defclass signal-query (struct)
 150     ((id :allocation :alien :type unsigned-int)
 151      (name :allocation :alien :type (copy-of string))
 152      (type :allocation :alien :type type-number)
 153      (flags :allocation :alien :type signal-flags)
 154      (return-type :allocation :alien :type type-number)
 155      (n-params :allocation :alien :type unsigned-int)
 156      (param-types :allocation :alien :type pointer))
 157     (:metaclass struct-class)))
 158
 159 (defbinding signal-query
 160     (signal-id &optional (signal-query (make-instance 'signal-query))) nil
 161   (signal-id unsigned-int)
 162   (signal-query signal-query :return))
 163
 164 (defun signal-param-types (info)
 165   (with-slots (n-params param-types) info
 166    (map-c-vector 'list
 167     #'(lambda (type-number)
 168         (type-from-number type-number))
 169     param-types 'type-number n-params)))
 170
 171
 172 (defun describe-signal (signal-id &optional type)
 173   (let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
 174     (with-slots (id name type flags return-type n-params) info
 175       (format t "The signal with id ~D is named '~A' and may be emitted on instances of type ~S~%~%" id name (type-from-number type t))
 176       (format t "Signal handlers should return ~A and take ~A~%"
 177        (cond
 178         ((= return-type (find-type-number "void")) "no values")
 179         ((not (type-from-number return-type)) "values of unknown type")
 180         ((format nil "values of type ~S" (type-from-number return-type))))
 181        (if (zerop n-params)
 182            "no arguments"
 183          (format nil "arguments with the following types: ~A"
 184           (signal-param-types info)))))))
 185
 186
 187 ;;;; Signal connecting and controlling
 188
 189 (defbinding %signal-stop-emission () nil
 190   (instance ginstance)
 191   (signal-id unsigned-int)
 192   (detail quark))
 193
 194 (defvar *signal-stop-emission* nil)
 195 (declaim (special *signal-stop-emission*))
 196
 197 (defun signal-stop-emission ()
 198   (if *signal-stop-emission*
 199       (funcall *signal-stop-emission*)
 200     (error "Not inside a signal handler")))
 201
 202
 203 (defbinding signal-add-emission-hook (type signal function &key (detail 0))
 204     unsigned-int
 205   ((ensure-signal-id-from-type signal type) unsigned-int)
 206   (detail quark)
 207   ((callback signal-emission-hook) pointer)
 208   ((register-callback-function function) unsigned-int)
 209   ((callback user-data-destroy-func) pointer))
 210
 211 (defbinding signal-remove-emission-hook (type signal hook-id) nil
 212   ((ensure-signal-id-from-type signal type) unsigned-int)
 213   (hook-id unsigned-int))
 214
 215
 216 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
 217     (instance signal-id &key detail blocked) boolean
 218   (instance ginstance)
 219   ((ensure-signal-id signal-id instance) unsigned-int)
 220   ((or detail 0) quark)
 221   (blocked boolean))
 222
 223 (defbinding %signal-connect-closure-by-id () unsigned-int
 224   (instance ginstance)
 225   (signal-id unsigned-int)
 226   (detail quark)
 227   (closure pointer)
 228   (after boolean))
 229
 230 (defbinding signal-handler-block () nil
 231   (instance ginstance)
 232   (handler-id unsigned-int))
 233
 234 (defbinding signal-handler-unblock () nil
 235   (instance ginstance)
 236   (handler-id unsigned-int))
 237
 238 (defbinding signal-handler-disconnect () nil
 239   (instance ginstance)
 240   (handler-id unsigned-int))
 241
 242 (defbinding signal-handler-is-connected-p () boolean
 243   (instance ginstance)
 244   (handler-id unsigned-int))
 245
 246 (deftype gclosure () 'pointer)
 247
 248 (defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
 249   (callback-id unsigned-int)
 250   (callback pointer)
 251   (destroy-notify pointer))
 252
 253 (defun make-callback-closure (function)
 254   (let ((callback-id (register-callback-function function)))
 255     (values
 256      (callback-closure-new
 257       callback-id (callback closure-marshal)
 258       (callback user-data-destroy-func))
 259      callback-id)))
 260
 261 (defgeneric compute-signal-function (gobject signal function object))
 262
 263 (defmethod compute-signal-function ((gobject gobject) signal function object)
 264   (declare (ignore signal))
 265   (cond
 266    ((or (eq object t) (eq object gobject)) function)
 267    ((not object)
 268     #'(lambda (&rest args) (apply function (rest args))))
 269    (t
 270     #'(lambda (&rest args) (apply function object (rest args))))))
 271
 272
 273 (defgeneric compute-signal-id (gobject signal))
 274
 275 (defmethod compute-signal-id ((gobject gobject) signal)
 276   (ensure-signal-id signal gobject))
 277
 278
 279 (defgeneric signal-connect (gobject signal function &key detail after object remove))
 280
 281 (defmethod signal-connect :around ((gobject gobject) signal function &rest args)
 282   (declare (ignore gobject signal args))
 283   (when function
 284     (call-next-method)))
 285
 286
 287 (defmethod signal-connect ((gobject gobject) signal function
 288                            &key detail after object remove)
 289 "Connects a callback function to a signal for a particular object. If
 290 :OBJECT is T, the object connected to is passed as the first argument
 291 to the callback function, or if :OBJECT is any other non NIL value, it
 292 is passed as the first argument instead. If :AFTER is non NIL, the
 293 handler will be called after the default handler for the signal. If
 294 :REMOVE is non NIL, the handler will be removed after beeing invoked
 295 once."
 296 (let* ((signal-id (compute-signal-id gobject signal))
 297        (detail-quark (if detail (quark-intern detail) 0))
 298        (signal-stop-emission
 299         #'(lambda ()
 300             (%signal-stop-emission gobject signal-id detail-quark)))
 301        (callback (compute-signal-function gobject signal function object))
 302        (wrapper #'(lambda (&rest args)
 303                     (let ((*signal-stop-emission* signal-stop-emission))
 304                       (apply callback args)))))
 305       (multiple-value-bind (closure-id callback-id)
 306           (make-callback-closure wrapper)
 307         (let ((handler-id (%signal-connect-closure-by-id
 308                            gobject signal-id detail-quark closure-id after)))
 309           (when remove
 310             (update-user-data callback-id
 311              #'(lambda (&rest args)
 312                  (unwind-protect
 313                      (let ((*signal-stop-emission* signal-stop-emission))
 314                        (apply callback args))
 315                    (signal-handler-disconnect gobject handler-id)))))
 316           handler-id))))
 317
 318
 319 ;;;; Signal emission
 320
 321 (defbinding %signal-emitv () nil
 322   (gvalues pointer)
 323   (signal-id unsigned-int)
 324   (detail quark)
 325   (return-value gvalue))
 326
 327 (defvar *signal-emit-functions* (make-hash-table))
 328
 329 (defun create-signal-emit-function (signal-id)
 330   (let ((info (signal-query signal-id)))
 331     (let* ((type (type-from-number (slot-value info 'type)))
 332            (param-types (cons type (signal-param-types info)))
 333            (return-type (type-from-number (slot-value info 'return-type)))
 334            (n-params (1+ (slot-value info 'n-params)))
 335            (params (allocate-memory (* n-params +gvalue-size+))))
 336       #'(lambda (detail object &rest args)
 337           (unless (= (length args) (1- n-params))
 338             (error "Invalid number of arguments: ~A" (+ 2 (length args))))
 339           (unwind-protect
 340               (loop
 341                for arg in (cons object args)
 342                for type in param-types
 343                as tmp = params then (sap+ tmp +gvalue-size+)
 344                do (gvalue-init tmp type arg)
 345                finally
 346                (if return-type
 347                    (return
 348                     (with-gvalue (return-value)
 349                       (%signal-emitv params signal-id detail return-value)))
 350                  (%signal-emitv params signal-id detail (make-pointer 0))))
 351             (loop
 352              repeat n-params
 353              as tmp = params then (sap+ tmp +gvalue-size+)
 354              while (gvalue-p tmp)
 355              do (gvalue-unset tmp)))))))
 356
 357 (defun signal-emit-with-detail (object signal detail &rest args)
 358   (let* ((signal-id (ensure-signal-id signal object))
 359          (function (or
 360                     (gethash signal-id *signal-emit-functions*)
 361                     (setf
 362                      (gethash signal-id *signal-emit-functions*)
 363                      (create-signal-emit-function signal-id)))))
 364     (apply function detail object args)))
 365
 366 (defun signal-emit (object signal &rest args)
 367   (apply #'signal-emit-with-detail object signal 0 args))
 368
 369
 370 ;;;; Convenient macros
 371
 372 (defmacro def-callback-marshal (name (return-type &rest args))
 373   (let ((names (loop
 374                 for arg in args
 375                 collect (if (atom arg) (gensym) (first arg))))
 376         (types (loop
 377                 for arg in args
 378                 collect (if (atom arg) arg (second arg)))))
 379     `(defcallback ,name (,return-type ,@(mapcar #'list names types)
 380                          (callback-id unsigned-int))
 381       (invoke-callback callback-id ',return-type ,@names))))
 382
 383 (defmacro with-callback-function ((id function) &body body)
 384   `(let ((,id (register-callback-function ,function)))
 385     (unwind-protect
 386          (progn ,@body)
 387       (destroy-user-data ,id))))