repos
/
qt.gui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
filehistory
normal
|
plain
|
shade
|
zebra
:qt and :qt-impl packages to prevent collision with :cl symbols and fix object with non smoke parent.
Annotate for file src/signal-slot/connect.lisp
2009-06-11 tobias
1
(in-package :cl-smoke.qt-impl)
2010-01-10 tobias
2
2009-06-11 tobias
3
(defgeneric qt:connect (qsignal slot &optional type)
2010-01-10 tobias
4
(:documentation "Connects a signal to a slot."))
08:52:49 '
5
2009-06-11 tobias
6
(defgeneric qt:disconnect (qsignal slot)
2010-01-10 tobias
7
(:documentation "Disconnects a connection."))
08:52:49 '
8
2009-06-11 tobias
9
(defgeneric qt:disconnect-all (qsignal)
2010-01-10 tobias
10
(:documentation "Disconnects all connections of QSIGNAL."))
08:52:49 '
11
'
12
(defun check-argument-types (signal-arguments slot-arguments)
'
13
(assert (= (length signal-arguments) (length slot-arguments)))
'
14
(loop for signal-arg in signal-arguments
'
15
for slot-arg in slot-arguments do
2009-08-02 tobias
16
(assert (subtypep signal-arg slot-arg))))
2010-01-10 tobias
17
08:52:49 '
18
;;FIXME check argument-types
2009-06-11 tobias
19
(defmethod qt:connect ((qsignal qsignal) (qslot qslot) &optional type)
2010-01-10 tobias
20
(assert (or (slot-boundp (signal-object qsignal) 'argument-types)
08:52:49 '
21
(slot-boundp qslot 'arguments))
'
22
((slot-value (signal-object qsignal) 'argument-types)
'
23
(slot-value qslot 'arguments))
'
24
"Argument types must be specified for at least on of
'
25
~A and ~A." qsignal qslot)
'
26
(when (not (slot-boundp (signal-object qsignal) 'argument-types))
'
27
(setf (argument-types (signal-object qsignal))
'
28
(arguments qslot)))
'
29
(when (not (slot-boundp qslot 'arguments))
'
30
(setf (slot-value qslot 'arguments)
'
31
(argument-types (signal-object qsignal))))
'
32
(check-argument-types (argument-types (signal-object qsignal))
'
33
(arguments qslot))
'
34
(unless (connect-id (signal-object qsignal) (id (signal-object qsignal))
'
35
qslot (id qslot)
'
36
type
'
37
(types (arguments qslot)))
'
38
(cerror "Failed to connect ~S to ~S." qsignal qslot)))
'
39
2009-06-11 tobias
40
(defmethod qt:connect ((sender qsignal) (function function) &optional type)
2010-01-10 tobias
41
(let ((slot (make-instance 'qslot
2009-08-02 tobias
42
:args (list (signal-object sender))
2010-01-10 tobias
43
:slot-function function)))
08:52:49 '
44
(unless (connect-id (signal-object sender) (id (signal-object sender))
'
45
slot (id slot)
'
46
type
2009-06-21 tobias
47
(types (arguments sender)))
2010-01-10 tobias
48
(cerror "Failed to connect the function ~S to the signal ~S."
08:52:49 '
49
function sender))))
'
50
'
51
(defclass qt-signal-slot-name ()
'
52
((name :initarg :name
'
53
:reader name)))
'
54
'
55
(defclass qt-signal (qt-signal-slot-name)
'
56
((sender :initarg :sender
'
57
:reader qsender))
'
58
(:documentation "Qt C++ signal."))
'
59
'
60
(defclass qt-slot (qt-signal-slot-name)
'
61
((receiver :initarg :receiver
'
62
:reader receiver))
'
63
(:documentation "Qt C++ slot."))
'
64
2009-06-11 tobias
65
(defgeneric qt:get-slot (receiver name)
2010-01-10 tobias
66
(:documentation "Returns the slot of RECEIVER with NAME.")
08:52:49 '
67
(:method (receiver name)
'
68
(make-instance 'qt-slot :receiver receiver :name name))
'
69
(:method (receiver (function function))
'
70
"Returns a slot for RECEIVER that calls function
'
71
with RECEIVER as the first argument."
2009-06-11 tobias
72
(let ((slot (qt:make-slot #'(lambda (&rest args)
14:59:48 '
73
(apply function (cxx:parent *this*)
'
74
args)))))
2009-08-02 tobias
75
(cxx:set-parent slot receiver)
11:15:21 '
76
slot)))
2010-01-10 tobias
77
2009-06-11 tobias
78
(define-compiler-macro qt:get-slot (&whole form receiver name)
2010-01-10 tobias
79
"Normalize the slot name."
08:52:49 '
80
(if (stringp name)
2009-06-11 tobias
81
(let ((normalized-name (cxx:data
14:59:48 '
82
(qt:meta-object.normalized-signature name))))
2009-08-02 tobias
83
(if (string= name normalized-name) ;; Avoid loop
2010-01-10 tobias
84
form
2009-06-11 tobias
85
`(qt:get-slot ,receiver ,normalized-name)))
2010-01-10 tobias
86
form))
08:52:49 '
87
2009-06-11 tobias
88
(defun qt:get-signal (sender name)
2010-01-10 tobias
89
"Returns the signal NAME of SENDER."
08:52:49 '
90
(make-instance 'qt-signal :sender sender :name name))
'
91
2009-06-11 tobias
92
(define-compiler-macro qt:get-signal (&whole form sender name)
2010-01-10 tobias
93
"Normalize the signal name."
08:52:49 '
94
(if (stringp name)
2009-06-11 tobias
95
(let ((normalized-name (cxx:data
14:59:48 '
96
(qt:meta-object.normalized-signature name))))
2009-08-02 tobias
97
(if (string= name normalized-name) ;; Avoid loop
2010-01-10 tobias
98
form
2009-06-11 tobias
99
`(qt:get-signal ,sender ,normalized-name)))
2010-01-10 tobias
100
form))
08:52:49 '
101
2009-06-11 tobias
102
(defmethod qt:connect ((qt-signal qt-signal) (qt-slot qt-slot) &optional type)
14:59:48 '
103
(unless (qt:object.connect (qsender qt-signal) (qt:qsignal (name qt-signal))
'
104
(receiver qt-slot) (qt:qslot (name qt-slot))
'
105
(or type qt:+auto-connection+))
2010-01-10 tobias
106
(cerror "Failed to connect ~A ~A to ~A ~A."
08:52:49 '
107
(qsender qt-signal) (name qt-signal)
'
108
(receiver qt-slot) (name qt-slot))))
'
109
2009-06-11 tobias
110
(defmethod qt:disconnect ((qt-signal qt-signal) (qt-slot qt-slot))
14:59:48 '
111
(unless (qt:object.disconnect (qsender qt-signal) (qt:qsignal (name qt-signal))
'
112
(receiver qt-slot) (qt:qslot (name qt-slot)))
2010-01-10 tobias
113
(cerror "Failed to disconnect ~A ~A from ~A ~A."
08:52:49 '
114
(receiver qt-slot) (name qt-slot)
'
115
(qsender qt-signal) (name qt-signal))))
'
116
2009-06-11 tobias
117
(defmethod qt:disconnect-all ((sender qt:object))
14:59:48 '
118
(unless (qt:object.disconnect sender 0 0 0)
2010-01-10 tobias
119
(cerror "Failed to disconnect everything connected to ~A."
08:52:49 '
120
sender)))
'
121
'
122
2009-06-11 tobias
123
(defmethod qt:connect ((qt-signal qt-signal) (function function) &optional type)
2010-01-10 tobias
124
(let* ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal)))
08:52:49 '
125
(slot (make-instance 'qslot
2009-07-27 tobias
126
;; Set the sender as the slots parent,
19:39:43 '
127
;; to ensure it does not get gc'ed.
2009-07-22 tobias
128
;; FIXME: unset parent on disconnect
2009-07-01 tobias
129
;; this no not critical beause the slot object
2009-07-22 tobias
130
;; is hidden from the user, who thus can not
22:21:01 '
131
;; connect it to other signals.
2009-07-27 tobias
132
:args (list (qsender qt-signal))
2010-01-10 tobias
133
:slot-function function
08:52:49 '
134
:argument-types
'
135
(method-arguments-type
'
136
(cxx:meta-object (qsender qt-signal))
'
137
signal-id))))
'
138
(if (connect-id (qsender qt-signal) signal-id
'
139
slot (id slot)
'
140
type (types (arguments slot)))
'
141
(cxx:connect-notify (qsender qt-signal)
'
142
(name qt-signal))
'
143
(cerror "Ignore" "Failed to connect the signal ~S of ~S to the function ~S."
'
144
(name qt-signal) (qsender qt-signal) function))))
'
145
2009-06-11 tobias
146
(defmethod qt:connect ((qt-signal qt-signal) (slot qslot) &optional type)
2010-01-10 tobias
147
(let ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal))))
08:52:49 '
148
(if (slot-boundp slot 'arguments)
'
149
(check-argument-types (method-arguments-type (cxx:meta-object
'
150
(qsender qt-signal))
'
151
signal-id)
'
152
(arguments slot))
'
153
(setf (slot-value slot 'arguments)
'
154
(method-arguments-type (cxx:meta-object (qsender qt-signal))
'
155
signal-id)))
'
156
(if (connect-id (qsender qt-signal) signal-id
'
157
slot (id slot)
'
158
type (types (arguments slot)))
'
159
(cxx:connect-notify (qsender qt-signal)
'
160
(name qt-signal))
'
161
(cerror "Ignore" "Failed to connect the signal ~S of ~S to the slot ~S."
'
162
(name qt-signal) (qsender qt-signal) slot))))
'
163
2009-06-11 tobias
164
(defmethod qt:connect ((qsignal qsignal) (slot qt-slot) &optional type)
2010-01-10 tobias
165
(let ((slot-id (find-slot-id (receiver slot) (name slot))))
08:52:49 '
166
(if (slot-boundp (signal-object qsignal) 'argument-types)
'
167
(check-argument-types (argument-types (signal-object slot))
'
168
(method-arguments-type (cxx:meta-object
'
169
(receiver slot))
'
170
slot-id))
'
171
(setf (argument-types (signal-object qsignal))
'
172
(method-arguments-type (cxx:meta-object (receiver slot))
'
173
slot-id)))
'
174
(unless (connect-id (signal-object qsignal) (id (signal-object qsignal))
'
175
(receiver slot) slot-id
'
176
type
'
177
(types (argument-types (signal-object qsignal))))
'
178
(cerror "Failed to connect ~S to ~S." qsignal slot))))
'
179
'
180
'
181
(defun connect-id (sender signal-id receiver slot-id type types)
2009-06-11 tobias
182
(qt:meta-object.connect sender signal-id
2010-01-10 tobias
183
receiver slot-id
08:52:49 '
184
(if (null type)
2009-06-11 tobias
185
(value qt:+auto-connection+)
2009-08-27 tobias
186
(value type))
2010-01-10 tobias
187
types))
08:52:49 '
188
'
189
(defun disconnect-id (sender signal-id receiver slot-id)
2009-06-11 tobias
190
(qt:meta-object.disconnect sender signal-id receiver slot-id))