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