repos
/
qt.core
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
initial import
Annotate for file src/signal-slot/connect.lisp
2009-04-05 tobias
1
(in-package :qt)
17:56:16 '
2
'
3
(defgeneric connect (qsignal slot &optional type)
'
4
(:documentation "Connects a signal to a slot."))
'
5
'
6
(defgeneric disconnect (qsignal slot)
'
7
(:documentation "Disconnects a connection."))
'
8
'
9
(defgeneric disconnect-all (qsignal)
'
10
(:documentation "Disconnects all connections of QSIGNAL."))
'
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
'
16
(assert (subtypep signal-arg slot-arg))))
'
17
'
18
;;FIXME check argument-types
'
19
(defmethod connect ((qsignal qsignal) (qslot qslot) &optional type)
'
20
(assert (or (slot-boundp (signal-object qsignal) 'argument-types)
'
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
'
40
(defmethod connect ((sender qsignal) (function function) &optional type)
'
41
(let ((slot (make-instance 'qslot
'
42
:args (list (signal-object sender))
'
43
:slot-function function)))
'
44
(unless (connect-id (signal-object sender) (id (signal-object sender))
'
45
slot (id slot)
'
46
type
'
47
(types (arguments sender)))
'
48
(cerror "Failed to connect the function ~S to the signal ~S."
'
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
'
65
(defun get-slot (receiver name)
'
66
"Returns the slot of RECEIVER with NAME."
'
67
(make-instance 'qt-slot :receiver receiver :name name))
'
68
'
69
(defun get-signal (sender name)
'
70
"Returns the signal NAME of SENDER."
'
71
(make-instance 'qt-signal :sender sender :name name))
'
72
'
73
(defmethod connect ((qt-signal qt-signal) (qt-slot qt-slot) &optional type)
'
74
(unless (object.connect (qsender qt-signal) (qsignal (name qt-signal))
'
75
(receiver qt-slot) (qslot (name qt-slot))
'
76
(or type +auto-connection+))
'
77
(cerror "Failed to connect ~A ~A to ~A ~A."
'
78
(qsender qt-signal) (name qt-signal)
'
79
(receiver qt-slot) (name qt-slot))))
'
80
'
81
(defmethod disconnect ((qt-signal qt-signal) (qt-slot qt-slot))
'
82
(unless (object.disconnect (qsender qt-signal) (qsignal (name qt-signal))
'
83
(receiver qt-slot) (qslot (name qt-slot)))
'
84
(cerror "Failed to disconnect ~A ~A from ~A ~A."
'
85
(receiver qt-slot) (name qt-slot)
'
86
(qsender qt-signal) (name qt-signal))))
'
87
'
88
(defmethod disconnect-all ((sender object))
'
89
(unless (object.disconnect sender 0 0 0)
'
90
(cerror "Failed to disconnect everything connected to ~A."
'
91
sender)))
'
92
'
93
'
94
(defmethod connect ((qt-signal qt-signal) (function function) &optional type)
'
95
(let* ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal)))
'
96
(slot (make-instance 'qslot
'
97
;; Set the sender as the slots parent,
'
98
;; to ensure it does not get gc'ed.
'
99
;; FIXME: unset parent on disconnect
'
100
;; this no not critical beause the slot object
'
101
;; is hidden from the user, who thus can not
'
102
;; connect it to other signals.
'
103
:args (list (qsender qt-signal))
'
104
:slot-function function
'
105
:argument-types
'
106
(method-arguments-type
'
107
(cxx:meta-object (qsender qt-signal))
'
108
signal-id))))
'
109
(if (connect-id (qsender qt-signal) signal-id
'
110
slot (id slot)
'
111
type (types (arguments slot)))
'
112
(cxx:connect-notify (qsender qt-signal)
'
113
(name qt-signal))
'
114
(cerror "Ignore" "Failed to connect the signal ~S of ~S to the function ~S."
'
115
(name qt-signal) (qsender qt-signal) function))))
'
116
'
117
(defmethod connect ((qt-signal qt-signal) (slot qslot) &optional type)
'
118
(let ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal))))
'
119
(if (slot-boundp slot 'arguments)
'
120
(check-argument-types (method-arguments-type (cxx:meta-object
'
121
(qsender qt-signal))
'
122
signal-id)
'
123
(arguments slot))
'
124
(setf (slot-value slot 'arguments)
'
125
(method-arguments-type (cxx:meta-object (qsender qt-signal))
'
126
signal-id)))
'
127
(if (connect-id (qsender qt-signal) signal-id
'
128
slot (id slot)
'
129
type (types (arguments slot)))
'
130
(cxx:connect-notify (qsender qt-signal)
'
131
(name qt-signal))
'
132
(cerror "Ignore" "Failed to connect the signal ~S of ~S to the slot ~S."
'
133
(name qt-signal) (qsender qt-signal) slot))))
'
134
'
135
(defmethod connect ((qsignal qsignal) (slot qt-slot) &optional type)
'
136
(let ((slot-id (find-slot-id (receiver slot) (name slot))))
'
137
(if (slot-boundp (signal-object qsignal) 'argument-types)
'
138
(check-argument-types (argument-types (signal-object slot))
'
139
(method-arguments-type (cxx:meta-object
'
140
(receiver slot))
'
141
slot-id))
'
142
(setf (argument-types (signal-object qsignal))
'
143
(method-arguments-type (cxx:meta-object (receiver slot))
'
144
slot-id)))
'
145
(unless (connect-id (signal-object qsignal) (id (signal-object qsignal))
'
146
(receiver slot) slot-id
'
147
type
'
148
(types (argument-types (signal-object qsignal))))
'
149
(cerror "Failed to connect ~S to ~S." qsignal slot))))
'
150
'
151
'
152
(defun connect-id (sender signal-id receiver slot-id type types)
'
153
(static-call "QMetaObject" "connect#$#$$$"
'
154
sender
'
155
signal-id
'
156
receiver
'
157
slot-id
'
158
(if (null type)
'
159
(value +auto-connection+)
'
160
(value type))
'
161
types))
'
162
'
163
(defun disconnect-id (sender signal-id receiver slot-id)
'
164
(static-call "QMetaObject" "disconnect#$#$"
'
165
sender
'
166
signal-id
'
167
receiver
'
168
slot-id))