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