src/signal-slot/slot.lisp
Sun Apr 5 19:56:16 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
--- old-qt.core/src/signal-slot/slot.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/signal-slot/slot.lisp 2014-11-11 13:37:58.000000000 +0100
@@ -0,0 +1,84 @@
+(in-package :qt)
+(declaim (optimize (debug 3)))
+
+(defclass qslot (object)
+ ((arguments :reader arguments :initarg :argument-types
+ :documentation "List of the argument types for the slot.")
+ (function :reader slot-function :initarg :slot-function
+ :initform (error "no function specified")
+ :documentation "The function called when the slot is invoked."))
+ (:metaclass smoke::smoke-wrapper-class)
+ (:documentation "A Qt slot that calls its associated function"))
+
+(defun make-slot (function &optional (arguments nil arguments-p))
+ "Returns a slot that calls FUNCTION when it receives a signal."
+ (if arguments-p
+ (make-instance 'qslot
+ :slot-function function
+ :argument-types arguments)
+ (make-instance 'qslot
+ :slot-function function)))
+
+(defmethod id ((slot qslot))
+ (cxx:method-count (cxx:meta-object slot)))
+
+(defparameter *sender* nil)
+(defmacro sender ()
+ "Returns the sender that invoked the slot."
+ `*sender*)
+
+(defun method-argument-count (metaobject index)
+ "Returns the number of arguments for the method INDEX of METAOBJECT."
+ (let ((signature (cxx:signature (cxx:method metaobject index))))
+ (setf signature (subseq signature (1+ (position #\( signature))
+ (position #\) signature :from-end t)))
+ (if (= 0 (length signature))
+ 0
+ (1+ (count #\, signature)))))
+
+(defmethod cxx::qt-metacall ((slot qslot) &rest args
+ &aux (a (third args)))
+ "Invoke the slots function when it is called. The return value
+of the invoked slot function is ignored."
+ (let ((id (call-next-method)))
+ (if (< id 0)
+ id
+ (if (enum= (first args) meta-object.+invoke-meta-method+)
+ (progn
+ (case id
+ (0 (let ((*sender* (cxx:sender slot)))
+ (apply (slot-function slot)
+ (arguments-to-lisp a (arguments slot))))))
+ (1- id))
+ id))))
+
+(defun find-signal-id (sender signal)
+ "Returns the ID of SIGNAL from SENDER."
+ (let ((id (cxx:index-of-signal (cxx:meta-object sender)
+ (cxx:data (meta-object.normalized-signature signal)))))
+ (when (< id 0)
+ (error "No signal ~S for class ~S."
+ signal (class-of sender)))
+ id))
+
+(defun connect-function (sender signal function &optional (type 0))
+ "Connects FUNCTION to the SIGNAL of SENDER.
+The return value of FUNCTION is ignored."
+ (let* ((signal-id (find-signal-id sender signal))
+ (slot (make-instance 'qslot
+ :args (list sender)
+ :slot-function function
+ :argument-types (method-arguments-type
+ (cxx:meta-object sender)
+ signal-id))))
+ (let ((ret (static-call "QMetaObject" "connect#$#$$$"
+ sender
+ signal-id
+ slot
+ (id slot)
+ type
+ (types (arguments slot)))))
+ (if ret
+ (cxx:connect-notify sender signal)
+ (cerror "Failed to connect the signal ~S of ~S to the function ~S."
+ signal sender function)))))