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