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.47 2007-10-17 14:31:19 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 () (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 *overridden-signals* (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 (name type function)
 258   (let* ((signal-id (ensure-signal-id-from-type name type))
 259          (type-number (find-type-number type t))
 260          (callback-id (gethash (cons type-number signal-id) *overridden-signals*)))
 261     (if callback-id
 262         (update-user-data callback-id function)
 263       (multiple-value-bind (callback-closure callback-id)
 264           (make-callback-closure function class-handler-marshal)
 265         (%signal-override-class-closure signal-id type-number callback-closure)
 266         (setf
 267          (gethash (cons type-number signal-id) *overridden-signals*)
 268          callback-id)))))
 269
 270
 271 (defbinding %signal-chain-from-overridden () nil
 272   (args pointer)
 273   (return-value (or null gvalue)))
 274
 275
 276 (defun %call-next-handler (n-params types args return-type)
 277   (let ((params (allocate-memory (* n-params +gvalue-size+))))
 278     (loop
 279      for arg in args
 280      for type in types
 281      for offset from 0 by +gvalue-size+
 282      do (gvalue-init (pointer+ params offset) type arg))
 283
 284     (unwind-protect
 285         (if return-type
 286             (with-gvalue (return-value return-type)
 287               (%signal-chain-from-overridden params return-value))
 288           (%signal-chain-from-overridden params nil))
 289       (progn
 290         (loop
 291          repeat n-params
 292          for offset from 0 by +gvalue-size+
 293          do (gvalue-unset (pointer+ params offset)))
 294         (deallocate-memory params)))))
 295
 296
 297 (defmacro define-signal-handler (name ((object class) &rest args) &body body)
 298   (let* ((info (signal-query (ensure-signal-id-from-type name class)))
 299          (types (cons class (signal-param-types info)))
 300          (n-params (1+ (slot-value info 'n-params)))
 301          (return-type (type-from-number (slot-value info 'return-type)))
 302          (vars (loop
 303                 for arg in args
 304                 until (eq arg '&rest)
 305                 collect arg))
 306          (rest (cadr (member '&rest args)))
 307          (next (make-symbol "ARGS"))
 308          (default (make-symbol "DEFAULT")))
 309
 310     `(progn
 311        (signal-override-class-closure ',name ',class
 312         #'(lambda (,object ,@args)
 313             (let ((,default (list* ,object ,@vars ,rest)))
 314               (flet ((call-next-handler (&rest ,next)
 315                        (%call-next-handler
 316                         ,n-params ',types (or ,next ,default) ',return-type)))
 317               ,@body))))
 318        ',name)))
 319
 320
 321 (defbinding %signal-stop-emission () nil
 322   (instance ginstance)
 323   (signal-id unsigned-int)
 324   (detail quark))
 325
 326 (defvar *signal-stop-emission* nil)
 327 (declaim (special *signal-stop-emission*))
 328
 329 (defun signal-stop-emission ()
 330   (if *signal-stop-emission*
 331       (funcall *signal-stop-emission*)
 332     (error "Not inside a signal handler")))
 333
 334
 335 (defbinding signal-add-emission-hook (type signal function &key (detail 0))
 336     unsigned-long
 337   ((ensure-signal-id-from-type signal type) unsigned-int)
 338   (detail quark)
 339   (emission-hook-marshal callback)
 340   ((register-callback-function function) unsigned-int)
 341   (user-data-destroy-callback callback))
 342
 343 (defbinding signal-remove-emission-hook (type signal hook-id) nil
 344   ((ensure-signal-id-from-type signal type) unsigned-int)
 345   (hook-id unsigned-long))
 346
 347
 348 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
 349     (instance signal-id &key detail blocked) boolean
 350   (instance ginstance)
 351   ((ensure-signal-id signal-id instance) unsigned-int)
 352   ((or detail 0) quark)
 353   (blocked boolean))
 354
 355 (defbinding %signal-connect-closure-by-id () unsigned-long
 356   (instance ginstance)
 357   (signal-id unsigned-int)
 358   (detail quark)
 359   (closure pointer)
 360   (after boolean))
 361
 362 (defbinding signal-handler-block () nil
 363   (instance ginstance)
 364   (handler-id unsigned-long))
 365
 366 (defbinding signal-handler-unblock () nil
 367   (instance ginstance)
 368   (handler-id unsigned-long))
 369
 370 ;; Internal
 371 (defbinding signal-handler-find () unsigned-long
 372   (instance gobject)
 373   (mask signal-match-type)
 374   (signal-id unsigned-int)
 375   (detail quark)
 376   (closure (or null pointer))
 377   (func (or null pointer))
 378   (data pointer-data))
 379
 380 (defbinding signal-handler-disconnect () nil
 381   (instance ginstance)
 382   (handler-id unsigned-long))
 383
 384 (defbinding signal-handler-is-connected-p () boolean
 385   (instance ginstance)
 386   (handler-id unsigned-long))
 387
 388 (defbinding (closure-new "g_cclosure_new") () gclosure
 389   ((make-pointer #xFFFFFFFF) pointer)
 390   (callback-id unsigned-int)
 391   (destroy-notify callback))
 392
 393 (defbinding closure-set-meta-marshal () nil
 394   (gclosure gclosure)
 395   (callback-id unsigned-int)
 396   (callback callback))
 397
 398 (defun callback-closure-new (callback-id callback destroy-notify)
 399   (let ((gclosure (closure-new callback-id destroy-notify)))
 400     (closure-set-meta-marshal gclosure callback-id callback)
 401     gclosure))
 402
 403 (defun make-callback-closure (function &optional (marshaller signal-handler-marshal))
 404   (let ((callback-id (register-callback-function function)))
 405     (values
 406      (callback-closure-new callback-id marshaller user-data-destroy-callback)
 407      callback-id)))
 408
 409 (defgeneric compute-signal-function (gobject signal function object args))
 410
 411 (defmethod compute-signal-function ((gobject gobject) signal function object args)
 412   (declare (ignore signal))
 413   (cond
 414    ((or (eq object t) (eq object gobject))
 415     (if args
 416         #'(lambda (&rest emission-args)
 417             (apply function (nconc emission-args args)))
 418       function))
 419    (object
 420     (if args
 421         #'(lambda (&rest emission-args)
 422             (apply function object (nconc (rest emission-args) args)))
 423       #'(lambda (&rest emission-args)
 424           (apply function object (rest emission-args)))))
 425    (args
 426     #'(lambda (&rest emission-args)
 427         (apply function (nconc (rest emission-args) args))))
 428    (t
 429     #'(lambda (&rest emission-args)
 430         (apply function (rest emission-args))))))
 431
 432 (defgeneric compute-signal-id (gobject signal))
 433
 434 (defmethod compute-signal-id ((gobject gobject) signal)
 435   (ensure-signal-id signal gobject))
 436
 437
 438 (defgeneric signal-connect (gobject signal function &key detail after object remove args))
 439
 440 (defmethod signal-connect :around ((gobject gobject) signal function &rest args)
 441   (declare (ignore gobject signal args))
 442   (when function
 443     (call-next-method)))
 444
 445
 446 (defmethod signal-connect ((gobject gobject) signal function
 447                            &key detail after object remove args)
 448 "Connects a callback function to a signal for a particular object. If
 449 :OBJECT is T, the object connected to is passed as the first argument
 450 to the callback function, or if :OBJECT is any other non NIL value, it
 451 is passed as the first argument instead. If :AFTER is non NIL, the
 452 handler will be called after the default handler for the signal. If
 453 :REMOVE is non NIL, the handler will be removed after beeing invoked
 454 once. ARGS is a list of additional arguments passed to the callback
 455 function."
 456 (let* ((signal-id (compute-signal-id gobject signal))
 457        (detail-quark (if detail (quark-intern detail) 0))
 458        (signal-stop-emission
 459         #'(lambda ()
 460             (%signal-stop-emission gobject signal-id detail-quark)))
 461        (callback (compute-signal-function gobject signal function object args))
 462        (wrapper #'(lambda (&rest args)
 463                     (let ((*signal-stop-emission* signal-stop-emission))
 464                       (apply callback args)))))
 465       (multiple-value-bind (closure-id callback-id)
 466           (make-callback-closure wrapper signal-handler-marshal)
 467         (let ((handler-id (%signal-connect-closure-by-id
 468                            gobject signal-id detail-quark closure-id after)))
 469           (when remove
 470             (update-user-data callback-id
 471              #'(lambda (&rest args)
 472                  (unwind-protect
 473                      (let ((*signal-stop-emission* signal-stop-emission))
 474                        (apply callback args))
 475                    (when (signal-handler-is-connected-p gobject handler-id)
 476                      (signal-handler-disconnect gobject handler-id))))))
 477           handler-id))))
 478
 479
 480 ;;;; Signal emission
 481
 482 (defbinding %signal-emitv () nil
 483   (gvalues pointer)
 484   (signal-id unsigned-int)
 485   (detail quark)
 486   (return-value gvalue))
 487
 488 (defvar *signal-emit-functions* (make-hash-table))
 489
 490 (defun create-signal-emit-function (signal-id)
 491   (let ((info (signal-query signal-id)))
 492     (let* ((type (type-from-number (slot-value info 'type)))
 493            (param-types (cons type (signal-param-types info)))
 494            (return-type (type-from-number (slot-value info 'return-type)))
 495            (n-params (1+ (slot-value info 'n-params)))
 496            (params (allocate-memory (* n-params +gvalue-size+))))
 497       #'(lambda (detail object &rest args)
 498           (unless (= (length args) (1- n-params))
 499             (error "Invalid number of arguments in emmision of signal ~A: ~A" signal-id (length args)))
 500           (unwind-protect
 501               (loop
 502                for arg in (cons object args)
 503                for type in param-types
 504                as tmp = params then (pointer+ tmp +gvalue-size+)
 505                do (gvalue-init tmp type arg)
 506                finally
 507                (if return-type
 508                    (return
 509                     (with-gvalue (return-value)
 510                       (%signal-emitv params signal-id detail return-value)))
 511                  (%signal-emitv params signal-id detail (make-pointer 0))))
 512             (loop
 513              repeat n-params
 514              as tmp = params then (pointer+ tmp +gvalue-size+)
 515              while (gvalue-p tmp)
 516              do (gvalue-unset tmp)))))))
 517
 518 (defun signal-emit-with-detail (object signal detail &rest args)
 519   (let* ((signal-id (ensure-signal-id signal object))
 520          (function (or
 521                     (gethash signal-id *signal-emit-functions*)
 522                     (setf
 523                      (gethash signal-id *signal-emit-functions*)
 524                      (create-signal-emit-function signal-id)))))
 525     (apply function detail object args)))
 526
 527 (defun signal-emit (object signal &rest args)
 528   (apply #'signal-emit-with-detail object signal 0 args))
 529
 530
 531 ;;;; Signal registration
 532
 533 (defbinding %signal-newv (name itype flags return-type param-types)
 534     unsigned-int
 535   ((signal-name-to-string name) string)
 536   (itype gtype)
 537   (flags signal-flags)
 538   (nil null) ; class closure
 539   (nil null) ; accumulator
 540   (nil null) ; accumulator data
 541   (nil null) ; c marshaller
 542   (return-type gtype)
 543   ((length param-types) unsigned-int)
 544   (param-types (vector gtype)))
 545
 546 (defun signal-new (name itype flags return-type param-types)
 547   (when (zerop (signal-lookup name itype))
 548     (%signal-newv name itype flags return-type param-types)))
 549
 550 ;;;; Convenient macros
 551
 552 (defmacro define-callback-marshal (name return-type args &key (callback-id :last))
 553   (let* ((ignore ())
 554          (params ())
 555          (names (loop
 556                  for arg in args
 557                  collect (if (or
 558                               (eq arg :ignore)
 559                               (and (consp arg) (eq (first arg) :ignore)))
 560                              (let ((name (gensym "IGNORE")))
 561                                (push name ignore)
 562                                name)
 563                            (let ((name (if (atom arg)
 564                                            (gensym (string arg))
 565                                          (first arg))))
 566                              (push name params)
 567                              name))))
 568          (types (loop
 569                  for arg in args
 570                  collect (cond
 571                           ((eq arg :ignore) 'pointer)
 572                           ((atom arg) arg)
 573                           (t (second arg))))))
 574     `(define-callback ,name ,return-type
 575        ,(ecase callback-id
 576           (:first `((callback-id pointer-data) ,@(mapcar #'list names types)))
 577           (:last `(,@(mapcar #'list names types) (callback-id pointer-data))))
 578        (declare (ignore ,@ignore))
 579        (invoke-callback callback-id ',return-type ,@(nreverse params)))))
 580
 581 (defmacro with-callback-function ((id function) &body body)
 582   `(let ((,id (register-callback-function ,function)))
 583     (unwind-protect
 584          (progn ,@body)
 585       (destroy-user-data ,id))))