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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2000-2005 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: gobject.lisp,v 1.39 2006-02-03 00:10:56 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27
  28 ;;;; Metaclass used for subclasses of gobject
  29
  30 (eval-when (:compile-toplevel :load-toplevel :execute)
  31   (defclass gobject-class (ginstance-class)
  32     ((instance-slots-p :initform nil
  33       :documentation "Non NIL if the class has slots with instance allocation")))
  34
  35   (defmethod validate-superclass ((class gobject-class) (super standard-class))
  36 ;  (subtypep (class-name super) 'gobject)
  37     t))
  38
  39 (defclass direct-property-slot-definition (direct-virtual-slot-definition)
  40   ((pname :reader slot-definition-pname :initarg :pname)
  41    (readable :initform t :reader slot-readable-p :initarg :readable)
  42    (writable :initform t :reader slot-writable-p :initarg :writable)
  43    (construct :initform nil :initarg :construct)))
  44
  45 (defclass effective-property-slot-definition (effective-virtual-slot-definition)
  46   ((pname :reader slot-definition-pname :initarg :pname)
  47    (readable :reader slot-readable-p :initarg :readable)
  48    (writable :reader slot-writable-p :initarg :writable)
  49    (construct :initarg :construct)))
  50
  51 (defclass direct-user-data-slot-definition (direct-virtual-slot-definition)
  52   ())
  53
  54 (defclass effective-user-data-slot-definition (effective-virtual-slot-definition)
  55   ())
  56
  57
  58 (defbinding %object-ref () pointer
  59   (location pointer))
  60
  61 (defbinding %object-unref () nil
  62   (location pointer))
  63
  64 (defcallback toggle-ref-callback (nil (data pointer) (location pointer) (last-ref-p boolean))
  65   (if last-ref-p
  66       (cache-instance (find-cached-instance location) t)
  67     (cache-instance (find-cached-instance location) nil)))
  68
  69 #+gtk2.8
  70 (defbinding %object-add-toggle-ref () pointer
  71   (location pointer)
  72   ((callback toggle-ref-callback) pointer)
  73   (nil null))
  74
  75 #+gtk2.8
  76 (defbinding %object-remove-toggle-ref () pointer
  77   (location pointer)
  78   ((callback toggle-ref-callback) pointer)
  79   (nil null))
  80
  81 (defmethod reference-foreign ((class gobject-class) location)
  82   (declare (ignore class))
  83   #+gtk2.8
  84   (if (slot-value class 'instance-slots-p)
  85       (%object-add-toggle-ref location)
  86     (%object-ref location))
  87   #-gtk2.8
  88   (%object-ref location))
  89
  90 (defmethod unreference-foreign ((class gobject-class) location)
  91   (declare (ignore class))
  92   (error "Should never be called on a GOBJECT-CLASS (if this is ever needed some redesigning would have to be done)")
  93 ;  (%object-unref location)
  94 )
  95
  96
  97
  98 ; (defbinding object-class-install-param () nil
  99 ;   (class pointer)
 100 ;   (id unsigned-int)
 101 ;   (parameter parameter))
 102
 103 ; (defbinding object-class-find-param-spec () parameter
 104 ;   (class pointer)
 105 ;   (name string))
 106
 107 (defun signal-name-to-string (name)
 108   (substitute #\_ #\- (string-downcase (string name))))
 109
 110
 111 (defmethod direct-slot-definition-class ((class gobject-class) &rest initargs)
 112   (case (getf initargs :allocation)
 113     (:property (find-class 'direct-property-slot-definition))
 114     (:user-data (find-class 'direct-user-data-slot-definition))
 115     (t (call-next-method))))
 116
 117 (defmethod effective-slot-definition-class ((class gobject-class) &rest initargs)
 118   (case (getf initargs :allocation)
 119     (:property (find-class 'effective-property-slot-definition))
 120     (:user-data (find-class 'effective-user-data-slot-definition))
 121     (t (call-next-method))))
 122
 123 (defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds)
 124   (if (typep (first direct-slotds) 'direct-property-slot-definition)
 125       (nconc
 126        (list :pname (signal-name-to-string
 127                      (most-specific-slot-value direct-slotds 'pname))
 128              :readable (most-specific-slot-value direct-slotds 'readable)
 129              :writable (most-specific-slot-value direct-slotds 'writable)
 130              :construct (most-specific-slot-value direct-slotds 'construct))
 131        (call-next-method))
 132     (call-next-method)))
 133
 134
 135 (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition))
 136   (let ((type (slot-definition-type slotd))
 137         (pname (slot-definition-pname slotd)))
 138     (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd))
 139       (setf
 140        (slot-value slotd 'getter)
 141        (let ((reader nil))
 142          #'(lambda (object)
 143              (unless reader
 144                (setq reader (reader-function type)))
 145              (let ((gvalue (gvalue-new type)))
 146                (%object-get-property object pname gvalue)
 147                (unwind-protect
 148                  (funcall reader  gvalue +gvalue-value-offset+)
 149                  (gvalue-free gvalue t)))))))
 150
 151     (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd))
 152       (setf
 153        (slot-value slotd 'setter)
 154        (let ((writer nil))
 155          #'(lambda (value object)
 156              (unless writer
 157                (setq writer (writer-function type)))
 158              (let ((gvalue (gvalue-new type)))
 159                (funcall writer value gvalue +gvalue-value-offset+)
 160                (%object-set-property object pname gvalue)
 161                (gvalue-free gvalue t)
 162                value))))))
 163
 164   (call-next-method))
 165
 166 (defmethod initialize-internal-slot-functions ((slotd effective-user-data-slot-definition))
 167   (let ((slot-name (slot-definition-name slotd)))
 168     (unless (slot-boundp slotd 'getter)
 169       (setf
 170        (slot-value slotd 'getter)
 171        #'(lambda (object)
 172            (prog1 (user-data object slot-name)))))
 173     (unless (slot-boundp slotd 'setter)
 174       (setf
 175        (slot-value slotd 'setter)
 176        #'(lambda (value object)
 177            (setf (user-data object slot-name) value))))
 178     (unless (slot-boundp slotd 'boundp)
 179       (setf
 180        (slot-value slotd 'boundp)
 181        #'(lambda (object)
 182            (user-data-p object slot-name)))))
 183   (call-next-method))
 184
 185 (defmethod shared-initialize :after ((class gobject-class) names &rest initargs)
 186   (declare (ignore initargs))
 187   (when (some #'(lambda (slotd)
 188                   (and
 189                    (eq (slot-definition-allocation slotd) :instance)
 190                    (not (typep slotd 'effective-special-slot-definition))))
 191               (class-slots class))
 192     (setf (slot-value class 'instance-slots-p) t)))
 193
 194
 195
 196 ;;;; Super class for all classes in the GObject type hierarchy
 197
 198 (eval-when (:compile-toplevel :load-toplevel :execute)
 199   (defclass gobject (ginstance)
 200     ()
 201     (:metaclass gobject-class)
 202     (:gtype "GObject")))
 203
 204
 205 (defun initial-add (object function initargs key pkey)
 206   (loop
 207    as (initarg value . rest) = initargs then rest
 208    do (cond
 209        ((eq initarg key) (funcall function object value))
 210        ((eq initarg pkey) (mapc #'(lambda (value)
 211                                     (funcall function object value))
 212                                 value)))
 213        while rest))
 214
 215 (defun initial-apply-add (object function initargs key pkey)
 216   (initial-add object #'(lambda (object value)
 217                           (apply function object (mklist value)))
 218                initargs key pkey))
 219
 220
 221 (defmethod initialize-instance ((object gobject) &rest initargs)
 222   (unless (slot-boundp object 'location)
 223     ;; Extract initargs which we should pass directly to the GObject
 224     ;; constructor
 225     (let* ((slotds (class-slots (class-of object)))
 226            (args (when initargs
 227                    (loop
 228                     as (key value . rest) = initargs then rest
 229                     as slotd = (find-if
 230                                 #'(lambda (slotd)
 231                                     (member key (slot-definition-initargs slotd)))
 232                                 slotds)
 233                     when (and (typep slotd 'effective-property-slot-definition)
 234                               (slot-value slotd 'construct))
 235                     collect (progn
 236                               (remf initargs key)
 237                               (list
 238                                (slot-definition-pname slotd)
 239                                (slot-definition-type slotd)
 240                                value))
 241                     while rest))))
 242       (if args
 243           (let* ((string-size (size-of 'string))
 244                  (string-writer (writer-function 'string))
 245                  (string-destroy (destroy-function 'string))
 246                  (params (allocate-memory
 247                           (* (length args) (+ string-size +gvalue-size+)))))
 248             (loop
 249              for (pname type value) in args
 250              as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
 251              do (funcall string-writer pname tmp)
 252              (gvalue-init (sap+ tmp string-size) type value))
 253             (unwind-protect
 254                 (setf
 255                  (slot-value object 'location)
 256                  (%gobject-newv (type-number-of object) (length args) params))
 257               (loop
 258                repeat (length args)
 259                as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
 260                do (funcall string-destroy tmp)
 261                (gvalue-unset (sap+ tmp string-size)))
 262               (deallocate-memory params)))
 263         (setf
 264          (slot-value object 'location)
 265          (%gobject-new (type-number-of object))))))
 266
 267   (apply #'call-next-method object initargs))
 268
 269
 270 (defmethod instance-finalizer ((instance gobject))
 271   (let ((location (proxy-location instance)))
 272     #+gtk2.8
 273     (if (slot-value (class-of instance) 'instance-slots-p)
 274         #'(lambda ()
 275             (remove-cached-instance location)
 276             (%object-remove-toggle-ref location))
 277       #'(lambda ()
 278           (remove-cached-instance location)
 279           (%object-unref location)))
 280     #-gtk2.8
 281     #'(lambda ()
 282         (remove-cached-instance location)
 283           (%object-unref location))))
 284
 285
 286 (defbinding (%gobject-new "g_object_new") () pointer
 287   (type type-number)
 288   (nil null))
 289
 290 (defbinding (%gobject-newv "g_object_newv") () pointer
 291   (type type-number)
 292   (n-parameters unsigned-int)
 293   (params pointer))
 294
 295
 296
 297 ;;;; Property stuff
 298
 299 (defbinding %object-set-property () nil
 300   (object gobject)
 301   (name string)
 302   (value gvalue))
 303
 304 (defbinding %object-get-property () nil
 305   (object gobject)
 306   (name string)
 307   (value gvalue))
 308
 309 (defbinding %object-notify () nil
 310   (object gobject)
 311   (name string))
 312
 313 (defbinding object-freeze-notify () nil
 314   (object gobject))
 315
 316 (defbinding object-thaw-notify () nil
 317   (object gobject))
 318
 319
 320 ;;;; User data
 321
 322 (defbinding %object-set-qdata-full () nil
 323   (object gobject)
 324   (id quark)
 325   (data unsigned-long)
 326   (destroy-marshal pointer))
 327
 328 (defcallback user-data-destroy-func (nil (id unsigned-int))
 329   (destroy-user-data id))
 330
 331 (export 'user-data-destroy-func)
 332
 333 (defun (setf user-data) (data object key)
 334   (%object-set-qdata-full object (quark-intern key)
 335    (register-user-data data) (callback user-data-destroy-func))
 336   data)
 337
 338 ;; deprecated
 339 (defun (setf object-data) (data object key &key (test #'eq))
 340   (assert (eq test #'eq))
 341   (setf (user-data object key) data))
 342
 343 (defbinding %object-get-qdata () unsigned-long
 344   (object gobject)
 345   (id quark))
 346
 347 (defun user-data (object key)
 348   (find-user-data (%object-get-qdata object (quark-intern key))))
 349
 350 ;; deprecated
 351 (defun object-data (object key &key (test #'eq))
 352   (assert (eq test #'eq))
 353   (user-data object key))
 354
 355 (defun user-data-p (object key)
 356   (user-data-exists-p (%object-get-qdata object (quark-intern key))))
 357
 358 (defbinding %object-steal-qdata () unsigned-long
 359   (object gobject)
 360   (id quark))
 361
 362 (defun unset-user-data (object key)
 363   (destroy-user-data (%object-steal-qdata object (quark-intern key))))
 364
 365
 366 ;;;;
 367
 368 (defbinding %object-class-list-properties () pointer
 369   (class pointer)
 370   (n-properties unsigned-int :out))
 371
 372
 373 (defun %map-params (params length type inherited-p)
 374   (if inherited-p
 375       (map-c-vector 'list #'identity params 'param length)
 376     (let ((properties ()))
 377       (map-c-vector 'list
 378        #'(lambda (param)
 379            (when (eql (param-owner-type param) type)
 380              (push param properties)))
 381        params 'param length)
 382       (nreverse properties))))
 383
 384 (defun query-object-class-properties (type &optional inherited-p)
 385   (let* ((type-number (find-type-number type t))
 386          (class (type-class-ref type-number)))
 387     (unwind-protect
 388          (multiple-value-bind (array length)
 389              (%object-class-list-properties class)
 390            (unless (null-pointer-p array)
 391              (unwind-protect
 392                  (%map-params array length type-number inherited-p)
 393                (deallocate-memory array))))
 394 ;      (type-class-unref type-number)
 395       )))
 396
 397
 398 (defun default-slot-name (name)
 399   (intern (substitute #\- #\_ (string-upcase (string-upcase name)))))
 400
 401 (defun default-slot-accessor (class-name slot-name type)
 402   (intern
 403    (format
 404     nil "~A-~A~A" class-name slot-name
 405     (if (eq type 'boolean) "-P" ""))))
 406
 407
 408 (defun slot-definition-from-property (class property &optional slot-name args)
 409   (with-slots (name flags value-type documentation) property
 410     (let* ((slot-name (or slot-name (default-slot-name name)))
 411            (slot-type (or (getf args :type) (type-from-number value-type) 'pointer))
 412            (accessor (default-slot-accessor class slot-name slot-type)))
 413
 414       `(,slot-name
 415         :allocation :property :pname ,name
 416
 417         ,@(when (find :unbound args) (list :unbound (getf args :unbound)))
 418         ,@(when (find :getter args) (list :getter (getf args :getter)))
 419         ,@(when (find :setter args) (list :setter (getf args :setter)))
 420
 421         ;; accessors
 422         ,@(cond
 423            ((and
 424              (member :writable flags) (member :readable flags)
 425              (not (member :construct-only flags)))
 426             (list :accessor accessor))
 427            ((and (member :writable flags) (not (member :construct-only flags)))
 428             (list :writer `(setf ,accessor)))
 429            ((member :readable flags)
 430             (list :reader accessor)))
 431
 432         ;; readable/writable/construct
 433         ,@(when (or (not (member :writable flags))
 434                     (member :construct-only flags))
 435             '(:writable nil))
 436         ,@(when (not (member :readable flags))
 437             '(:readable nil))
 438         ,@(when (or (member :construct flags)
 439                     (member :construct-only flags))
 440             '(:construct t))
 441
 442         ;; initargs
 443         ,@(if (find :initarg args)
 444               (let ((initarg (getf args :initarg)))
 445                 (etypecase initarg
 446                   (null ())
 447                   (symbol `(:initarg ,initarg))))
 448             (when (or (member :construct flags)
 449                       (member :construct-only flags)
 450                       (member :writable flags))
 451               (list :initarg (intern (string slot-name) "KEYWORD"))))
 452
 453         :type ,slot-type
 454         :documentation ,documentation))))
 455
 456
 457 (defun slot-definitions (class properties slots)
 458   (loop
 459    for property in properties
 460    as slot = (or
 461               (find (param-name property) slots
 462                :key #'(lambda (slot) (getf (rest slot) :pname))
 463                :test #'string=)
 464               (find (param-name property) slots
 465                :key #'first :test #'string-equal))
 466    do (cond
 467        ((not slot)
 468         (push (slot-definition-from-property class property) slots))
 469        ((getf (rest slot) :merge)
 470         (setf
 471          (rest slot)
 472          (rest (slot-definition-from-property class property (first slot) (rest slot)))))))
 473   (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots))
 474
 475
 476 (defun expand-gobject-type (type forward-p options &optional (metaclass 'gobject-class))
 477   (let ((supers (cons (supertype type) (implements type)))
 478         (class  (type-from-number type))
 479         (slots (getf options :slots)))
 480     `(defclass ,class ,supers
 481          ,(unless forward-p
 482             (slot-definitions class (query-object-class-properties type) slots))
 483          (:metaclass ,metaclass)
 484          (:gtype ,(register-type-as type)))))
 485
 486 (defun gobject-dependencies (type)
 487   (delete-duplicates
 488    (cons
 489     (supertype type)
 490     (append
 491      (type-interfaces type)
 492      (mapcar #'param-value-type (query-object-class-properties type))))))
 493
 494
 495 (register-derivable-type 'gobject "GObject" 'expand-gobject-type 'gobject-dependencies)
 496
 497
 498 ;;; Pseudo type for gobject instances which have their reference count
 499 ;;; increased by the returning function
 500
 501 (defmethod alien-type ((type (eql 'referenced)) &rest args)
 502   (declare (ignore type args))
 503   (alien-type 'gobject))
 504
 505 (defmethod from-alien-form (form (type (eql 'referenced)) &rest args)
 506   (declare (ignore type))
 507   (destructuring-bind (type) args
 508     (if (subtypep type 'gobject)
 509         (let ((instance (make-symbol "INSTANCE")))
 510           `(let ((,instance ,(from-alien-form form type)))
 511              (when ,instance
 512                (%object-unref (proxy-location ,instance)))
 513              ,instance))
 514       (error "~A is not a subclass of GOBJECT" type))))
 515
 516 (export 'referenced)