darcs - commonqt

4 ;;; Redistribution and use in source and binary forms, with or without

5 ;;; modification, are permitted provided that the following conditions

6 ;;; are met:

7 ;;;

8 ;;; * Redistributions of source code must retain the above copyright

9 ;;; notice, this list of conditions and the following disclaimer.

10 ;;;

11 ;;; * Redistributions in binary form must reproduce the above

12 ;;; copyright notice, this list of conditions and the following

13 ;;; disclaimer in the documentation and/or other materials

14 ;;; provided with the distribution.

15 ;;;

16 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED

17 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED

18 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE

19 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY

20 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

21 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE

22 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS

23 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,

24 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING

25 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS

26 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

28 (in-package :cl-smoke.commonqt)

30 (defclass class-info ()

31 ((key :initarg :key

32 :accessor entry-key)

33 (value :initarg :value

34 :accessor entry-value)))

36 (defclass slot-or-signal ()

37 ((name :initarg :name

38 :accessor entry-name)

39 (full-name :initarg :full-name

40 :accessor entry-full-name)

41 (arg-types :initarg :arg-types

42 :accessor entry-arg-types)

43 (reply-type :initarg :reply-type

44 :accessor entry-reply-type)))

46 (defun make-slot-or-signal (signature)

47 (let ((signature (#_data

48 (#_normalizedSignature "QMetaObject" signature))))

49 (cl-ppcre:register-groups-bind

50 (a b c d)

51 ("^(([\\w,<>:]*)\\s+)?([^\\s]*)\\((.*)\\)" signature)

52 (declare (ignore a))

53 (make-instance 'slot-or-signal

54 :name c

55 :full-name (concatenate 'string c "(" d ")")

56 :arg-types d

57 :reply-type (if (or (null b) (equal b "void")) "" b)))))

59 (defconstant +access-protected+ #x01)

60 (defconstant +access-public+ #x02)

61 (defconstant +method-signal+ #x04)

62 (defconstant +method-slot+ #x08)

64 (cffi:defcstruct qmeta-object

65 "QMetaObject (a POD struct)"

66 (super-data :pointer)

67 (string-data :pointer)

68 (data :pointer)

69 (extra-data :pointer))

71 (defun make-metaobject (parent class-name class-infos signals slots)

72 (let ((data (make-array 0 :fill-pointer 0 :adjustable t))

73 (table (make-hash-table))

74 (stream (make-string-output-stream)))

75 (labels ((intern-string (s)

76 (or (gethash s table)

77 (setf (gethash s table)

78 (prog1

79 (file-position stream)

80 (write-string s stream)

81 (write-char (code-char 0) stream)))))

82 (add (x) (vector-push-extend x data))

83 (add-string (s) (add (intern-string s))))

84 (add 1) ;revision

85 (add (intern-string class-name)) ;class name

86 (add (length class-infos)) ;classinfo

87 (add (if (plusp (length class-infos)) 10 0))

88 (add (+ (length signals) (length slots)))

89 (add (+ 10 (* 2 (length class-infos)))) ;methods

90 (add 0) ;properties

91 (add 0)

92 (add 0) ;enums/sets

93 (add 0)

94 (dolist (entry class-infos)

95 (add-string (entry-key entry))

96 (add-string (entry-value entry)))

97 (dolist (entry signals)

98 (add-string (entry-full-name entry))

99 (add-string (remove #\, (entry-full-name entry) :test-not #'eql))

100 (add-string (entry-reply-type entry))

101 (add-string "") ;tag

102 (add (logior +method-signal+ +access-protected+)))

103 (dolist (entry slots)

104 (add-string (entry-full-name entry))

105 (add-string (remove #\, (entry-full-name entry) :test-not #'eql))

106 (add-string (entry-reply-type entry))

107 (add-string "") ;tag

108 (add (logior +method-slot+ +access-public+)))

109 (add 0))

110 (let ((dataptr (cffi:foreign-alloc :int :count (length data))))

111 (dotimes (i (length data))

112 (setf (cffi:mem-aref dataptr :int i) (elt data i)))

113 (let ((meta-struct (cffi:foreign-alloc 'qmeta-object))

114 (parent-meta-object (#_staticMetaObject parent)))

115 (setf (foreign-slot-value meta-struct 'qmeta-object 'super-data)

116 (smoke:pointer parent-meta-object)

117

118 (foreign-slot-value meta-struct 'qmeta-object 'string-data)

119 (foreign-string-alloc (get-output-stream-string stream))

120

121 (foreign-slot-value meta-struct 'qmeta-object 'data)

122 dataptr

123

124 (foreign-slot-value meta-struct 'qmeta-object 'extra-data)

125 (null-pointer))

126 (let ((meta-object (make-instance 'cl-smoke.qt:meta-object

127 :pointer meta-struct)))

128

129 ;; PARENT-META-OBJECT must remain valid during the lifetime

130 ;; of META-OBJECT.

131 (push parent-meta-object (smoke::owned-objects meta-object))

132 meta-object)))))