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