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