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