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.29 2006-02-08 19:56:25 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-get (sap+ param-values offset) t))))
  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
 223 (defun %call-next-handler (n-params types args return-type)
 224   (let ((params (allocate-memory (* n-params +gvalue-size+))))
 225     (loop
 226      for arg in args
 227      for type in types
 228      for offset from 0 by +gvalue-size+
 229      do (gvalue-init (sap+ params offset) type arg))
 230
 231     (unwind-protect
 232         (if return-type
 233             (with-gvalue (return-value return-type)
 234               (%signal-chain-from-overridden params return-value))
 235           (%signal-chain-from-overridden params nil))
 236       (progn
 237         (loop
 238          repeat n-params
 239          for offset from 0 by +gvalue-size+
 240          do (gvalue-unset (sap+ params offset)))
 241         (deallocate-memory params)))))
 242
 243
 244 (defmacro define-signal-handler (name ((object class) &rest args) &body body)
 245   (let* ((info (signal-query (ensure-signal-id-from-type name class)))
 246          (types (cons class (signal-param-types info)))
 247          (n-params (1+ (slot-value info 'n-params)))
 248          (return-type (type-from-number (slot-value info 'return-type)))
 249          (vars (loop
 250                 for arg in args
 251                 until (eq arg '&rest)
 252                 collect arg))
 253          (rest (cadr (member '&rest args)))
 254          (next (make-symbol "ARGS"))
 255          (default (make-symbol "DEFAULT")))
 256
 257     `(progn
 258        (signal-override-class-closure ',name ',class
 259         #'(lambda (,object ,@args)
 260             (let ((,default (list* ,object ,@vars ,rest)))
 261               (flet ((call-next-handler (&rest ,next)
 262                        (%call-next-handler
 263                         ,n-params ',types (or ,next ,default) ',return-type))))
 264               ,@body)))
 265        ',name)))
 266
 267
 268 (defbinding %signal-stop-emission () nil
 269   (instance ginstance)
 270   (signal-id unsigned-int)
 271   (detail quark))
 272
 273 (defvar *signal-stop-emission* nil)
 274 (declaim (special *signal-stop-emission*))
 275
 276 (defun signal-stop-emission ()
 277   (if *signal-stop-emission*
 278       (funcall *signal-stop-emission*)
 279     (error "Not inside a signal handler")))
 280
 281
 282 (defbinding signal-add-emission-hook (type signal function &key (detail 0))
 283     unsigned-int
 284   ((ensure-signal-id-from-type signal type) unsigned-int)
 285   (detail quark)
 286   ((callback signal-emission-hook) pointer)
 287   ((register-callback-function function) unsigned-int)
 288   ((callback user-data-destroy-func) pointer))
 289
 290 (defbinding signal-remove-emission-hook (type signal hook-id) nil
 291   ((ensure-signal-id-from-type signal type) unsigned-int)
 292   (hook-id unsigned-int))
 293
 294
 295 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
 296     (instance signal-id &key detail blocked) boolean
 297   (instance ginstance)
 298   ((ensure-signal-id signal-id instance) unsigned-int)
 299   ((or detail 0) quark)
 300   (blocked boolean))
 301
 302 (defbinding %signal-connect-closure-by-id () unsigned-int
 303   (instance ginstance)
 304   (signal-id unsigned-int)
 305   (detail quark)
 306   (closure pointer)
 307   (after boolean))
 308
 309 (defbinding signal-handler-block () nil
 310   (instance ginstance)
 311   (handler-id unsigned-int))
 312
 313 (defbinding signal-handler-unblock () nil
 314   (instance ginstance)
 315   (handler-id unsigned-int))
 316
 317 (defbinding signal-handler-disconnect () nil
 318   (instance ginstance)
 319   (handler-id unsigned-int))
 320
 321 (defbinding signal-handler-is-connected-p () boolean
 322   (instance ginstance)
 323   (handler-id unsigned-int))
 324
 325 (deftype gclosure () 'pointer)
 326 (register-type 'gclosure "GClosure")
 327
 328 (defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
 329   (callback-id unsigned-int)
 330   (callback pointer)
 331   (destroy-notify pointer))
 332
 333 (defun make-callback-closure (function)
 334   (let ((callback-id (register-callback-function function)))
 335     (values
 336      (callback-closure-new
 337       callback-id (callback closure-marshal)
 338       (callback user-data-destroy-func))
 339      callback-id)))
 340
 341 (defgeneric compute-signal-function (gobject signal function object))
 342
 343 (defmethod compute-signal-function ((gobject gobject) signal function object)
 344   (declare (ignore signal))
 345   (cond
 346    ((or (eq object t) (eq object gobject)) function)
 347    ((not object)
 348     #'(lambda (&rest args) (apply function (rest args))))
 349    (t
 350     #'(lambda (&rest args) (apply function object (rest args))))))
 351
 352
 353 (defgeneric compute-signal-id (gobject signal))
 354
 355 (defmethod compute-signal-id ((gobject gobject) signal)
 356   (ensure-signal-id signal gobject))
 357
 358
 359 (defgeneric signal-connect (gobject signal function &key detail after object remove))
 360
 361 (defmethod signal-connect :around ((gobject gobject) signal function &rest args)
 362   (declare (ignore gobject signal args))
 363   (when function
 364     (call-next-method)))
 365
 366
 367 (defmethod signal-connect ((gobject gobject) signal function
 368                            &key detail after object remove)
 369 "Connects a callback function to a signal for a particular object. If
 370 :OBJECT is T, the object connected to is passed as the first argument
 371 to the callback function, or if :OBJECT is any other non NIL value, it
 372 is passed as the first argument instead. If :AFTER is non NIL, the
 373 handler will be called after the default handler for the signal. If
 374 :REMOVE is non NIL, the handler will be removed after beeing invoked
 375 once."
 376 (let* ((signal-id (compute-signal-id gobject signal))
 377        (detail-quark (if detail (quark-intern detail) 0))
 378        (signal-stop-emission
 379         #'(lambda ()
 380             (%signal-stop-emission gobject signal-id detail-quark)))
 381        (callback (compute-signal-function gobject signal function object))
 382        (wrapper #'(lambda (&rest args)
 383                     (let ((*signal-stop-emission* signal-stop-emission))
 384                       (apply callback args)))))
 385       (multiple-value-bind (closure-id callback-id)
 386           (make-callback-closure wrapper)
 387         (let ((handler-id (%signal-connect-closure-by-id
 388                            gobject signal-id detail-quark closure-id after)))
 389           (when remove
 390             (update-user-data callback-id
 391              #'(lambda (&rest args)
 392                  (unwind-protect
 393                      (let ((*signal-stop-emission* signal-stop-emission))
 394                        (apply callback args))
 395                    (signal-handler-disconnect gobject handler-id)))))
 396           handler-id))))
 397
 398
 399 ;;;; Signal emission
 400
 401 (defbinding %signal-emitv () nil
 402   (gvalues pointer)
 403   (signal-id unsigned-int)
 404   (detail quark)
 405   (return-value gvalue))
 406
 407 (defvar *signal-emit-functions* (make-hash-table))
 408
 409 (defun create-signal-emit-function (signal-id)
 410   (let ((info (signal-query signal-id)))
 411     (let* ((type (type-from-number (slot-value info 'type)))
 412            (param-types (cons type (signal-param-types info)))
 413            (return-type (type-from-number (slot-value info 'return-type)))
 414            (n-params (1+ (slot-value info 'n-params)))
 415            (params (allocate-memory (* n-params +gvalue-size+))))
 416       #'(lambda (detail object &rest args)
 417           (unless (= (length args) (1- n-params))
 418             (error "Invalid number of arguments: ~A" (+ 2 (length args))))
 419           (unwind-protect
 420               (loop
 421                for arg in (cons object args)
 422                for type in param-types
 423                as tmp = params then (sap+ tmp +gvalue-size+)
 424                do (gvalue-init tmp type arg)
 425                finally
 426                (if return-type
 427                    (return
 428                     (with-gvalue (return-value)
 429                       (%signal-emitv params signal-id detail return-value)))
 430                  (%signal-emitv params signal-id detail (make-pointer 0))))
 431             (loop
 432              repeat n-params
 433              as tmp = params then (sap+ tmp +gvalue-size+)
 434              while (gvalue-p tmp)
 435              do (gvalue-unset tmp)))))))
 436
 437 (defun signal-emit-with-detail (object signal detail &rest args)
 438   (let* ((signal-id (ensure-signal-id signal object))
 439          (function (or
 440                     (gethash signal-id *signal-emit-functions*)
 441                     (setf
 442                      (gethash signal-id *signal-emit-functions*)
 443                      (create-signal-emit-function signal-id)))))
 444     (apply function detail object args)))
 445
 446 (defun signal-emit (object signal &rest args)
 447   (apply #'signal-emit-with-detail object signal 0 args))
 448
 449
 450 ;;;; Convenient macros
 451
 452 (defmacro def-callback-marshal (name (return-type &rest args))
 453   (let ((names (loop
 454                 for arg in args
 455                 collect (if (atom arg) (gensym) (first arg))))
 456         (types (loop
 457                 for arg in args
 458                 collect (if (atom arg) arg (second arg)))))
 459     `(defcallback ,name (,return-type ,@(mapcar #'list names types)
 460                          (callback-id unsigned-int))
 461       (invoke-callback callback-id ',return-type ,@names))))
 462
 463 (defmacro with-callback-function ((id function) &body body)
 464   `(let ((,id (register-callback-function ,function)))
 465     (unwind-protect
 466          (progn ,@body)
 467       (destroy-user-data ,id))))