Thu Jul 23 00:21:01 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* support packages for symbols as property names.

--- old-qt.gui/src/properties.lisp 2014-10-30 07:45:18.000000000 +0100

+++ new-qt.gui/src/properties.lisp 2014-10-30 07:45:18.000000000 +0100

@@ -2,7 +2,28 @@

(defun reverse-lispify (symbol)

"Converts the name of symbol to C++ style."

- (smoke::lisp-to-cxx (symbol-name symbol)))

+ (if (eq (symbol-package symbol)

+ (find-package :keyword))

+ (smoke::lisp-to-cxx (symbol-name symbol))

+ (concatenate 'string

+ (package-name (symbol-package symbol))

+ "::"

+ (symbol-name symbol))))

+

+(defun property-package (name)

+ (let ((package-end (search "::" name)))

+ (if package-end

+ (values

+ (find-package (intern (subseq name 0 package-end) :keyword))

+ (+ 2 package-end))

+ (values (find-package :keyword) 0))))

+

+(defun lispify-property-name (name)

+ (multiple-value-bind (package name-start)

+ (property-package name)

+ (if (= 0 name-start)

+ (smoke::lispify name package)

+ (intern (subseq name name-start) package))))

(defun property-name (name)

"The property name is a string or a to camelCase converted symbol."

@@ -12,33 +33,48 @@

(defun qt:property (object name)

"Returns the property NAME of OBJECT."

+ (declare (type qt:object object)

+ (type (or string symbol) name))

+ (assert (qt:property-p object name)

+ (object name)

+ "~A has no property ~A." object name)

(qt:from-variant (cxx:property object (property-name name))))

-

(defun (setf qt:property) (new-value object name)

- (cxx:set-property object (property-name name)

- (make-instance 'qt:variant

- :args (list new-value)))

+ (declare (type qt:object object)

+ (type (or string symbol) name))

+ (cxx:set-property object (property-name name)

+ (make-instance 'qt:variant :arg0 new-value))

new-value)

(defun qt:remove-property (object name)

"Removes the property NAME from OBJECT."

+ (declare (type qt:object object)

+ (type (or string symbol) name))

(setf (qt:property object name) (qt:make-variant)))

(defun qt:property-p (object name)

"Returns T when NAME is a property of OBJECT and NIL otherwise."

+ (declare (type qt:object object)

+ (type (or string symbol) name))

(qt:variant-boundp (cxx:property object (property-name name))))

(defun meta-object-properties (meta-object &optional (all t))

"Returns a list of the properties of META-OBJECT."

(loop for index from (if all 0 (cxx:property-offset meta-object))

below (cxx:property-count meta-object)

- collect (smoke::lispify (cxx:name (cxx:property meta-object index)))))

+ collect (lispify-property-name (cxx:name (cxx:property meta-object index)))))

+

+(defun sort-symbols (symbols)

+ (sort symbols

+ #'(lambda (a b)

+ (string<= (write-to-string a) (write-to-string b)))))

(defgeneric qt:class-properties (class)

(:documentation "Returns a list of the properties of CLASS.")

(:method ((class class))

- (meta-object-properties (cxx:static-meta-object class)))

+ (sort-symbols

+ (meta-object-properties (cxx:static-meta-object class))))

(:method ((symbol symbol))

(qt:class-properties (find-class symbol))))

@@ -50,10 +86,12 @@

(qt:class-direct-properties (find-class symbol))))

(defun dynamic-properties (object)

- (map 'list (compose #'smoke::lispify #'cxx:data)

+ (map 'list (compose #'lispify-property-name #'cxx:data)

(cxx:dynamic-property-names object)))

(defun qt:properties (object)

"Returns a list of the properties of OBJECT."

- (nconc (dynamic-properties object)

- (meta-object-properties (cxx:meta-object object))))

+ (declare (type qt:object object))

+ (sort-symbols

+ (nconc (dynamic-properties object)

+ (meta-object-properties (cxx:meta-object object)))))