src/signal-slot/connect.lisp
Sun Jan 10 09:52:49 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Split up in qt.gui & cleanup name prefix.
--- old-qt.gui/src/signal-slot/connect.lisp 2014-10-30 07:42:35.000000000 +0100
+++ new-qt.gui/src/signal-slot/connect.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,204 +0,0 @@
-(in-package :cl-smoke.qt-impl)
-
-(defgeneric qt:connect (qsignal slot &optional type)
- (:documentation "Connects a signal to a slot."))
-
-(defgeneric qt:disconnect (qsignal slot)
- (:documentation "Disconnects a connection."))
-
-(defgeneric qt:disconnect-all (qsignal)
- (:documentation "Disconnects all connections of QSIGNAL."))
-
-(defun check-argument-types (signal-arguments slot-arguments)
- (assert (= (length signal-arguments) (length slot-arguments)))
- (loop for signal-arg in signal-arguments
- for slot-arg in slot-arguments do
- (if (typep signal-arg 'smoke::smoke-type)
- (assert (smoke-type= signal-arg slot-arg))
- (assert (subtypep signal-arg slot-arg)))))
-
-;;FIXME check argument-types
-(defmethod qt:connect ((qsignal qsignal) (qslot qslot) &optional type)
- (assert (or (slot-boundp (signal-object qsignal) 'argument-types)
- (slot-boundp qslot 'arguments))
- ((slot-value (signal-object qsignal) 'argument-types)
- (slot-value qslot 'arguments))
- "Argument types must be specified for at least on of
-~A and ~A." qsignal qslot)
- (when (not (slot-boundp (signal-object qsignal) 'argument-types))
- (setf (argument-types (signal-object qsignal))
- (arguments qslot)))
- (when (not (slot-boundp qslot 'arguments))
- (setf (slot-value qslot 'arguments)
- (argument-types (signal-object qsignal))))
- (check-argument-types (argument-types (signal-object qsignal))
- (arguments qslot))
- (unless (connect-id (signal-object qsignal) (id (signal-object qsignal))
- qslot (id qslot)
- type
- (types (arguments qslot)))
- (cerror "Failed to connect ~S to ~S." qsignal qslot)))
-
-(defmethod qt:connect ((sender qsignal) (function function) &optional type)
- (let ((slot (make-instance 'qslot
- :arg0 (signal-object sender)
- :argument-types (argument-types (signal-object sender))
- :slot-function function)))
-
- (unless (connect-id (signal-object sender) (id (signal-object sender))
- slot (id slot)
- type
- (types (argument-types (signal-object sender))))
- (cerror "Failed to connect the function ~S to the signal ~S."
- function sender))))
-
-(defclass qt-signal-slot-name ()
- ((name :initarg :name
- :reader name)))
-
-(defclass qt-signal (qt-signal-slot-name)
- ((sender :initarg :sender
- :reader qsender))
- (:documentation "Qt C++ signal."))
-
-(defclass qt-slot (qt-signal-slot-name)
- ((receiver :initarg :receiver
- :reader receiver))
- (:documentation "Qt C++ slot."))
-
-(defmethod print-object ((qt-signal qt-signal) stream)
- (print-unreadable-object (qt-signal stream :type t :identity t)
- (when (slot-boundp qt-signal 'sender)
- (princ (qsender qt-signal) stream))
- (princ " " stream)
- (when (slot-boundp qt-signal 'name)
- (princ (name qt-signal) stream))))
-
-(defgeneric qt:get-slot (receiver name)
- (:documentation "Returns the slot of RECEIVER with NAME.")
- (:method (receiver name)
- (make-instance 'qt-slot :receiver receiver :name name))
- (:method (receiver (function function))
- "Returns a slot for RECEIVER that calls function
-with RECEIVER as the first argument."
- (make-instance 'qslot
- :arg0 receiver
- :slot-function #'(lambda (&rest args)
- (apply function (cxx:parent *this*)
- args)))))
-
-(define-compiler-macro qt:get-slot (&whole form receiver name)
- "Normalize the slot name."
- (if (stringp name)
- (let ((normalized-name (cxx:data
- (qt:meta-object.normalized-signature name))))
- (if (string= name normalized-name) ;; Avoid infinite recursion
- form
- `(qt:get-slot ,receiver ,normalized-name)))
- form))
-
-(defun qt:get-signal (sender name)
- "Returns the signal NAME of SENDER."
- (make-instance 'qt-signal :sender sender :name name))
-
-(define-compiler-macro qt:get-signal (&whole form sender name)
- "Normalize the signal name."
- (if (stringp name)
- (let ((normalized-name (cxx:data
- (qt:meta-object.normalized-signature name))))
- (if (string= name normalized-name) ;; Avoid infinite recursion
- form
- `(qt:get-signal ,sender ,normalized-name)))
- form))
-
-(defmethod qt:connect ((qt-signal qt-signal) (qt-slot qt-slot) &optional type)
- (unless (qt:object.connect (qsender qt-signal) (qt:qsignal (name qt-signal))
- (receiver qt-slot) (qt:qslot (name qt-slot))
- (or type qt:+auto-connection+))
- (cerror "Failed to connect ~A ~A to ~A ~A."
- (qsender qt-signal) (name qt-signal)
- (receiver qt-slot) (name qt-slot))))
-
-(defmethod qt:disconnect ((qt-signal qt-signal) (qt-slot qt-slot))
- (unless (qt:object.disconnect (qsender qt-signal) (qt:qsignal (name qt-signal))
- (receiver qt-slot) (qt:qslot (name qt-slot)))
- (cerror "Failed to disconnect ~A ~A from ~A ~A."
- (receiver qt-slot) (name qt-slot)
- (qsender qt-signal) (name qt-signal))))
-
-(defmethod qt:disconnect-all ((sender qt:object))
- (unless (qt:object.disconnect sender 0 0 0)
- (cerror "Failed to disconnect everything connected to ~A."
- sender)))
-
-
-(defmethod qt:connect ((qt-signal qt-signal) (function function) &optional type)
- (let* ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal)))
- (slot (make-instance 'qslot
- :arg0 (qsender qt-signal)
- :slot-function function
- :argument-types
- (method-arguments-type
- (cxx:meta-object (qsender qt-signal))
- signal-id))))
- ;; Ensure that the slot is not gc'ed as long as the QT-SIGNAL
- ;; exists.
- ;;
- ;; FIXME: remove on disconnect.
- ;; This no not critical because the slot
- ;; object is not accessible to the user,
- ;; who thus can not connect it to other
- ;; signals.
- (if (connect-id (qsender qt-signal) signal-id
- slot (id slot)
- type (types (arguments slot)))
- (cxx:connect-notify (qsender qt-signal)
- (name qt-signal))
- (cerror "Ignore" "Failed to connect the signal ~S of ~S to the function ~S."
- (name qt-signal) (qsender qt-signal) function))))
-
-(defmethod qt:connect ((qt-signal qt-signal) (slot qslot) &optional type)
- (let ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal))))
- (if (slot-boundp slot 'arguments)
- (check-argument-types (method-arguments-type (cxx:meta-object
- (qsender qt-signal))
- signal-id)
- (arguments slot))
- (setf (slot-value slot 'arguments)
- (method-arguments-type (cxx:meta-object (qsender qt-signal))
- signal-id)))
- (if (connect-id (qsender qt-signal) signal-id
- slot (id slot)
- type (types (arguments slot)))
- (cxx:connect-notify (qsender qt-signal)
- (name qt-signal))
- (cerror "Ignore" "Failed to connect the signal ~S of ~S to the slot ~S."
- (name qt-signal) (qsender qt-signal) slot))))
-
-(defmethod qt:connect ((qsignal qsignal) (slot qt-slot) &optional type)
- (let ((slot-id (find-slot-id (receiver slot) (name slot))))
- (if (slot-boundp (signal-object qsignal) 'argument-types)
- (check-argument-types (argument-types (signal-object slot))
- (method-arguments-type (cxx:meta-object
- (receiver slot))
- slot-id))
- (setf (argument-types (signal-object qsignal))
- (method-arguments-type (cxx:meta-object (receiver slot))
- slot-id)))
- (unless (connect-id (signal-object qsignal) (id (signal-object qsignal))
- (receiver slot) slot-id
- type
- (types (argument-types (signal-object qsignal))))
- (cerror "Failed to connect ~S to ~S." qsignal slot))))
-
-
-(defun connect-id (sender signal-id receiver slot-id type types)
- (qt:meta-object.connect sender signal-id
- receiver slot-id
- (if (null type)
- qt:+auto-connection+
- type)
- types))
-
-(defun disconnect-id (sender signal-id receiver slot-id)
- (qt:meta-object.disconnect sender signal-id receiver slot-id))