X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.type-info.object.lisp;h=27b7db06ab79370b3ed05085733c768de0433f16;hb=8db173e3df82074b8ca96d00304c4e63b499f598;hp=043bd231cebaff230ec1aa120f6006a33c34c87f;hpb=db0d829452f27bbef68da2afd755b7accc5be5be;p=cl-gtk2.git diff --git a/glib/gobject.type-info.object.lisp b/glib/gobject.type-info.object.lisp index 043bd23..27b7db0 100644 --- a/glib/gobject.type-info.object.lisp +++ b/glib/gobject.type-info.object.lisp @@ -1,4 +1,4 @@ -(in-package :gobject.type-info) +(in-package :gobject) (defstruct g-class-property-definition "Structure describing property of a GObject class. @@ -22,6 +22,20 @@ See accessor functions: constructor-only owner-type) +(defmethod print-object ((instance g-class-property-definition) stream) + (if *print-readably* + (call-next-method) + (print-unreadable-object (instance stream) + (format stream + "PROPERTY ~A ~A.~A (flags:~@[~* readable~]~@[~* writable~]~@[~* constructor~]~@[~* constructor-only~])" + (g-class-property-definition-type instance) + (g-class-property-definition-owner-type instance) + (g-class-property-definition-name instance) + (g-class-property-definition-readable instance) + (g-class-property-definition-writable instance) + (g-class-property-definition-constructor instance) + (g-class-property-definition-constructor-only instance))))) + (setf (documentation 'g-class-property-definition-name 'function) "Name of GObject class property. See @class{g-class-property-definition}. @return{a string}") @@ -78,6 +92,11 @@ See accessor functions: for param = (mem-aref params :pointer i) collect (parse-g-param-spec param)))))) +(defun class-property-info (g-type property-name) + (with-unwind (g-class (g-type-class-ref g-type) g-type-class-unref) + (let* ((param-spec (g-object-class-find-property g-class property-name))) + (when param-spec (parse-g-param-spec param-spec))))) + (defun interface-properties (g-type) "@return{list of properties of GObject interface @code{g-type}. Each property is described by an object of type @class{g-class-property-definition}.} @arg[g-type]{an integer or a string specifying the GType}" @@ -89,150 +108,3 @@ See accessor functions: for i from 0 below (mem-ref n-properties :uint) for param = (mem-aref params :pointer i) collect (parse-g-param-spec param)))))) - -(defstruct enum-item - "A structure describing a single enumeration item. - -See accessor functions: -@itemize{ -@item{@fun{enum-item-name}} -@item{@fun{enum-item-value}} -@item{@fun{enum-item-nick}} -}" - name value nick) - -(setf (documentation 'enum-item-name 'function) - "The C name of enum item, e.g. \"GTK_WINDOW_TOPLEVEL\". -@return{a string}") - -(setf (documentation 'enum-item-value 'function) - "The numeric value of enum item. -@return{an integer}") - -(setf (documentation 'enum-item-nick 'function) - "The \"nickname\" of enum item. Nickname is a short name of enum item. E.g., \"toplevel\". -@return{a string}") - -(defun get-enum-items (type) - "Gets the list of enum items that belong to GEnum type @code{type} -@arg[type]{a string or an integer specifying GEnum type} -@return{a list of @class{enum-item} objects}" - (assert (g-type-is-a type +g-type-enum+)) - (let ((g-class (g-type-class-ref type))) - (unwind-protect - (loop - with n = (foreign-slot-value g-class 'g-enum-class :n-values) - with values = (foreign-slot-value g-class 'g-enum-class :values) - for i from 0 below n - for enum-value = (mem-aref values 'g-enum-value i) - collect (make-enum-item - :name (foreign-slot-value enum-value 'g-enum-value - :name) - :value (foreign-slot-value enum-value 'g-enum-value - :value) - :nick (foreign-slot-value enum-value 'g-enum-value - :nick))) - (g-type-class-unref g-class)))) - -(defstruct flags-item - "A structure describing a single flags item. - -See accessor functions: -@itemize{ -@item{@fun{flags-item-name}} -@item{@fun{flags-item-value}} -@item{@fun{flags-item-nick}} -}" - name value nick) - -(setf (documentation 'flags-item-name 'function) - "The C name of flags item, e.g. \"GDK_PROPERTY_CHANGE_MASK\". -@return{a string}") - -(setf (documentation 'flags-item-value 'function) - "The numeric value of flags item. -@return{an integer}") - -(setf (documentation 'flags-item-nick 'function) - "The \"nickname\" of flags item. Nickname is a short name of flags item. E.g., \"property-change-mask\". -@return{a string}") - -(defun get-flags-items (type) - "Gets the list of flags items that belong to GFlags type @code{type} -@arg[type]{a string or an integer specifying GFlags type} -@return{a list of @class{flags-item} objects}" - (assert (g-type-is-a type +g-type-flags+)) - (let ((g-class (g-type-class-ref type))) - (unwind-protect - (loop - with n = (foreign-slot-value g-class 'g-flags-class :n-values) - with values = (foreign-slot-value g-class 'g-flags-class :values) - for i from 0 below n - for flags-value = (mem-aref values 'g-flags-value i) - collect (make-flags-item - :name (foreign-slot-value flags-value 'g-flags-value - :name) - :value (foreign-slot-value flags-value 'g-flags-value - :value) - :nick (foreign-slot-value flags-value 'g-flags-value - :nick))) - (g-type-class-unref g-class)))) - -(defstruct signal-info - id - name - owner-type - flags - return-type - param-types - detail) - -(defmethod print-object ((instance signal-info) stream) - (if *print-readably* - (call-next-method) - (print-unreadable-object (instance stream) - (format stream - "Signal [#~A] ~A ~A.~A~@[::~A~](~{~A~^, ~})~@[ [~{~A~^, ~}]~]" - (signal-info-id instance) - (g-type-string (signal-info-return-type instance)) - (g-type-string (signal-info-owner-type instance)) - (signal-info-name instance) - (signal-info-detail instance) - (mapcar #'g-type-string (signal-info-param-types instance)) - (signal-info-flags instance))))) - -(defun query-signal-info (signal-id) - (with-foreign-object (q 'g-signal-query) - (g-signal-query signal-id q) - (assert (not (zerop (foreign-slot-value q 'g-signal-query :signal-id)))) - (let ((param-types - (iter (with param-types = (foreign-slot-value q 'g-signal-query :param-types)) - (for i from 0 below (foreign-slot-value q 'g-signal-query :n-params)) - (for param-type = (mem-aref param-types '(g-type-designator :mangled-p t) i)) - (collect param-type)))) - (make-signal-info :id signal-id - :name (foreign-slot-value q 'g-signal-query :signal-name) - :owner-type (foreign-slot-value q 'g-signal-query :owner-type) - :flags (foreign-slot-value q 'g-signal-query :signal-flags) - :return-type (foreign-slot-value q 'g-signal-query :return-type) - :param-types param-types)))) - -(defun parse-signal-name (owner-type signal-name) - (with-foreign-objects ((signal-id :uint) (detail 'glib:g-quark)) - (when (g-signal-parse-name signal-name owner-type signal-id detail t) - (let ((signal-info (query-signal-info (mem-ref signal-id :uint)))) - (setf (signal-info-detail signal-info) (mem-ref detail 'g-quark)) - signal-info)))) - -(defun type-signals (type &key include-inherited) - (unless (= (g-type-numeric type) +g-type-invalid+) - (let ((signals (with-foreign-object (n-ids :uint) - (with-unwind (ids (g-signal-list-ids type n-ids) g-free) - (iter (for i from 0 below (mem-ref n-ids :uint)) - (collect (query-signal-info (mem-aref ids :uint i)))))))) - (if include-inherited - (nconc (type-signals (g-type-parent type) :include-inherited t) - (iter (for interface in (g-type-interfaces type)) - (nconcing (type-signals interface :include-inherited t))) - signals) - signals))))