mdw@git.distorted.org.uk Git - 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.25 2005-04-24 13:25:31 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 (register-type 'gclosure "GClosure")
 248
 249 (defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
 250   (callback-id unsigned-int)
 251   (callback pointer)
 252   (destroy-notify pointer))
 253
 254 (defun make-callback-closure (function)
 255   (let ((callback-id (register-callback-function function)))
 256     (values
 257      (callback-closure-new
 258       callback-id (callback closure-marshal)
 259       (callback user-data-destroy-func))
 260      callback-id)))
 261
 262 (defgeneric compute-signal-function (gobject signal function object))
 263
 264 (defmethod compute-signal-function ((gobject gobject) signal function object)
 265   (declare (ignore signal))
 266   (cond
 267    ((or (eq object t) (eq object gobject)) function)
 268    ((not object)
 269     #'(lambda (&rest args) (apply function (rest args))))
 270    (t
 271     #'(lambda (&rest args) (apply function object (rest args))))))
 272
 273
 274 (defgeneric compute-signal-id (gobject signal))
 275
 276 (defmethod compute-signal-id ((gobject gobject) signal)
 277   (ensure-signal-id signal gobject))
 278
 279
 280 (defgeneric signal-connect (gobject signal function &key detail after object remove))
 281
 282 (defmethod signal-connect :around ((gobject gobject) signal function &rest args)
 283   (declare (ignore gobject signal args))
 284   (when function
 285     (call-next-method)))
 286
 287
 288 (defmethod signal-connect ((gobject gobject) signal function
 289                            &key detail after object remove)
 290 "Connects a callback function to a signal for a particular object. If
 291 :OBJECT is T, the object connected to is passed as the first argument
 292 to the callback function, or if :OBJECT is any other non NIL value, it
 293 is passed as the first argument instead. If :AFTER is non NIL, the
 294 handler will be called after the default handler for the signal. If
 295 :REMOVE is non NIL, the handler will be removed after beeing invoked
 296 once."
 297 (let* ((signal-id (compute-signal-id gobject signal))
 298        (detail-quark (if detail (quark-intern detail) 0))
 299        (signal-stop-emission
 300         #'(lambda ()
 301             (%signal-stop-emission gobject signal-id detail-quark)))
 302        (callback (compute-signal-function gobject signal function object))
 303        (wrapper #'(lambda (&rest args)
 304                     (let ((*signal-stop-emission* signal-stop-emission))
 305                       (apply callback args)))))
 306       (multiple-value-bind (closure-id callback-id)
 307           (make-callback-closure wrapper)
 308         (let ((handler-id (%signal-connect-closure-by-id
 309                            gobject signal-id detail-quark closure-id after)))
 310           (when remove
 311             (update-user-data callback-id
 312              #'(lambda (&rest args)
 313                  (unwind-protect
 314                      (let ((*signal-stop-emission* signal-stop-emission))
 315                        (apply callback args))
 316                    (signal-handler-disconnect gobject handler-id)))))
 317           handler-id))))
 318
 319
 320 ;;;; Signal emission
 321
 322 (defbinding %signal-emitv () nil
 323   (gvalues pointer)
 324   (signal-id unsigned-int)
 325   (detail quark)
 326   (return-value gvalue))
 327
 328 (defvar *signal-emit-functions* (make-hash-table))
 329
 330 (defun create-signal-emit-function (signal-id)
 331   (let ((info (signal-query signal-id)))
 332     (let* ((type (type-from-number (slot-value info 'type)))
 333            (param-types (cons type (signal-param-types info)))
 334            (return-type (type-from-number (slot-value info 'return-type)))
 335            (n-params (1+ (slot-value info 'n-params)))
 336            (params (allocate-memory (* n-params +gvalue-size+))))
 337       #'(lambda (detail object &rest args)
 338           (unless (= (length args) (1- n-params))
 339             (error "Invalid number of arguments: ~A" (+ 2 (length args))))
 340           (unwind-protect
 341               (loop
 342                for arg in (cons object args)
 343                for type in param-types
 344                as tmp = params then (sap+ tmp +gvalue-size+)
 345                do (gvalue-init tmp type arg)
 346                finally
 347                (if return-type
 348                    (return
 349                     (with-gvalue (return-value)
 350                       (%signal-emitv params signal-id detail return-value)))
 351                  (%signal-emitv params signal-id detail (make-pointer 0))))
 352             (loop
 353              repeat n-params
 354              as tmp = params then (sap+ tmp +gvalue-size+)
 355              while (gvalue-p tmp)
 356              do (gvalue-unset tmp)))))))
 357
 358 (defun signal-emit-with-detail (object signal detail &rest args)
 359   (let* ((signal-id (ensure-signal-id signal object))
 360          (function (or
 361                     (gethash signal-id *signal-emit-functions*)
 362                     (setf
 363                      (gethash signal-id *signal-emit-functions*)
 364                      (create-signal-emit-function signal-id)))))
 365     (apply function detail object args)))
 366
 367 (defun signal-emit (object signal &rest args)
 368   (apply #'signal-emit-with-detail object signal 0 args))
 369
 370
 371 ;;;; Convenient macros
 372
 373 (defmacro def-callback-marshal (name (return-type &rest args))
 374   (let ((names (loop
 375                 for arg in args
 376                 collect (if (atom arg) (gensym) (first arg))))
 377         (types (loop
 378                 for arg in args
 379                 collect (if (atom arg) arg (second arg)))))
 380     `(defcallback ,name (,return-type ,@(mapcar #'list names types)
 381                          (callback-id unsigned-int))
 382       (invoke-callback callback-id ',return-type ,@names))))
 383
 384 (defmacro with-callback-function ((id function) &body body)
 385   `(let ((,id (register-callback-function ,function)))
 386     (unwind-protect
 387          (progn ,@body)
 388       (destroy-user-data ,id))))