Sun Apr 5 19:56:16 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* initial import

--- old-qt.core/src/signal-slot/connect.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-qt.core/src/signal-slot/connect.lisp 2014-11-11 13:37:35.000000000 +0100

@@ -0,0 +1,168 @@

+(in-package :qt)

+

+(defgeneric connect (qsignal slot &optional type)

+ (:documentation "Connects a signal to a slot."))

+

+(defgeneric disconnect (qsignal slot)

+ (:documentation "Disconnects a connection."))

+

+(defgeneric 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

+ (assert (subtypep signal-arg slot-arg))))

+

+;;FIXME check argument-types

+(defmethod 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 connect ((sender qsignal) (function function) &optional type)

+ (let ((slot (make-instance 'qslot

+ :args (list (signal-object sender))

+ :slot-function function)))

+ (unless (connect-id (signal-object sender) (id (signal-object sender))

+ slot (id slot)

+ type

+ (types (arguments 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."))

+

+(defun get-slot (receiver name)

+ "Returns the slot of RECEIVER with NAME."

+ (make-instance 'qt-slot :receiver receiver :name name))

+

+(defun get-signal (sender name)

+ "Returns the signal NAME of SENDER."

+ (make-instance 'qt-signal :sender sender :name name))

+

+(defmethod connect ((qt-signal qt-signal) (qt-slot qt-slot) &optional type)

+ (unless (object.connect (qsender qt-signal) (qsignal (name qt-signal))

+ (receiver qt-slot) (qslot (name qt-slot))

+ (or type +auto-connection+))

+ (cerror "Failed to connect ~A ~A to ~A ~A."

+ (qsender qt-signal) (name qt-signal)

+ (receiver qt-slot) (name qt-slot))))

+

+(defmethod disconnect ((qt-signal qt-signal) (qt-slot qt-slot))

+ (unless (object.disconnect (qsender qt-signal) (qsignal (name qt-signal))

+ (receiver qt-slot) (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 disconnect-all ((sender object))

+ (unless (object.disconnect sender 0 0 0)

+ (cerror "Failed to disconnect everything connected to ~A."

+ sender)))

+

+

+(defmethod 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

+ ;; Set the sender as the slots parent,

+ ;; to ensure it does not get gc'ed.

+ ;; FIXME: unset parent on disconnect

+ ;; this no not critical beause the slot object

+ ;; is hidden from the user, who thus can not

+ ;; connect it to other signals.

+ :args (list (qsender qt-signal))

+ :slot-function function

+ :argument-types

+ (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 function ~S."

+ (name qt-signal) (qsender qt-signal) function))))

+

+(defmethod 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 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)

+ (static-call "QMetaObject" "connect#$#$$$"

+ sender

+ signal-id

+ receiver

+ slot-id

+ (if (null type)

+ (value +auto-connection+)

+ (value type))

+ types))

+

+(defun disconnect-id (sender signal-id receiver slot-id)

+ (static-call "QMetaObject" "disconnect#$#$"

+ sender

+ signal-id

+ receiver

+ slot-id))