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.21 2005/02/14 00:41:54 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 create-callback-function (gobject function arg1))
 256
 257 (defmethod create-callback-function ((gobject gobject) function arg1)
 258   (cond
 259    ((or (eq arg1 t) (eq arg1 gobject)) function)
 260    ((not arg1)
 261     #'(lambda (&rest args) (apply function (rest args))))
 262    (t
 263     #'(lambda (&rest args) (apply function arg1 (rest args))))))
 264
 265 (defgeneric signal-connect (gobject signal function &key))
 266
 267 (defmethod signal-connect ((gobject gobject) signal function
 268                            &key (detail 0) after object remove)
 269 "Connects a callback function to a signal for a particular object. If
 270 :OBJECT is T, the object connected to is passed as the first argument
 271 to the callback function, or if :OBJECT is any other non NIL value, it
 272 is passed as the first argument instead. If :AFTER is non NIL, the
 273 handler will be called after the default handler for the signal. If
 274 :REMOVE is non NIL, the handler will be removed after beeing invoked
 275 once."
 276   (when function
 277     (let* ((signal-id (ensure-signal-id signal gobject))
 278            (signal-stop-emission
 279             #'(lambda ()
 280                 (%signal-stop-emission gobject signal-id detail)))
 281            (callback (create-callback-function gobject function object))
 282            (wrapper #'(lambda (&rest args)
 283                         (let ((*signal-stop-emission* signal-stop-emission))
 284                           (apply callback args)))))
 285       (multiple-value-bind (closure-id callback-id)
 286           (make-callback-closure wrapper)
 287         (let ((handler-id (%signal-connect-closure-by-id
 288                            gobject signal-id detail closure-id after)))
 289           (when remove
 290             (update-user-data callback-id
 291              #'(lambda (&rest args)
 292                  (unwind-protect
 293                      (let ((*signal-stop-emission* signal-stop-emission))
 294                        (apply callback args))
 295                    (signal-handler-disconnect gobject handler-id)))))
 296           handler-id)))))
 297
 298
 299 ;;;; Signal emission
 300
 301 (defbinding %signal-emitv () nil
 302   (gvalues pointer)
 303   (signal-id unsigned-int)
 304   (detail quark)
 305   (return-value gvalue))
 306
 307 (defvar *signal-emit-functions* (make-hash-table))
 308
 309 (defun create-signal-emit-function (signal-id)
 310   (let ((info (signal-query signal-id)))
 311     (let* ((type (type-from-number (slot-value info 'type)))
 312            (param-types (cons type (signal-param-types info)))
 313            (return-type (type-from-number (slot-value info 'return-type)))
 314            (n-params (1+ (slot-value info 'n-params)))
 315            (params (allocate-memory (* n-params +gvalue-size+))))
 316       #'(lambda (detail object &rest args)
 317           (unless (= (length args) (1- n-params))
 318             (error "Invalid number of arguments: ~A" (+ 2 (length args))))
 319           (unwind-protect
 320               (loop
 321                for arg in (cons object args)
 322                for type in param-types
 323                as tmp = params then (sap+ tmp +gvalue-size+)
 324                do (gvalue-init tmp type arg)
 325                finally
 326                (if return-type
 327                    (return
 328                     (with-gvalue (return-value)
 329                       (%signal-emitv params signal-id detail return-value)))
 330                  (%signal-emitv params signal-id detail (make-pointer 0))))
 331             (loop
 332              repeat n-params
 333              as tmp = params then (sap+ tmp +gvalue-size+)
 334              while (gvalue-p tmp)
 335              do (gvalue-unset tmp)))))))
 336
 337 (defun signal-emit-with-detail (object signal detail &rest args)
 338   (let* ((signal-id (ensure-signal-id signal object))
 339          (function (or
 340                     (gethash signal-id *signal-emit-functions*)
 341                     (setf
 342                      (gethash signal-id *signal-emit-functions*)
 343                      (create-signal-emit-function signal-id)))))
 344     (apply function detail object args)))
 345
 346 (defun signal-emit (object signal &rest args)
 347   (apply #'signal-emit-with-detail object signal 0 args))
 348
 349
 350 ;;;; Convenient macros
 351
 352 (defmacro def-callback-marshal (name (return-type &rest args))
 353   (let ((names (loop
 354                 for arg in args
 355                 collect (if (atom arg) (gensym) (first arg))))
 356         (types (loop
 357                 for arg in args
 358                 collect (if (atom arg) arg (second arg)))))
 359     `(defcallback ,name (,return-type ,@(mapcar #'list names types)
 360                          (callback-id unsigned-int))
 361       (invoke-callback callback-id ',return-type ,@names))))
 362
 363 (defmacro with-callback-function ((id function) &body body)
 364   `(let ((,id (register-callback-function ,function)))
 365     (unwind-protect
 366          (progn ,@body)
 367       (destroy-user-data ,id))))