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