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