Thu Jul 2 19:34:07 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
diff -rN -u old-commonqt/commonqt.mbd new-commonqt/commonqt.mbd
--- old-commonqt/commonqt.mbd 1970-01-01 01:00:00.000000000 +0100
+++ new-commonqt/commonqt.mbd 2014-10-30 06:54:35.000000000 +0100
@@ -0,0 +1,14 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+(in-package :sysdef-user)
+
+(define-system :cl-smoke.commonqt ()
+ (:version 0 0 1)
+ (:documentation "CL-smoke CommonQT compability layer.")
+ (:author "Tobias Rautenkranz")
+ (:needs :smoke :qt :cl-ppcre :cffi)
+ (:components
+ ("src" module
+ (:components
+ "package"
+ ("signal-slot" (:needs "commonqt"))
+ ("commonqt" (:needs "package"))))))
diff -rN -u old-commonqt/src/commonqt.lisp new-commonqt/src/commonqt.lisp
--- old-commonqt/src/commonqt.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-commonqt/src/commonqt.lisp 2014-10-30 06:54:35.000000000 +0100
@@ -0,0 +1,211 @@
+(in-package :cl-smoke.commonqt)
+
+;;; calling methods
+;;;
+(eval-when (:load-toplevel :compile-toplevel :execute)
+(defun read-perserving-case (stream)
+ (let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (read stream)))
+
+(defun cl-smoke-funcall-form (stream subchar arg)
+ (declare (ignore subchar arg))
+ (let ((method (read-perserving-case stream)))
+ (if (string= "new" (symbol-name method))
+ `(lambda (&rest args)
+ (make-instance
+ ',(smoke::lispify (symbol-name (read-perserving-case stream)) :cl-smoke.qt)
+ :args args))
+ (let ((object (read stream)))
+ (if (stringp object)
+ `(lambda (&rest args)
+ (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
+ (find-class ',(smoke::lispify object :cl-smoke.qt))
+ args))
+ `(lambda (&rest args)
+ (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
+ ,object
+ args))))))))
+
+(eval-when (:load-toplevel :compile-toplevel)
+ (set-dispatch-macro-character #\# #\_ #'cl-smoke-funcall-form))
+
+;;; Instantiating
+;;;
+(defun new (instance &rest arguments)
+ "Calls the C++ construor for INSTANCE with ARGUMENTS."
+ (assert (null-pointer-p (smoke:pointer instance)))
+ (setf (slot-value instance 'smoke:pointer)
+ (smoke::call-constructor instance arguments))
+ (assert (not (null-pointer-p (smoke:pointer instance))))
+ (smoke::set-binding instance)
+ (smoke::take-ownership instance)
+ (smoke::add-object instance)
+ instance)
+
+;;; Connecting signals and slots
+;;;
+(defun qsignal (name)
+ (cl-smoke.qt:qsignal name))
+(defun qslot (name)
+ (cl-smoke.qt:qslot name))
+
+;;; QApplication
+;;;
+(defun make-qapplication (&rest arguments)
+ "Returns a new QApplication instance with ARGUMENTS as command line
+arguments argv. argv[0] is set to (LISP-IMPLEMNTATION-TYPE)."
+ (let* ((argc ;(smoke::make-auto-pointer
+ (cffi:foreign-alloc :int
+ :initial-element (1+ (length arguments))))
+ (argv ;(smoke::make-auto-pointer
+ (cffi:foreign-alloc :string
+ :initial-contents
+ (cons (lisp-implementation-type) ;; arg0
+ arguments)))
+ (application (make-instance 'cl-smoke.qt:application :args
+ (list argc argv))))
+ ;; argc & argv must remain valid during the lifetime of application.
+ (setf (cl-smoke.qt:property application 'arguments)
+ (cl-smoke.qt:make-lisp-variant (cons argc argv)))
+ application))
+
+;;; Overriding C++ methods
+(defclass override-gf (standard-generic-function)
+ ((cxx-gf :initarg :cxx-gf
+ :reader cxx-gf))
+ (:metaclass closer-mop:funcallable-standard-class)
+ (:documentation "Redirects its methods to CXX-GF."))
+
+(defmethod add-method ((gf override-gf) method)
+ (add-method (cxx-gf gf) method))
+
+(defmethod remove-method ((gf override-gf) method)
+ (remove-method (cxx-gf gf) method))
+
+;;; Subclassing C++ & defining signals and slots
+;;;
+(defclass qt-class (cxx:class)
+ ((qt-slots :initarg :slots :initform nil) ;; FIXME remove this
+ (signals :initarg :signals :initform nil) ;; FIXME remove this
+ (method-functions :documentation "The signals and slots.")
+ (meta-object)))
+
+(defun setup-meta-object (class qt-superclass)
+ (let ((methods (make-array (+ (length (slot-value class 'signals))
+ (length (slot-value class 'qt-slots)))
+ :element-type 'function
+ :initial-element #'identity))
+ (index 0))
+ (dolist (signal-name (slot-value class 'signals))
+ (incf index)
+ (setf (aref methods index)
+ #'(lambda (this &rest args)
+ (apply #'emit-signal this signal-name args))))
+ (dolist (slot (slot-value class 'qt-slots))
+ (setf (aref methods index)
+ (if (symbolp (second slot))
+ (second slot)
+ (eval `(function ,(second slot)))))
+ (incf index))
+ (setf (slot-value class 'method-functions) methods))
+ (let ((signals (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
+ (slot-value class 'signals)))
+ (slots (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
+ (slot-value class 'qt-slots)))
+ (class-name (class-name class)))
+ (setf (slot-value class 'meta-object)
+ (make-metaobject qt-superclass
+ (format nil "~A::~A"
+ (package-name (symbol-package class-name))
+ (symbol-name class-name))
+ nil
+ signals
+ slots))))
+
+(defun setup-qt-class (qt-class next-method &rest args &key qt-superclass
+ direct-superclasses direct-default-initargs
+ override &allow-other-keys)
+ (assert (null direct-superclasses))
+ (dolist (method override)
+ (ensure-generic-function
+ (second method)
+ :generic-function-class (find-class 'override-gf)
+ :lambda-list '(this &rest args)
+ :cxx-gf (fdefinition (smoke::lispify (first method) :cxx))))
+ (apply next-method qt-class
+ :direct-default-initargs ;; the C++ instance is constructed with #'NEW
+ (cons `(:pointer (null-pointer) ,#'null-pointer)
+ direct-default-initargs)
+ :direct-superclasses
+ (list (find-qclass (first qt-superclass)))
+ args)
+ (setup-meta-object qt-class (find-qclass (first qt-superclass))))
+
+(defmethod initialize-instance :around ((class qt-class)
+ &rest args)
+ (apply #'setup-qt-class class #'call-next-method args)
+ (closer-mop:ensure-method #'cxx:meta-object
+ '(lambda (this)
+ (slot-value (class-of this) 'meta-object))
+ :specializers (list class))
+ (closer-mop:ensure-method
+ #'cxx:qt-metacall
+ '(lambda (this call id arguments)
+ (let ((m-id (call-next-method)))
+ (if (< m-id 0)
+ m-id
+ (if (enum= call cl-smoke.qt:meta-object.+invoke-meta-method+)
+ (progn
+ (when (< m-id (length (slot-value (class-of this)
+ 'method-functions)))
+ (with-simple-restart
+ (continue "Skip the method ~A of ~A."
+ id
+ this)
+ (apply (aref (slot-value (class-of this) 'method-functions)
+ m-id)
+ this
+ (cl-smoke.qt-impl::arguments-to-lisp
+ arguments
+ (cl-smoke.qt-impl::method-arguments-type
+ (cxx:meta-object this) id)))))
+ (- m-id
+ (length (slot-value (class-of this) 'method-functions))))
+ m-id))))
+ :specializers (list class (find-class t) (find-class t) (find-class t))))
+
+(defmethod reinitialize-instance :around ((qt-class qt-class) &rest args)
+ (apply #'setup-qt-class qt-class #'call-next-method args))
+
+(defun emit-signal (object signal-name &rest arguments)
+ "Emits the signal SIGNAL-NAME of OBJECT using ARGUMENTS."
+ (let* ((meta-object (slot-value (class-of object) 'meta-object))
+ (id (#_indexOfSignal meta-object signal-name)))
+ (assert (>= id 0)
+ ()
+ "No signal ~A of ~A." signal-name object)
+ (cl-smoke.qt-impl::activate
+ object id (cl-smoke.qt-impl::method-arguments-type meta-object id)
+ arguments)))
+
+(defmacro call-next-qmethod ()
+ "Calls the next method."
+ '(call-next-method))
+
+
+;;; Enum values
+;;;
+(defun primitive-value (enum)
+ "Returns the integer value of ENUM."
+ (cxx-support:value enum))
+
+;;; Type disambiguation
+;;;
+;; No-op since we have overload resolution.
+(setf (fdefinition 'uint) #'identity
+ (fdefinition 'int) #'identity)
+
+(defun find-qclass (class-name)
+ "Returns the CLOS class for the C++ CLASS-NAME string."
+ (find-class (smoke::lispify class-name :cl-smoke.qt)))
diff -rN -u old-commonqt/src/package.lisp new-commonqt/src/package.lisp
--- old-commonqt/src/package.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-commonqt/src/package.lisp 2014-10-30 06:54:35.000000000 +0100
@@ -0,0 +1,33 @@
+;; Remove the :qt nickname of :cl-smoke.qt to allow
+;; :cl-smoke.commonqt to use it.
+(eval-when (:load-toplevel :compile-toplevel)
+ (rename-package :cl-smoke.qt :cl-smoke.qt))
+
+(defpackage :cl-smoke.commonqt
+ (:use :cl :cxx-support :cffi)
+ (:nicknames :qt)
+ (:export #:new
+
+ #:qsignal
+ #:qslot
+
+ #:make-qapplication
+
+ #:qt-class
+
+ #:emit-signal
+ #:call-next-qmethod
+ #:primitive-value
+
+ #:uint
+ #:int))
+
+;; No named-readtables support; fake it.
+;;
+(defpackage :named-readtables
+ (:use :cl)
+ (:export #:in-readtable))
+
+(in-package :named-readtables)
+(defun in-readtable (name)
+ (declare (ignore name)))
diff -rN -u old-commonqt/src/signal-slot.lisp new-commonqt/src/signal-slot.lisp
--- old-commonqt/src/signal-slot.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-commonqt/src/signal-slot.lisp 2014-10-30 06:54:35.000000000 +0100
@@ -0,0 +1,131 @@
+;;; Copyright (c) 2009 David Lichteblau. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;;
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;;
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-smoke.commonqt)
+
+(defclass class-info ()
+ ((key :initarg :key
+ :accessor entry-key)
+ (value :initarg :value
+ :accessor entry-value)))
+
+(defclass slot-or-signal ()
+ ((name :initarg :name
+ :accessor entry-name)
+ (full-name :initarg :full-name
+ :accessor entry-full-name)
+ (arg-types :initarg :arg-types
+ :accessor entry-arg-types)
+ (reply-type :initarg :reply-type
+ :accessor entry-reply-type)))
+
+(defun make-slot-or-signal (signature)
+ (let ((signature (#_data
+ (#_normalizedSignature "QMetaObject" signature))))
+ (cl-ppcre:register-groups-bind
+ (a b c d)
+ ("^(([\\w,<>:]*)\\s+)?([^\\s]*)\\((.*)\\)" signature)
+ (declare (ignore a))
+ (make-instance 'slot-or-signal
+ :name c
+ :full-name (concatenate 'string c "(" d ")")
+ :arg-types d
+ :reply-type (if (or (null b) (equal b "void")) "" b)))))
+
+(defconstant +access-protected+ #x01)
+(defconstant +access-public+ #x02)
+(defconstant +method-signal+ #x04)
+(defconstant +method-slot+ #x08)
+
+(cffi:defcstruct qmeta-object
+ "QMetaObject (a POD struct)"
+ (super-data :pointer)
+ (string-data :pointer)
+ (data :pointer)
+ (extra-data :pointer))
+
+(defun make-metaobject (parent class-name class-infos signals slots)
+ (let ((data (make-array 0 :fill-pointer 0 :adjustable t))
+ (table (make-hash-table))
+ (stream (make-string-output-stream)))
+ (labels ((intern-string (s)
+ (or (gethash s table)
+ (setf (gethash s table)
+ (prog1
+ (file-position stream)
+ (write-string s stream)
+ (write-char (code-char 0) stream)))))
+ (add (x) (vector-push-extend x data))
+ (add-string (s) (add (intern-string s))))
+ (add 1) ;revision
+ (add (intern-string class-name)) ;class name
+ (add (length class-infos)) ;classinfo
+ (add (if (plusp (length class-infos)) 10 0))
+ (add (+ (length signals) (length slots)))
+ (add (+ 10 (* 2 (length class-infos)))) ;methods
+ (add 0) ;properties
+ (add 0)
+ (add 0) ;enums/sets
+ (add 0)
+ (dolist (entry class-infos)
+ (add-string (entry-key entry))
+ (add-string (entry-value entry)))
+ (dolist (entry signals)
+ (add-string (entry-full-name entry))
+ (add-string (remove #\, (entry-full-name entry) :test-not #'eql))
+ (add-string (entry-reply-type entry))
+ (add-string "") ;tag
+ (add (logior +method-signal+ +access-protected+)))
+ (dolist (entry slots)
+ (add-string (entry-full-name entry))
+ (add-string (remove #\, (entry-full-name entry) :test-not #'eql))
+ (add-string (entry-reply-type entry))
+ (add-string "") ;tag
+ (add (logior +method-slot+ +access-public+)))
+ (add 0))
+ (let ((dataptr (cffi:foreign-alloc :int :count (length data))))
+ (dotimes (i (length data))
+ (setf (cffi:mem-aref dataptr :int i) (elt data i)))
+ (let ((meta-struct (cffi:foreign-alloc 'qmeta-object))
+ (parent-meta-object (#_staticMetaObject parent)))
+ (setf (foreign-slot-value meta-struct 'qmeta-object 'super-data)
+ (smoke:pointer parent-meta-object)
+
+ (foreign-slot-value meta-struct 'qmeta-object 'string-data)
+ (foreign-string-alloc (get-output-stream-string stream))
+
+ (foreign-slot-value meta-struct 'qmeta-object 'data)
+ dataptr
+
+ (foreign-slot-value meta-struct 'qmeta-object 'extra-data)
+ (null-pointer))
+ (let ((meta-object (make-instance 'cl-smoke.qt:meta-object
+ :pointer meta-struct)))
+
+ ;; PARENT-META-OBJECT must remain valid during the lifetime
+ ;; of META-OBJECT.
+ (push parent-meta-object (smoke::owned-objects meta-object))
+ meta-object)))))
diff -rN -u old-commonqt/test.lisp new-commonqt/test.lisp
--- old-commonqt/test.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-commonqt/test.lisp 2014-10-30 06:54:35.000000000 +0100
@@ -0,0 +1,25 @@
+#|
+MALLOC_CHECK_=3 sbcl --noinform --disable-debugger --noprint --load $0 --end-toplevel-options "$@" || exit 1
+exit 0
+# do not use --script to allow loading mudballs with ${HOME}/.sbclrc
+# Used for testing on darcs record.
+|#
+
+
+(in-package :sysdef-user)
+
+(defun load-sysdef (pathname system)
+ (load pathname)
+ (setf (mb.sysdef::pathname-of (find-system system)) pathname))
+
+(defun load-sysdef-file (system-name file-name)
+ "Loads a mbd file in the current directory."
+ (load-sysdef (make-pathname :defaults *default-pathname-defaults*
+ :name file-name
+ :type "mbd")
+ system-name))
+
+(load-sysdef-file :cl-smoke.commonqt "commonqt")
+(mb:test :cl-smoke.commonqt)
+
+(sb-ext:quit)
diff -rN -u old-commonqt/tests/test.lisp new-commonqt/tests/test.lisp
--- old-commonqt/tests/test.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-commonqt/tests/test.lisp 2014-10-30 06:54:35.000000000 +0100
@@ -0,0 +1,92 @@
+(eval-when (:compile-toplevel :load-toplevel)
+ (mb:load :FiveAM))
+
+(in-package :cl-smoke.commonqt)
+
+(5am:def-suite :cl-smoke.commonqt-suite)
+(5am:in-suite :cl-smoke.commonqt-suite)
+
+(5am:test static-call
+ (5am:is (string= (cl-smoke.qt:q-version)
+ (#_qVersion "GlobalSpace"))))
+
+(5am:test enum
+ (5am:is (enum= cl-smoke.qt:+blue+
+ (#_blue "Qt"))))
+
+(5am:test new
+ (5am:is (cxx:= (make-instance 'cl-smoke.qt:byte-array :args '("foobar"))
+ (#_new QByteArray "foobar"))))
+
+(5am:test call
+ (let ((byte-array (make-instance 'cl-smoke.qt:byte-array :args '("foobar"))))
+ (5am:is (string= (cxx:data byte-array)
+ (#_data byte-array)))))
+
+(defclass button ()
+ ((called :accessor button-meta-object-called :initform nil))
+ (:metaclass qt-class)
+ (:qt-superclass "QPushButton")
+ (:override ("metaObject" meta-object)))
+
+(defmethod initialize-instance :after ((instance button) &rest initargs)
+ (declare (ignore initargs))
+ (new instance "foobar"))
+
+(defmethod meta-object ((this button))
+ (setf (button-meta-object-called this) t)
+ (call-next-qmethod))
+
+(5am:test subclassing
+ (cl-smoke.qt:with-app ()
+ (let ((button (make-instance 'button)))
+ (5am:is (string= ""
+ (#_objectName button)))
+ (5am:is (string= "foobar"
+ (#_text button))))))
+
+(5am:test overriding
+ (cl-smoke.qt:with-app ()
+ (let ((button (make-instance 'button)))
+ (5am:is (eql nil (button-meta-object-called button)))
+ (#_metaObject button)
+ (5am:is (eql t (button-meta-object-called button))))))
+
+(defclass mumble ()
+ ((called :accessor mumble-called :initform nil))
+ (:metaclass qt-class)
+ (:qt-superclass "QObject")
+ (:slots ("listen(int)" (lambda (this &optional value)
+ (5am:is (= 37 value))
+ (setf (mumble-called this) t))))
+ (:signals ("say(int)")))
+
+(defmethod initialize-instance :after ((instance mumble) &rest initargs)
+ (declare (ignore initargs))
+ (new instance))
+
+(5am:test signal-slot
+ (let ((mumble (make-instance 'mumble)))
+ (5am:is (eql t
+ (#_connect "QObject"
+ mumble (qt:qsignal "say(int)")
+ mumble (qt:qslot "listen(int)"))))
+ (5am:is (eql nil (mumble-called mumble)))
+ (emit-signal mumble "say(int)" 37)
+ (5am:is (eql t (mumble-called mumble)))
+
+ (5am:is (string= "QObject"
+ (#_className (#_superClass (#_metaObject mumble)))))))
+
+(5am:test make-qapplication
+ (let ((application (make-qapplication)))
+ (5am:is (eql (#_instance "QCoreApplication")
+ application))
+ (5am:is (eql t (typep application 'cl-smoke.qt:application)))
+ (smoke:delete-object application)))
+
+(eval-when (:load-toplevel)
+ (let ((results (5am:run :cl-smoke.commonqt-suite)))
+ (5am:explain! results)
+ (unless (5am:results-status results)
+ (error "Testsuite :qt.suite failed."))))