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