chiark - git - mdw - clg/blob - glib/gcallback.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: gcallback.lisp,v 1.22 2005-02-22 17:29:38 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22 (use-prefix "g")
  23
  24
  25 ;;;; Callback invokation
  26
  27 (defun register-callback-function (function)
  28   (check-type function (or null symbol function))
  29   (register-user-data function))
  30
  31 ;; Callback marshal for regular signal handlers
  32 (defcallback closure-marshal (nil
  33                               (gclosure pointer)
  34                               (return-value gvalue)
  35                               (n-params unsigned-int)
  36                               (param-values pointer)
  37                               (invocation-hint pointer)
  38                               (callback-id unsigned-int))
  39   (callback-trampoline callback-id n-params param-values return-value))
  40
  41 ;; Callback function for emission hooks
  42 (defcallback signal-emission-hook (nil
  43                                    (invocation-hint pointer)
  44                                    (n-params unsigned-int)
  45                                    (param-values pointer)
  46                                    (callback-id unsigned-int))
  47   (callback-trampoline callback-id n-params param-values))
  48
  49 (defun callback-trampoline (callback-id n-params param-values &optional
  50                             (return-value (make-pointer 0)))
  51   (let* ((return-type (unless (null-pointer-p return-value)
  52                         (gvalue-type return-value)))
  53          (args (loop
  54                 for n from 0 below n-params
  55                 collect (gvalue-get (sap+ param-values (* n +gvalue-size+))))))
  56     (let ((result (apply #'invoke-callback callback-id return-type args)))
  57       (when return-type
  58         (gvalue-set return-value result)))))
  59
  60 (defun invoke-callback (callback-id return-type &rest args)
  61   (restart-case
  62       (apply (find-user-data callback-id) args)
  63     (continue nil :report "Return from callback function"
  64               (when return-type
  65                 (format *query-io* "Enter return value of type ~S: " return-type)
  66                 (force-output *query-io*)
  67                 (eval (read *query-io*))))
  68     (re-invoke nil :report "Re-invoke callback function"
  69                (apply #'invoke-callback callback-id return-type args))))
  70
  71
  72 ;;;; Timeouts and idle functions
  73
  74 (defconstant +priority-high+ -100)
  75 (defconstant +priority-default+ 0)
  76 (defconstant +priority-high-idle+ 100)
  77 (defconstant +priority-default-idle+ 200)
  78 (defconstant +priority-low+ 300)
  79
  80 (defbinding source-remove () boolean
  81   (tag unsigned-int))
  82
  83 (defcallback source-callback-marshal (nil (callback-id unsigned-int))
  84   (callback-trampoline callback-id 0 nil))
  85
  86 (defbinding (timeout-add "g_timeout_add_full")
  87     (interval function &optional (priority +priority-default+)) unsigned-int
  88   (priority int)
  89   (interval unsigned-int)
  90   ((callback source-callback-marshal) pointer)
  91   ((register-callback-function function) unsigned-long)
  92   ((callback user-data-destroy-func) pointer))
  93
  94 (defun timeout-remove (timeout)
  95   (source-remove timeout))
  96
  97 (defbinding (idle-add "g_idle_add_full")
  98     (function &optional (priority +priority-default-idle+)) unsigned-int
  99   (priority int)
 100   ((callback source-callback-marshal) pointer)
 101   ((register-callback-function function) unsigned-long)
 102   ((callback user-data-destroy-func) pointer))
 103
 104 (defun idle-remove (idle)
 105   (source-remove idle))
 106
 107
 108 ;;;; Signal information querying
 109
 110 (defbinding signal-lookup (name type) unsigned-int
 111   ((signal-name-to-string name) string)
 112   ((find-type-number type t) type-number))
 113
 114 (defbinding signal-name () (copy-of string)
 115   (signal-id unsigned-int))
 116
 117 (defbinding signal-list-ids (type) (vector unsigned-int n-ids)
 118   ((find-type-number type t) type-number)
 119   (n-ids unsigned-int :out))
 120
 121 (defun signal-list-names (type)
 122   (map 'list #'signal-name (signal-list-ids type)))
 123
 124 (defun ensure-signal-id-from-type (signal-id type)
 125   (etypecase signal-id
 126     (integer (if (signal-name signal-id)
 127                  signal-id
 128                (error "Invalid signal id: ~D" signal-id)))
 129     ((or symbol string)
 130      (let ((numeric-id (signal-lookup signal-id type)))
 131        (if (zerop numeric-id)
 132            (error "Invalid signal name for ~S: ~D" type signal-id)
 133          numeric-id)))))
 134
 135 (defun ensure-signal-id (signal-id instance)
 136   (ensure-signal-id-from-type signal-id (type-of instance)))
 137
 138 (eval-when (:compile-toplevel :load-toplevel :execute)
 139   (deftype signal-flags ()
 140     '(flags :run-first :run-last :run-cleanup :no-recurse
 141             :detailed :action :no-hooks))
 142
 143   (defclass signal-query (struct)
 144     ((id :allocation :alien :type unsigned-int)
 145      (name :allocation :alien :type (copy-of string))
 146      (type :allocation :alien :type type-number)
 147      (flags :allocation :alien :type signal-flags)
 148      (return-type :allocation :alien :type type-number)
 149      (n-params :allocation :alien :type unsigned-int)
 150      (param-types :allocation :alien :type pointer))
 151     (:metaclass struct-class)))
 152
 153 (defbinding signal-query
 154     (signal-id &optional (signal-query (make-instance 'signal-query))) nil
 155   (signal-id unsigned-int)
 156   (signal-query signal-query :return))
 157
 158 (defun signal-param-types (info)
 159   (with-slots (n-params param-types) info
 160    (map-c-vector 'list
 161     #'(lambda (type-number)
 162         (type-from-number type-number))
 163     param-types 'type-number n-params)))
 164
 165
 166 (defun describe-signal (signal-id &optional type)
 167   (let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
 168     (with-slots (id name type flags return-type n-params) info
 169       (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))
 170       (format t "Signal handlers should return ~A and take ~A~%"
 171        (cond
 172         ((= return-type (find-type-number "void")) "no values")
 173         ((not (type-from-number return-type)) "values of unknown type")
 174         ((format nil "values of type ~S" (type-from-number return-type))))
 175        (if (zerop n-params)
 176            "no arguments"
 177          (format nil "arguments with the following types: ~A"
 178           (signal-param-types info)))))))
 179
 180
 181 ;;;; Signal connecting and controlling
 182
 183 (defbinding %signal-stop-emission () nil
 184   (instance ginstance)
 185   (signal-id unsigned-int)
 186   (detail quark))
 187
 188 (defvar *signal-stop-emission* nil)
 189 (declaim (special *signal-stop-emission*))
 190
 191 (defun signal-stop-emission ()
 192   (if *signal-stop-emission*
 193       (funcall *signal-stop-emission*)
 194     (error "Not inside a signal handler")))
 195
 196
 197 (defbinding signal-add-emission-hook (type signal function &key (detail 0))
 198     unsigned-int
 199   ((ensure-signal-id-from-type signal type) unsigned-int)
 200   (detail quark)
 201   ((callback signal-emission-hook) pointer)
 202   ((register-callback-function function) unsigned-int)
 203   ((callback user-data-destroy-func) pointer))
 204
 205 (defbinding signal-remove-emission-hook (type signal hook-id) nil
 206   ((ensure-signal-id-from-type signal type) unsigned-int)
 207   (hook-id unsigned-int))
 208
 209
 210 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
 211     (instance signal-id &key detail blocked) boolean
 212   (instance ginstance)
 213   ((ensure-signal-id signal-id instance) unsigned-int)
 214   ((or detail 0) quark)
 215   (blocked boolean))
 216
 217 (defbinding %signal-connect-closure-by-id () unsigned-int
 218   (instance ginstance)
 219   (signal-id unsigned-int)
 220   (detail quark)
 221   (closure pointer)
 222   (after boolean))
 223
 224 (defbinding signal-handler-block () nil
 225   (instance ginstance)
 226   (handler-id unsigned-int))
 227
 228 (defbinding signal-handler-unblock () nil
 229   (instance ginstance)
 230   (handler-id unsigned-int))
 231
 232 (defbinding signal-handler-disconnect () nil
 233   (instance ginstance)
 234   (handler-id unsigned-int))
 235
 236 (defbinding signal-handler-is-connected-p () boolean
 237   (instance ginstance)
 238   (handler-id unsigned-int))
 239
 240 (deftype gclosure () 'pointer)
 241
 242 (defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
 243   (callback-id unsigned-int)
 244   (callback pointer)
 245   (destroy-notify pointer))
 246
 247 (defun make-callback-closure (function)
 248   (let ((callback-id (register-callback-function function)))
 249     (values
 250      (callback-closure-new
 251       callback-id (callback closure-marshal)
 252       (callback user-data-destroy-func))
 253      callback-id)))
 254
 255 (defgeneric compute-signal-function (gobject signal function object))
 256
 257 (defmethod compute-signal-function ((gobject gobject) signal function object)
 258   (declare (ignore signal))
 259   (cond
 260    ((or (eq object t) (eq object gobject)) function)
 261    ((not object)
 262     #'(lambda (&rest args) (apply function (rest args))))
 263    (t
 264     #'(lambda (&rest args) (apply function object (rest args))))))
 265
 266
 267 (defgeneric compute-signal-id (gobject signal))
 268
 269 (defmethod compute-signal-id ((gobject gobject) signal)
 270   (ensure-signal-id signal gobject))
 271
 272
 273 (defgeneric signal-connect (gobject signal function &key detail after object remove))
 274
 275 (defmethod signal-connect :around ((gobject gobject) signal function &rest args)
 276   (declare (ignore gobject signal args))
 277   (when function
 278     (call-next-method)))
 279
 280
 281 (defmethod signal-connect ((gobject gobject) signal function
 282                            &key detail after object remove)
 283 "Connects a callback function to a signal for a particular object. If
 284 :OBJECT is T, the object connected to is passed as the first argument
 285 to the callback function, or if :OBJECT is any other non NIL value, it
 286 is passed as the first argument instead. If :AFTER is non NIL, the
 287 handler will be called after the default handler for the signal. If
 288 :REMOVE is non NIL, the handler will be removed after beeing invoked
 289 once."
 290 (let* ((signal-id (compute-signal-id gobject signal))
 291        (detail-quark (if detail (quark-intern detail) 0))
 292        (signal-stop-emission
 293         #'(lambda ()
 294             (%signal-stop-emission gobject signal-id detail-quark)))
 295        (callback (compute-signal-function gobject signal function object))
 296        (wrapper #'(lambda (&rest args)
 297                     (let ((*signal-stop-emission* signal-stop-emission))
 298                       (apply callback args)))))
 299       (multiple-value-bind (closure-id callback-id)
 300           (make-callback-closure wrapper)
 301         (let ((handler-id (%signal-connect-closure-by-id
 302                            gobject signal-id detail-quark closure-id after)))
 303           (when remove
 304             (update-user-data callback-id
 305              #'(lambda (&rest args)
 306                  (unwind-protect
 307                      (let ((*signal-stop-emission* signal-stop-emission))
 308                        (apply callback args))
 309                    (signal-handler-disconnect gobject handler-id)))))
 310           handler-id))))
 311
 312
 313 ;;;; Signal emission
 314
 315 (defbinding %signal-emitv () nil
 316   (gvalues pointer)
 317   (signal-id unsigned-int)
 318   (detail quark)
 319   (return-value gvalue))
 320
 321 (defvar *signal-emit-functions* (make-hash-table))
 322
 323 (defun create-signal-emit-function (signal-id)
 324   (let ((info (signal-query signal-id)))
 325     (let* ((type (type-from-number (slot-value info 'type)))
 326            (param-types (cons type (signal-param-types info)))
 327            (return-type (type-from-number (slot-value info 'return-type)))
 328            (n-params (1+ (slot-value info 'n-params)))
 329            (params (allocate-memory (* n-params +gvalue-size+))))
 330       #'(lambda (detail object &rest args)
 331           (unless (= (length args) (1- n-params))
 332             (error "Invalid number of arguments: ~A" (+ 2 (length args))))
 333           (unwind-protect
 334               (loop
 335                for arg in (cons object args)
 336                for type in param-types
 337                as tmp = params then (sap+ tmp +gvalue-size+)
 338                do (gvalue-init tmp type arg)
 339                finally
 340                (if return-type
 341                    (return
 342                     (with-gvalue (return-value)
 343                       (%signal-emitv params signal-id detail return-value)))
 344                  (%signal-emitv params signal-id detail (make-pointer 0))))
 345             (loop
 346              repeat n-params
 347              as tmp = params then (sap+ tmp +gvalue-size+)
 348              while (gvalue-p tmp)
 349              do (gvalue-unset tmp)))))))
 350
 351 (defun signal-emit-with-detail (object signal detail &rest args)
 352   (let* ((signal-id (ensure-signal-id signal object))
 353          (function (or
 354                     (gethash signal-id *signal-emit-functions*)
 355                     (setf
 356                      (gethash signal-id *signal-emit-functions*)
 357                      (create-signal-emit-function signal-id)))))
 358     (apply function detail object args)))
 359
 360 (defun signal-emit (object signal &rest args)
 361   (apply #'signal-emit-with-detail object signal 0 args))
 362
 363
 364 ;;;; Convenient macros
 365
 366 (defmacro def-callback-marshal (name (return-type &rest args))
 367   (let ((names (loop
 368                 for arg in args
 369                 collect (if (atom arg) (gensym) (first arg))))
 370         (types (loop
 371                 for arg in args
 372                 collect (if (atom arg) arg (second arg)))))
 373     `(defcallback ,name (,return-type ,@(mapcar #'list names types)
 374                          (callback-id unsigned-int))
 375       (invoke-callback callback-id ',return-type ,@names))))
 376
 377 (defmacro with-callback-function ((id function) &body body)
 378   `(let ((,id (register-callback-function ,function)))
 379     (unwind-protect
 380          (progn ,@body)
 381       (destroy-user-data ,id))))