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