glib/gobject.object.low.lisp

   1 (in-package :gobject)
   2
   3 (defun g-type-from-object (object-ptr)
   4   "Returns the GType of an @code{object-ptr}
   5
   6 @arg[object-ptr]{C pointer to an object}
   7 @return{GType designator (see @class{g-type-designator})}"
   8   (g-type-from-instance object-ptr))
   9
  10 (defun g-type-from-class (g-class)
  11   (foreign-slot-value g-class 'g-type-class :type))
  12
  13 (defun g-type-from-instance (type-instance)
  14   (g-type-from-class (foreign-slot-value type-instance 'g-type-instance :class)))
  15
  16 (defun g-type-from-interface (type-interface)
  17   (foreign-slot-value type-interface 'g-type-interface :type))
  18
  19 (define-condition property-access-error (error)
  20   ((property-name :initarg :property-name :reader property-access-error-property-name)
  21    (class-name :initarg :class-name :reader property-access-error-class-name)
  22    (message :initarg :message :reader property-access-error-message))
  23   (:report (lambda (condition stream)
  24              (format stream "Error accessing property '~A' on class '~A': ~A"
  25                      (property-access-error-property-name condition)
  26                      (property-access-error-class-name condition)
  27                      (property-access-error-message condition)))))
  28
  29 (define-condition property-unreadable-error (property-access-error)
  30   ()
  31   (:default-initargs :message "property is not readable"))
  32
  33 (define-condition property-unwritable-error (property-access-error)
  34   ()
  35   (:default-initargs :message "property is not writable"))
  36
  37 (defun g-object-type-property-type (object-type property-name
  38                                &key assert-readable assert-writable)
  39   (let* ((property (class-property-info object-type property-name)))
  40     (when (and assert-readable (not (g-class-property-definition-readable property)))
  41       (error 'property-unreadable-error
  42              :property-name property-name
  43              :class-name (gtype-name (gtype object-type))))
  44     (when (and assert-writable (not (g-class-property-definition-writable property)))
  45       (error 'property-unwritable-error
  46              :property-name property-name
  47              :class-name (gtype-name (gtype object-type))))
  48     (g-class-property-definition-type property)))
  49
  50 (defun g-object-property-type (object-ptr property-name &key assert-readable assert-writable)
  51   (g-object-type-property-type (g-type-from-object object-ptr) property-name :assert-readable assert-readable :assert-writable assert-writable))
  52
  53 (defun g-object-call-get-property (object-ptr property-name &optional property-type)
  54   (restart-case
  55       (unless property-type
  56         (setf property-type
  57               (g-object-type-property-type (g-type-from-object object-ptr) property-name :assert-readable t)))
  58     (return-nil () (return-from g-object-call-get-property nil)))
  59   (with-foreign-object (value 'g-value)
  60     (g-value-zero value)
  61     (g-value-init value property-type)
  62     (g-object-get-property object-ptr property-name value)
  63     (unwind-protect
  64          (parse-g-value value)
  65       (g-value-unset value))))
  66
  67 (defun g-object-call-set-property (object-ptr property-name new-value
  68                                    &optional property-type)
  69   (unless property-type
  70     (setf property-type
  71           (g-object-type-property-type (g-type-from-object object-ptr) property-name :assert-writable t)))
  72   (with-foreign-object (value 'g-value)
  73     (set-g-value value new-value property-type :zero-g-value t)
  74     (unwind-protect
  75          (g-object-set-property object-ptr property-name value)
  76       (g-value-unset value))))
  77
  78 (defun g-object-call-constructor (object-type args-names args-values
  79                                   &optional args-types)
  80   (unless args-types
  81     (setf args-types
  82           (mapcar (lambda (name)
  83                     (g-object-type-property-type object-type name))
  84                   args-names)))
  85   (let ((args-count (length args-names)))
  86     (with-foreign-object (parameters 'g-parameter args-count)
  87       (loop
  88          for i from 0 below args-count
  89          for arg-name in args-names
  90          for arg-value in args-values
  91          for arg-type in args-types
  92          for arg-g-type = (if arg-type arg-type (g-object-type-property-type object-type arg-name))
  93          for parameter = (mem-aref parameters 'g-parameter i)
  94          do (setf (foreign-slot-value parameter 'g-parameter :name) arg-name)
  95          do (set-g-value (foreign-slot-value parameter 'g-parameter :value) arg-value arg-g-type :zero-g-value t))
  96       (unwind-protect
  97            (g-object-newv object-type args-count parameters)
  98         (loop
  99            for i from 0 below args-count
 100            for parameter = (mem-aref parameters 'g-parameter i)
 101            do (foreign-string-free (mem-ref (foreign-slot-pointer parameter 'g-parameter :name) :pointer))
 102            do (g-value-unset (foreign-slot-pointer parameter 'g-parameter :value)))))))
 103