Sun Apr 5 19:56:16 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
diff -rN -u old-qt.core/CMakeLists.txt new-qt.core/CMakeLists.txt
--- old-qt.core/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/CMakeLists.txt 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,7 @@
+cmake_minimum_required(VERSION 2.6)
+
+project(qt)
+
+add_subdirectory(src)
+
+include(UseDoxygen OPTIONAL)
diff -rN -u old-qt.core/TODO new-qt.core/TODO
--- old-qt.core/TODO 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/TODO 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1 @@
+* QApplication and KCmdLineArgs.init call exit() on e.g. "--help"
diff -rN -u old-qt.core/examples/hello-world.lisp new-qt.core/examples/hello-world.lisp
--- old-qt.core/examples/hello-world.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/examples/hello-world.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,63 @@
+(in-package :qt-examples)
+(declaim (optimize (debug 3)))
+
+(defun hello-world ()
+ "Hello world"
+ (qt:with-app
+ (let ((widget (make-instance 'qt:push-button :args '("Hello world"))))
+ (cxx:show widget)
+ (qt:exec))))
+
+
+(defun hello-world-quit ()
+ "Quit on push-button click"
+ (qt:with-app
+ (let ((quit (make-instance 'qt:push-button :args '("Quit"))))
+ (cxx:resize quit 75 30)
+ (cxx:set-font quit (make-instance 'qt:font :args (list "Times"
+ 18
+ qt:font.+bold+)))
+
+ (qt:object.connect quit (qt:qsignal "clicked()")
+ (qt:app) (qt:qslot "quit()"))
+ (cxx:show quit)
+ (qt:exec))))
+
+(defun hello-world-gc ()
+ "GC on push-button click"
+ (qt:with-app
+ (let ((gc (make-instance 'qt:widget)))
+ (let ((layout (make-instance 'qt:vbox-layout))
+ (button (make-instance 'qt:push-button :args '("GC"))))
+ (trivial-garbage:gc :full t)
+ (cxx:add-widget layout button)
+ (trivial-garbage:gc :full t)
+ (cxx:set-layout gc layout)
+ (trivial-garbage:gc :full t)
+ (qt:connect-function button "clicked()"
+ #'(lambda ()
+ (format t "GC-ing~%")
+ (trivial-garbage:gc :full t))))
+ (trivial-garbage:gc :full t)
+ (cxx:show gc)
+ (trivial-garbage:gc :full t)
+ (qt:exec))))
+
+;; You need to run cmake & make to generate the .po and .qm files
+(defun i18n-hello-world ()
+ "i18n hello world"
+ (qt:with-app
+ (qt:with-translator "hello-world"
+ (let ((widget (make-instance 'qt:label)))
+ (setf (qt:property widget 'window-title)
+ (qt:tr "Lisp Qt Example" "hello-world"))
+ (cxx:set-text widget
+ (format nil (qt:tr "<h1>Hello world</h1>
+
+You are running ~A version ~A on a ~A ~A")
+ (lisp-implementation-type)
+ (lisp-implementation-version)
+ (software-type)
+ (software-version)))
+ (cxx:show widget)
+ (qt:exec)))))
diff -rN -u old-qt.core/examples/package.lisp new-qt.core/examples/package.lisp
--- old-qt.core/examples/package.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/examples/package.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,15 @@
+(defpackage #:qt-examples
+ (:use #:cl)
+ (:export #:hello-world
+ #:i18n-hello-world
+ #:hello-world-quit
+ #:hello-world-gc
+
+ #:class-browser
+
+ #:tick-tack-toe
+ #:repl
+
+ #:launcher
+
+ #:load-ui-file))
diff -rN -u old-qt.core/qt.mbd new-qt.core/qt.mbd
--- old-qt.core/qt.mbd 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/qt.mbd 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,65 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+
+;;; SYSDEF.CMAKE
+(defpackage :sysdef.cmake
+ (:use :cl :sysdef)
+ (:export :cmake-file :cmake-library))
+
+(in-package :sysdef.cmake)
+(defclass sysdef.cmake:cmake-file (source-file)
+ ()
+ (:default-initargs :type "txt"))
+
+(defclass sysdef.cmake:cmake-library (component)
+ ())
+;;; end SYSDEF.CMAKE
+
+(in-package :sysdef-user)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (use-package :sysdef.cmake))
+
+(define-system :qt ()
+ (:version 0 0 1)
+ (:documentation "Smoke Qt bindings.")
+ (:keywords "GUI" "Qt")
+ (:author "Tobias Rautenkranz")
+ (:components
+ ("CMakeLists" sysdef.cmake:cmake-file)
+ ("src" module
+ (:needs "CMakeLists")
+ (:components
+ ("CMakeLists.txt" static-file)
+ "package"
+ ("lib" module
+ (:needs "package")
+ (:components
+ ("libqt-smoke-extra" sysdef.cmake:cmake-library)
+
+ ("CMakeLists.txt" static-file)
+ ("qt-smoke.cpp" static-file)
+ ("lisp-object.h" static-file)
+ ("lisp-object.cpp" static-file)
+ ("qstring.cpp" static-file)
+ ("qstringlist.cpp" static-file)))
+
+ ("qt" (:needs "package" "lib"))
+ ("object" (:needs "qt"))
+ ("application" (:needs "qt"))
+ ("qstring" (:needs "qt"))
+ ("msg-handler" (:needs "lib"))
+ ("painter" (:needs "qt"))
+ ("i18n" (:needs "qt"))
+ ("lisp-object" (:needs "qt" "lib"))
+ ("signal-slot" module
+ (:needs "lisp-object")
+ (:serial t)
+ (:components
+ "signal-slot"
+ "translate"
+ "signal"
+ "slot"
+ "connect"))
+ ("string-list" (:needs "qt" "lib" "qstring"))
+ ("variant" (:needs "qt" "qstring" "lisp-object"))
+ ("properties" (:needs "variant")))))
+ (:needs :smoke :sysdef.cmake :cffi))
diff -rN -u old-qt.core/src/CMakeLists.txt new-qt.core/src/CMakeLists.txt
--- old-qt.core/src/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/CMakeLists.txt 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1 @@
+add_subdirectory(lib)
diff -rN -u old-qt.core/src/application.lisp new-qt.core/src/application.lisp
--- old-qt.core/src/application.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/application.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,104 @@
+(in-package :qt)
+
+(declaim (optimize (debug 3)))
+
+(defvar *app*)
+(defvar *widgets* nil)
+
+(defun app ()
+ "Returns the APPLICATION (or CORE-APPLICATION) object,
+within a WITH-APP."
+ (assert (app-p)
+ (*app*))
+ *app*)
+
+(defun app-p ()
+ "Returns t when the APPLICATION object exists and nil otherwise."
+ (boundp '*app*))
+
+
+(let ((argv (null-pointer))
+ (argc (null-pointer)))
+ (declare (cffi:foreign-pointer argv argc))
+ (defun ensure-app (&optional
+ (application 'application)
+ (args #+sbcl sb-ext:*posix-argv*
+ #-sbcl (list (lisp-implementation-type))))
+ "Constructs the global application object, when there is none,
+with the command line arguments ARGS.
+
+Returns the application object a first value and
+true when a new application was created and false otherwise."
+ (assert (not (null args))
+ (args)
+ "No program name supplied.")
+ (if (app-p)
+ (progn
+ (assert (typep (app) (find-class application))
+ (application)
+ "The existing application object ~A is
+not of type ~A." (app) (find-class application))
+ (values (app) nil))
+ (progn
+; (assert (null-pointer-p (smoke::pointer (core-application.instance))))
+ (foreign-free argv)
+ (foreign-free argc)
+
+ (setf argv (foreign-alloc :string :initial-contents args))
+ (setf argc (foreign-alloc :int :initial-element (length args)))
+ (values (qt:new "QApplication" "QApplication$?" argc argv) t))))
+ (defun kill-app ()
+ (cxx:quit (app))
+ (when (typep (app) (find-class 'qt:application))
+ (application.close-all-windows))
+ (setf *widgets* nil)
+ (trivial-garbage:cancel-finalization (app))
+ ;(smoke::remove-object (smoke::pointer (app)))
+ (smoke::delete-pointer (smoke::pointer (app)) (class-of (app)))
+ (setf (slot-value (app) 'pointer) (null-pointer))
+; (foreign-free argc)
+ (setf argc (null-pointer))
+; (foreign-free argv)
+ (setf argv (null-pointer))
+ (makunbound '*app*)))
+
+(defmacro with-application ((ensure-app remove-app) &body body)
+ (let ((cleanup-p (gensym "cleanup-p")))
+ `(let ((,cleanup-p nil))
+ (multiple-value-setq (*app* ,cleanup-p) ,ensure-app)
+ (unwind-protect
+ (progn
+ ,@body)
+ (when ,cleanup-p
+ ,remove-app
+ (makunbound '*app*))))))
+
+(defmacro with-app (&body body)
+ "Ensures that a APPLICATION instance exists,
+evaluates BODY and executes the APPLICATION instance after BODY.
+The instance can be accessed with:
+APP.
+
+Can be nested.
+
+When a APPLICATION was created, it will be deleted when returning
+from BODY."
+ `(with-application ((ensure-app 'application) (kill-app))
+ ,@body))
+
+(defmacro with-core-app (&body body)
+ `(with-application ((ensure-app 'core-application) (kill-app))
+ ,@body))
+
+
+(defun exec (&rest widgets)
+ "Executes APP."
+ (setf *widgets* (append widgets *widgets*))
+ (restart-bind ((abort-app #'(lambda ()
+ (application.close-all-windows)
+ (cxx:quit (app))
+ (invoke-restart (find-restart 'continue)))
+ :report-function
+ #'(lambda (stream)
+ (format stream "Return from the application event loop."))))
+ (cxx:exec (app))))
diff -rN -u old-qt.core/src/i18n.lisp new-qt.core/src/i18n.lisp
--- old-qt.core/src/i18n.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/i18n.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,42 @@
+(in-package :qt)
+
+(defun tr (message &optional context)
+ "Returns the translated MESSAGE for CONTEXT or
+a string STRING-EQUAL to MESSAGE when no translation was found.
+
+Translations can be loaded with WITH-TRANSLATOR."
+ (qt:core-application.translate (or context "") message))
+
+(defmacro with-installed-translator (translator &body body)
+ `(unwind-protect
+ (progn
+ (cxx:install-translator (qt:app) ,translator)
+ ,@body)
+ (cxx:remove-translator (qt:app) ,translator)))
+
+(defmacro with-translator (base-name &body body)
+ "Loads the translations in the BASE-NAME_LANGCODE.qm file.
+
+Must be in a WITH-APP."
+ (let ((translator (gensym)))
+ `(let ((,translator (make-instance 'translator)))
+ (unless (cxx:load ,translator (format nil "~A_~A"
+ ,base-name
+ (cxx:name (qt:locale.system))))
+ (cerror "Ignore" "Loading the translations ~A for ~A failed."
+ ,base-name (cxx:name (qt:locale.system))))
+ (with-installed-translator ,translator
+ ,@body))))
+
+(defmacro with-libqt-translator (&body body)
+ "Loads the translations for the Qt library.
+
+Must be in a WITH-APP."
+ (let ((translator (gensym)))
+ `(let ((,translator (make-instance 'translator)))
+ (unless (cxx:load ,translator (format nil "qt_~A"
+ (cxx:name (qt:locale.system)))
+ (qt:library-info.location qt:library-info.+translations-path+))
+ (cerror "Ignore" "Loading the Qt library translations failed."))
+ (with-installed-translator ,translator
+ ,@body))))
diff -rN -u old-qt.core/src/lib/CMakeLists.txt new-qt.core/src/lib/CMakeLists.txt
--- old-qt.core/src/lib/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/lib/CMakeLists.txt 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,7 @@
+find_package(Qt4)
+set(QT_DONT_USE_QTGUI true)
+include(${QT_USE_FILE})
+
+set(QT_SMOKE_SOURCES qt-smoke.cpp qstring.cpp qstringlist.cpp lisp-object.cpp)
+add_library(qt-smoke-extra MODULE ${QT_SMOKE_SOURCES})
+target_link_libraries(qt-smoke-extra ${QT_LIBRARIES})
diff -rN -u old-qt.core/src/lib/lisp-object.cpp new-qt.core/src/lib/lisp-object.cpp
--- old-qt.core/src/lib/lisp-object.cpp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/lib/lisp-object.cpp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,179 @@
+#include "lisp-object.h"
+
+#include <QtGlobal>
+#include <QtDebug>
+
+namespace cl_smoke {
+namespace qt {
+
+/** @struct lisp_object::data
+ * @internal
+ * Holds a reference ID for a lisp object and calls
+ * the destructor callback when it is deleted.
+ */
+
+/** @typedef lisp_object::destructor
+ * Destructor.
+ * @param id The ID
+ */
+
+lisp_object::destructor lisp_object::destruct = NULL;
+
+
+/** Constructor. */
+lisp_object::data::data()
+: id(id),
+ is_set(false)
+{ }
+
+/** Constructor.
+ * @param id The ID.
+ */
+lisp_object::data::data(int id)
+: id(id),
+ is_set(true)
+{ }
+
+/** Destructor. */
+lisp_object::data::~data()
+{
+ Q_ASSERT_X(lisp_object::destruct, __func__,
+ "call setup_lisp_object() first.");
+
+ if (this->is_set)
+ (*lisp_object::destruct)(this->id);
+}
+
+/** @class lisp_object
+ * @brief Holds a reference ID to a lisp object.
+ *
+ * The registered destructor callback is called when
+ * the last instance for a specific lisp object is deleted.
+ *
+ * Used for lisp objects in QVariants and signal/slots.
+ */
+
+/** Constructor. */
+lisp_object::lisp_object()
+ : d(new data())
+{ }
+
+/** Constructor.
+ * @param id the ID
+ */
+lisp_object::lisp_object(int id)
+ : d(new data(id))
+{ }
+
+/** Constructor.
+ * @param other the lisp_object to copy
+ */
+lisp_object::lisp_object(const lisp_object& other)
+ : d(other.d)
+{ }
+
+/** @fn lisp_object::id() const
+ * Gets the ID.
+ *
+ * @return the ID
+ */
+
+/** @fn lisp_object::set() const
+ * Determines werter the ID is set.
+ *
+ * @return @c true when the id is set and @c false otherwise.
+ */
+
+/** Sets a new ID.
+ * @param id the ID
+ */
+void
+lisp_object::set_id(int id)
+{
+ Q_ASSERT(this->set() ? id != this->id() : true);
+
+ d = new data(id);
+}
+
+} // namespace qt
+} // namespace cl_smoke
+
+using namespace cl_smoke::qt;
+
+/** Initialize the lisp_object.
+ * @relates cl_smoke::qt::lisp_object
+ * @param destruct destructor callback
+ *
+ * @return the QMetaType ID of lisp_object
+ */
+int
+qt_smoke_setup_lisp_object(void* destruct)
+{
+ Q_ASSERT(destruct != NULL);
+ lisp_object::destruct = reinterpret_cast<lisp_object::destructor>(destruct);
+
+ return qRegisterMetaType<lisp_object>();
+}
+
+/** Gets the ID of @a object.
+ * @relates cl_smoke::qt::lisp_object
+ * @param object the lisp_object.
+ *
+ * @return the ID
+ */
+int
+qt_smoke_lisp_object_id(const void* object)
+{
+ return static_cast<const lisp_object*>(object)->id();
+}
+
+
+/** Determines werter the ID of @a object is set.
+ * @relates cl_smoke::qt::lisp_object
+ * @param object the object
+ *
+ * @return @c true when the ID is set and @c false otherwise.
+ */
+int
+qt_smoke_lisp_object_set(const void* object)
+{
+ return static_cast<const lisp_object*>(object)->set();
+}
+
+/** Makes a new lisp_object.
+ * @relates cl_smoke::qt::lisp_object
+ * @param id the ID
+ *
+ * @return A new lisp_object instance.
+ */
+void*
+qt_smoke_make_lisp_object(int id)
+{
+ return new lisp_object(id);
+}
+
+/** Deletes a lisp_object.
+ * @relates cl_smoke::qt::lisp_object
+ * @param object the lisp_object
+ */
+void*
+qt_smoke_free_lisp_object(void* object)
+{
+ delete static_cast<lisp_object*>(object);
+}
+
+#include <QVariant>
+/** Gets the lisp_object of a QVariant.
+ * @relates cl_smoke::qt::lisp_object
+ * @param variant the QVariant
+ *
+ * @return a new lisp_object.
+ */
+void*
+qt_smoke_lisp_object_value(const void* variant)
+{
+ const QVariant* qvariant = static_cast<const QVariant*>(variant);
+ Q_ASSERT(QVariant::UserType == qvariant->type());
+
+ new lisp_object(qvariant->value<lisp_object>());
+}
diff -rN -u old-qt.core/src/lib/lisp-object.h new-qt.core/src/lib/lisp-object.h
--- old-qt.core/src/lib/lisp-object.h 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/lib/lisp-object.h 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,82 @@
+#ifndef LISP_OBJECT_H
+#define LISP_OBJECT_H
+
+#include <QMetaType>
+#include <QSharedData>
+#include <QExplicitlySharedDataPointer>
+#include <smoke.h>
+
+
+extern "C"
+{
+ int
+ qt_smoke_setup_lisp_object(void* destruct);
+
+ int
+ qt_smoke_lisp_object_id(const void* object);
+
+ int
+ qt_smoke_lisp_object_set(const void* object);
+
+ void*
+ qt_smoke_make_lisp_object(int id);
+
+ void*
+ qt_smoke_free_lisp_object(void* object);
+
+ void*
+ qt_smoke_lisp_object_value(const void* variant);
+}
+
+namespace cl_smoke {
+namespace qt {
+
+class lisp_object
+{
+ public:
+ typedef void (*destructor)(int id);
+
+ lisp_object();
+
+ lisp_object(int id);
+
+ lisp_object(const lisp_object& other);
+
+ inline int
+ id() const
+ { Q_ASSERT(this->set()); return d->id; }
+
+ void
+ set_id(int id);
+
+ inline bool
+ set() const
+ { return d->is_set; }
+
+ friend int
+ ::qt_smoke_setup_lisp_object(void* destruct);
+
+ private:
+ struct data : public QSharedData
+ {
+ data();
+ data(int id);
+ ~data();
+ int id;
+ bool is_set;
+
+ private:
+ Q_DISABLE_COPY(data)
+ };
+
+ QExplicitlySharedDataPointer<data> d;
+
+ static destructor destruct;
+};
+
+} // namespace qt
+} // namespace cl_smoke
+
+Q_DECLARE_METATYPE(cl_smoke::qt::lisp_object);
+
+#endif // LISP_OBJECT_H
diff -rN -u old-qt.core/src/lib/qstring.cpp new-qt.core/src/lib/qstring.cpp
--- old-qt.core/src/lib/qstring.cpp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/lib/qstring.cpp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,44 @@
+#include <QString>
+#include <QtDebug>
+
+/** @file
+ * @brief QString conversion. */
+
+extern "C" {
+
+/** Converts a QString to a QByteArray.
+ * @param qstring Pointer to a QString
+ *
+ * @return a pointer to a newly allocated char array.
+ */
+void*
+qt_smoke_qstring_to_byte_array(const void* qstring)
+{
+ Q_ASSERT(qstring);
+ const QString* string = static_cast<const QString*>(qstring);
+
+ return new QByteArray(string->toLocal8Bit());
+}
+
+/** Frees an QString.
+ * @param qstring the QString to free
+ */
+void
+qt_smoke_free_qstring(void* qstring)
+{
+ delete static_cast<QString*>(qstring);
+}
+
+/** Converts a string to a QString.
+ * @param data a char array
+ * @param length the length of @a data
+ *
+ * @return a newly allocated QString
+ */
+void*
+qt_smoke_string_to_qstring(const char* data, int length)
+{
+ return new QString(QString::fromLocal8Bit(data, length));
+}
+
+} // extern "C"
diff -rN -u old-qt.core/src/lib/qstringlist.cpp new-qt.core/src/lib/qstringlist.cpp
--- old-qt.core/src/lib/qstringlist.cpp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/lib/qstringlist.cpp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,69 @@
+#include <QStringList>
+#include <QtDebug>
+#include <cstring>
+
+/** @file
+ * @brief QStringList conversion. */
+
+extern "C" {
+
+/** Returns the number of items of @a string_list.
+ * @param string_list the QStringList
+ *
+ * @return the number of items
+ */
+int
+qt_smoke_string_list_size(const void* string_list)
+{
+ Q_ASSERT(string_list);
+ return static_cast<const QStringList*>(string_list)->size();
+}
+
+/** Returns the byte array of @a string_list at position @a index.
+ * @param string_list the QStringList
+ * @param index the index of the string
+ *
+ * @return a new allocated byte-array
+ */
+void*
+qt_smoke_string_list_at(const void* string_list, int index)
+{
+ Q_ASSERT(string_list);
+ const QStringList* list = static_cast<const QStringList*>(string_list);
+
+ Q_ASSERT(0 <= index && index < list->size());
+
+ return new QByteArray(list->at(index).toLocal8Bit());
+}
+
+/** Free a QStringList.
+ * @param string_list the QStringList to free
+ */
+void
+qt_smoke_free_string_list(void* string_list)
+{
+ delete static_cast<QStringList*>(string_list);
+}
+
+/** Allocates a new QStringList.
+ *
+ * @return a new QStringList
+ */
+void*
+qt_smoke_make_string_list()
+{
+ return new QStringList();
+}
+
+/** Appends @a string to @a string_list
+ * @param string_list the QStringList
+ * @param data the string
+ * @param length the length of @a data
+ */
+void
+qt_smoke_string_list_append(void* string_list, const char* data, int length)
+{
+ static_cast<QStringList*>(string_list)->append(QString::fromLocal8Bit(data, length));
+}
+
+} // extern "C"
diff -rN -u old-qt.core/src/lib/qt-smoke.cpp new-qt.core/src/lib/qt-smoke.cpp
--- old-qt.core/src/lib/qt-smoke.cpp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/lib/qt-smoke.cpp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,26 @@
+#include <qnamespace.h>
+#include <QEvent>
+#include <QtDebug>
+
+/** @file
+ * @brief Qt support functions */
+
+extern "C" {
+
+/** Registers a callback to be invoked for every QEvent.
+ * @see QCoreApplication::notifyInternal
+ *
+ * @param callback the callback
+ *
+ * @return @c true on success and @c false when the callback table is full.
+ */
+int
+qt_smoke_register_event_notify(void* callback)
+{
+ Q_ASSERT(callback);
+
+ return QInternal::registerCallback(QInternal::EventNotifyCallback,
+ reinterpret_cast<qInternalCallback>(callback));
+}
+
+} // extern "C"
diff -rN -u old-qt.core/src/lisp-object.lisp new-qt.core/src/lisp-object.lisp
--- old-qt.core/src/lisp-object.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/lisp-object.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,62 @@
+(in-package :qt)
+(declaim (optimize (debug 3)))
+
+(defvar *cxx-lisp-objects* (make-hash-table)
+ "Objects that are currently passed in a C++ class.")
+
+(let ((id 0))
+ (defun gen-cxx-lisp-object-id ()
+ "Returns a new unique ID."
+ (incf id)))
+
+(defcfun qt-smoke-setup-lisp-object :int
+ (destruct :pointer))
+
+(defcfun qt-smoke-lisp-object-id :int
+ (object :pointer))
+
+(defcfun qt-smoke-lisp-object-set :int
+ (object :pointer))
+
+(defcfun qt-smoke-make-lisp-object :pointer
+ (id :int))
+
+(defcfun qt-smoke-free-lisp-object :void
+ (object :pointer))
+
+(defcallback destruct-cxx-lisp-object :void
+ ((id :int))
+ (remhash id *cxx-lisp-objects*))
+
+(defvar *cxx-lisp-object-metatype*)
+
+(eval-when (:load-toplevel)
+ (setf *cxx-lisp-object-metatype*
+ (qt-smoke-setup-lisp-object (callback destruct-cxx-lisp-object)))
+ (assert (>= *cxx-lisp-object-metatype*
+ (smoke::value meta-type.+user+))
+ (*cxx-lisp-object-metatype*)
+ "setup of lisp-object failed"))
+
+(defun make-cxx-lisp-object (object)
+ "Constructs a C++ object wrapper for OBJECT."
+ (let ((id (gen-cxx-lisp-object-id)))
+ (setf (gethash id *cxx-lisp-objects*) object)
+ (qt-smoke-make-lisp-object id)))
+
+(defun free-cxx-lisp-object (pointer)
+ "Deletes the lisp_object at POINTER."
+ (qt-smoke-free-lisp-object pointer))
+;; (qmetatype.destroy *cxx-lisp-object-metatype* pointer)) ;; FIXME use this?
+
+(defun translate-cxx-lisp-object (pointer)
+ "Returns the object of the cxx-lisp-object at POINTER.
+
+When beeing received as an argument by a slot,
+the object must not be deallocated."
+ (multiple-value-bind (value present-p)
+ (gethash (qt-smoke-lisp-object-id pointer)
+ *cxx-lisp-objects*)
+ (assert present-p (value present-p)
+ "No object for ~A in ~A" pointer *cxx-lisp-objects*)
+ value))
diff -rN -u old-qt.core/src/msg-handler.lisp new-qt.core/src/msg-handler.lisp
--- old-qt.core/src/msg-handler.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/msg-handler.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,26 @@
+(in-package :qt)
+
+(cffi:defcenum qt-msg-type
+ (:debug-message)
+ (:warning-message)
+ (:critical-message)
+ (:fatal-message))
+
+(defcallback qt-msg-handler :void
+ ((type qt-msg-type)
+ (message :string))
+ (ecase type
+ (:debug-message
+ (write-string "qDebug: " *debug-io*)
+ (write-line message *debug-io*))
+ (:warning-message (warn message))
+ (:critical-message (cerror "Ignore" "~A" message))
+ (:fatal-message (error message))))
+
+(defun register-msg-handler ()
+ (with-foreign-object (handler :pointer)
+ (setf (mem-ref handler :pointer) (callback qt-msg-handler))
+ (qt:q-install-msg-handler handler)))
+
+(eval-when (:load-toplevel)
+ (register-msg-handler))
diff -rN -u old-qt.core/src/object.lisp new-qt.core/src/object.lisp
--- old-qt.core/src/object.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/object.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,190 @@
+(in-package :qt)
+(declaim (optimize (debug 3)))
+
+(let ((object (make-instance 'object)))
+ (defmethod cxx:static-meta-object ((class (eql (find-class 'object))) &rest args)
+ "No OBJECT.STATIC-META-OBJECT (r558420)."
+ (declare (ignore args))
+ (cxx:meta-object object))
+ (defmethod cxx:static-meta-object ((class smoke::smoke-wrapper-class) &rest args)
+ (declare (ignore args))
+ (cxx:static-meta-object (smoke::find-smoke-class class))))
+
+(defmethod documentation :around ((class smoke::smoke-standard-class)
+ (doc-type t))
+ (if (and (subtypep class (find-class 'object))
+ (not (subtypep class (find-class 'smoke::smoke-wrapper-class))))
+ (format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}
+
+Signals:
+~{~T~A~%~}
+Slots:
+~{~T~A~%~}"
+ (call-next-method) (sort (class-properties class) #'string<=)
+ (sort (class-signals class) #'string<=)
+ (sort (class-slots class) #'string<=))
+ (call-next-method)))
+
+(defun meta-object-methods (meta-object &optional (direct-only nil))
+ (loop for index from (if direct-only (cxx:method-offset meta-object) 0)
+ below (cxx:method-count meta-object)
+ collect (cxx:method meta-object index)))
+
+
+(defun meta-object-signals (meta-object)
+ (mapcar #'cxx:signature
+ (remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
+ (cxx:method-type m)))
+ (meta-object-methods meta-object))))
+
+(defun class-signals (class)
+ (meta-object-signals (cxx:static-meta-object class)))
+
+(defun meta-object-slots (meta-object)
+ (mapcar #'cxx:signature
+ (remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
+ (cxx:method-type m)))
+ (meta-object-methods meta-object))))
+
+
+(defun class-slots (class)
+ (meta-object-slots (cxx:static-meta-object class)))
+
+
+(defvar *children* (make-hash-table)
+ "A list of custom subclasses of QObject which have a parent
+and therefor must not be garbage collected.")
+
+(defmethod initialize-instance :after ((object object)
+ &key pointer &allow-other-keys)
+ "Registers the object to the parent when a parent was set in the constructor
+and the objects metaclass is SMOKE-WRAPPER-CLASS."
+ (when (and (null pointer)
+ (null-pointer-p (smoke::pointer object)))
+ (error "Object ~A has not been constructed" object))
+ (when (and (null pointer)
+ (not (null-pointer-p (smoke::pointer object)))
+; (typep (class-of object) 'smoke::smoke-wrapper-class)
+ (not (null-pointer-p (smoke::pointer (cxx:parent object)))))
+ (setf (gethash (smoke::pointer object) *children*) object)))
+
+(define-condition wrapper-gc (storage-condition)
+ ((class-name :initarg :class-name
+ :documentation "The class name of the gc'ed object.")
+ (pointer :initarg :pointer))
+ (:report (lambda (condition stream)
+ (format stream "The object ~A ~A of type smoke-wrapper-class
+has a parent but got garbage collected."
+ (slot-value condition 'class-name)
+ (slot-value condition 'pointer)))))
+
+(let ((get-parent (smoke::make-smoke-method (smoke::make-smoke-class
+ *qt-smoke*
+ "QObject")
+ "parent"))
+ ;; FIXME this leaks memory when QCoreApplication::exec is never called,
+ ;; beause then, deleteLater has no effect.
+ (delete-later (smoke::make-smoke-method (smoke::make-smoke-class
+ *qt-smoke*
+ "QObject")
+ "deleteLater")))
+ (defmethod smoke::make-finalize ((object object))
+ "Delete the qt:object OBJECT,
+ by calling cxx:delete-later iff it has no parent."
+ (let ((pointer (pointer object))
+ (name (class-name (class-of object)))
+ (next (call-next-method)))
+ (if (typep (class-of object) 'smoke::smoke-wrapper-class)
+ #'(lambda ()
+ (handler-case
+ (if (null-pointer-p (smoke::pointer-call get-parent pointer))
+ (smoke::pointer-call delete-later pointer)
+ (error (make-condition 'wrapper-gc :class-name name
+ :pointer pointer)))
+ (condition (condition)
+ (format *debug-io* "error: wrap finalize ~A ~A~%" name
+ condition))))
+ #'(lambda ()
+ (handler-case
+ (progn
+ (when (null-pointer-p (smoke::pointer-call get-parent pointer))
+ (funcall next)))
+ (condition (condition)
+ (format *debug-io* "error: qfinalize ~A ~A ~A~%" name
+ pointer
+ condition)))))))
+ ;(smoke::pointer-call delete-later pointer)))))))
+ )
+(defun cxx-gc ()
+ "Delete the C++ object that have been queued for deletion when
+QT:CORE-APPLICATION.EXEC is run."
+ (core-application.send-posted-events
+ (make-instance 'object :pointer (null-pointer))
+event.+deferred-delete+))
+
+
+;(defmethod upcast-object ((objeckt qobject))
+; (let ((class-name (cxx:classname (cxx:metaobject object))))
+; (if (string= class-name (name (get-class object)))
+; object
+; (let ((real-class (lispify class-name)))
+;;FIXME get smoke module from class name
+; (make-instance
+; :pointer upcast (object class))))))))
+
+
+;(defmethod upcast-object ((event qevent))
+; (case (cxx:type event)
+; (#.qevent.+childadded+
+
+;;;
+;;; The event-notify callback get called by QCoreApplication,
+;;; on notification of an event.
+;;;
+;;; The DATA argument is an array of size three, containing the pointers:
+;;; void* receiver
+;;; void* event
+;;; void* result
+;;; in that order.
+;;;
+;;; Returning true marks the event as handled; false on the other hand
+;;; leaves the event processing unchanged.
+;;;
+;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent *event)
+
+(cffi:defcallback event-notify smoke:cxx-bool
+ ((data :pointer))
+ (declare (optimize (speed 3)))
+ (let ((event (make-instance 'event :pointer (cffi:mem-aref data :pointer 1)
+ :owned-p nil)))
+ (enum-case (cxx:type event)
+ (event.+child-added+
+ (let* ((child-event (make-instance 'child-event
+ :pointer
+ (smoke::upcast event (find-class 'child-event))
+ :owned-p nil))
+ (child (smoke::get-object
+ (smoke::pointer (cxx:child child-event)))))
+; (when (and child
+; (typep (class-of child)
+; 'smoke::smoke-wrapper-class))
+ (when child
+ (setf (gethash (smoke::pointer child) *children*) child))))
+ (event.+child-removed+
+ (let* ((child-event (make-instance 'child-event
+ :pointer (smoke::upcast event
+ (find-class 'child-event))
+ :owned-p nil)))
+ (remhash (smoke::pointer (cxx:child child-event)) *children*)))))
+ nil)
+
+(cffi:defcfun qt-smoke-register-event-notify :boolean
+ (event-notify :pointer))
+
+(defun register-event-notify ()
+ (let ((ret (qt-smoke-register-event-notify (cffi:callback event-notify))))
+ (unless ret
+ (error "The event-notify callback table is full."))))
+
+(eval-when (:load-toplevel)
+ (register-event-notify))
diff -rN -u old-qt.core/src/package.lisp new-qt.core/src/package.lisp
--- old-qt.core/src/package.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/package.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,40 @@
+(defpackage :qt
+ (:use :cl :asdf :smoke :cffi :bordeaux-threads :cxx-support)
+ (:export #:new
+ #:call
+
+ #:app
+ #:app-p
+ #:exec
+ #:with-app
+ #:with-core-app
+
+ #:with-painter
+
+ #:tr
+ #:with-translator
+ #:with-libqt-translator
+
+ #:qmethod
+ #:qsignal
+ #:qslot
+
+ #:property
+ #:property-p
+ #:properties
+ #:class-properties
+ #:class-direct-properties
+
+ #:from-variant
+ #:make-variant
+ #:make-lisp-variant
+
+ #:connect
+ #:get-slot
+ #:get-signal
+ #:make-slot
+ #:make-signal
+ #:connect-signal
+ #:connect-function
+ #:sender))
+
diff -rN -u old-qt.core/src/painter.lisp new-qt.core/src/painter.lisp
--- old-qt.core/src/painter.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/painter.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,16 @@
+(in-package :qt)
+
+(defmacro with-painter ((painter paint-device) &body body)
+ "Binds a PAINTER instance for PAINT-DEVICE to PAINTER
+ during the evaulation of BODY.
+
+Makes sure the painter ends after BODY; thus prevening problems with
+still active and not yet garbage collected painters."
+ `(let ((,painter (make-instance 'painter :args (list ,paint-device))))
+ (assert (cxx:is-active ,painter)
+ (,painter)
+ "Painter ~A for ~A is not active"
+ ,painter ,paint-device)
+ (unwind-protect
+ (progn ,@body)
+ (cxx:end ,painter))))
diff -rN -u old-qt.core/src/properties.lisp new-qt.core/src/properties.lisp
--- old-qt.core/src/properties.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/properties.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,50 @@
+(in-package :qt)
+
+(defun reverse-lispify (symbol)
+ "Converts the name of symbol to C++ style."
+ (smoke::lisp-to-cxx (symbol-name symbol)))
+
+(defun property-name (name)
+ "The property name is a string or a to camelCase converted symbol."
+ (typecase name
+ (string name)
+ (symbol (reverse-lispify name))))
+
+(defun property (object name)
+ "Returns the property NAME of OBJECT."
+ (from-variant (cxx:property object (property-name name))))
+
+(defun (setf property) (new-value object name)
+ (cxx:set-property object (property-name name)
+ (make-instance 'qt:variant
+ :args (list new-value)))
+ new-value)
+
+(defun property-p (object name)
+ "Returns T when NAME is a property of OBJECT and NIL otherwise."
+ (valid-p (cxx:property object (property-name name))))
+
+(defun meta-object-properties (meta-object &optional (all t))
+ "Returns a list of the properties of META-OBJECT."
+ (loop for index from (if all 0 (cxx:property-offset meta-object))
+ below (cxx:property-count meta-object)
+ collect (smoke::lispify (cxx:name (cxx:property meta-object index)))))
+
+(defgeneric class-properties (class)
+ (:documentation "Returns a list of the properties of CLASS.")
+ (:method ((class class))
+ (meta-object-properties (cxx:static-meta-object class)))
+ (:method ((symbol symbol))
+ (class-properties (find-class symbol))))
+
+(defgeneric class-direct-properties (class)
+ (:documentation "Returns a list of the properties of CLASS.")
+ (:method ((class class))
+ (meta-object-properties (cxx:static-meta-object class) nil))
+ (:method ((symbol symbol))
+ (class-direct-properties (find-class symbol))))
+
+(defun properties (object)
+ "Returns a list of the properties of OBJECT."
+ (warn "FIXME: dynamicPropertyNames not implemented")
+ (meta-object-properties (cxx:meta-object object)))
diff -rN -u old-qt.core/src/qstring.lisp new-qt.core/src/qstring.lisp
--- old-qt.core/src/qstring.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/qstring.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,59 @@
+(in-package :qt)
+
+(defcfun qt-smoke-string-to-qstring :pointer
+ (data :string)
+ (length :int))
+
+(defcfun qt-smoke-free-qstring :void
+ (string :pointer))
+
+(defcfun qt-smoke-qstring-to-byte-array :pointer
+ (qstring :pointer))
+
+(define-foreign-type qstring ()
+ ()
+ (:actual-type :pointer))
+
+(defun setup-type-map ()
+ (smoke::add-type "QString" 'qstring)
+ (smoke::add-type "const QString&" 'qstring))
+
+(eval-when (:load-toplevel :execute)
+ (setup-type-map))
+
+;;; make sure, that you have configured slime corretly.
+;;; e.g.
+;;; (string #\U9999) crashed slime for me. Adding
+;;; (set-language-environment "UTF-8")
+;;; (setq slime-net-coding-system 'utf-8-unix)
+;;; to .emacs helps.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (text-codec.set-codec-for-cstrings
+ (text-codec.codec-for-name (string *default-foreign-encoding*)))
+ (text-codec.set-codec-for-locale
+ (text-codec.codec-for-name (string *default-foreign-encoding*))))
+
+
+(define-parse-method qstring ()
+ (make-instance 'qstring))
+
+(defmethod translate-to-foreign (string (type qstring))
+ (with-foreign-string ((data length) string :null-terminated-p nil)
+ (qt-smoke-string-to-qstring data length)))
+
+(let ((method (smoke::make-smoke-method (find-class 'byte-array)
+ "data")))
+ (defmethod cxx:data ((array byte-array) &rest args)
+ (declare (ignore args))
+ (values ;; Discarge second return value (length of string)
+ (foreign-string-to-lisp (smoke::pointer-call method
+ (smoke::pointer array))
+ :count (cxx:size array)))))
+
+(defmethod translate-from-foreign (string (type qstring))
+ (cxx:data (make-instance 'byte-array
+ :pointer (qt-smoke-qstring-to-byte-array string))))
+
+(defmethod free-translated-object (pointer (type qstring) param)
+ (declare (ignore param))
+ (qt-smoke-free-qstring pointer))
diff -rN -u old-qt.core/src/qt.lisp new-qt.core/src/qt.lisp
--- old-qt.core/src/qt.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/qt.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,33 @@
+(in-package :qt)
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (define-foreign-library libsmokeqt
+ (:unix "libsmokeqt.so.2")
+ (t (:default "libsmokeqt")))
+
+ (use-foreign-library libsmokeqt)
+
+ (use-foreign-library libqt-smoke-extra)
+
+ (defcvar "qt_Smoke" :pointer
+ "The Smoke Qt binding")
+
+ (defcfun (init-qt-smoke "_Z13init_qt_Smokev") :void)
+
+ (defvar *qt-binding* (null-pointer))
+
+ (init-qt-smoke))
+
+(eval-when (:load-toplevel :compile-toplevel)
+ (when (null-pointer-p *qt-binding*)
+ (setf *qt-binding* (init *qt-smoke*))))
+ ;(make-smoke-classes *qt-smoke*))
+
+(define-methods *qt-smoke*)
+
+
+(defun new (class-name method-name &rest args)
+ (apply #'new-object *qt-binding* class-name method-name args))
+
+(defun static-call (class-name method-name &rest args)
+ (apply #'smoke::static-call *qt-smoke* class-name method-name args))
diff -rN -u old-qt.core/src/signal-slot/connect.lisp new-qt.core/src/signal-slot/connect.lisp
--- 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-10-30 07:34:07.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))
diff -rN -u old-qt.core/src/signal-slot/signal-slot.lisp new-qt.core/src/signal-slot/signal-slot.lisp
--- old-qt.core/src/signal-slot/signal-slot.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/signal-slot/signal-slot.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,35 @@
+(in-package :qt)
+
+
+(defclass funcallable-smoke-class (closer-mop:funcallable-standard-class
+ smoke::smoke-wrapper-class)
+ ())
+
+(defmethod closer-mop:validate-superclass ((class funcallable-smoke-class)
+ (superclass closer-mop:funcallable-standard-class))
+ t)
+
+(defgeneric id (method))
+
+(defun munged-name-p (name)
+ "Returns true when NAME is a METHOD, SLOT or SIGNAL."
+ (and (> (length name) 0)
+ (case (aref name 0)
+ ((#\0 #\1 #\2) t)
+ (t nil))))
+
+(defun qmethod (name)
+ "Equivalent of the METHOD(a) CPP macro."
+ (assert (not (munged-name-p name)))
+ (format nil "0~A" name))
+
+(defun qslot (name)
+ "Equivalent of the SLOT(a) CPP macro."
+ (assert (not (munged-name-p name)))
+ (format nil "1~A" name))
+
+(defun qsignal (name)
+ "Equivalent of the SIGNAL(a) CPP macro."
+ (assert (not (munged-name-p name)))
+ (format nil "2~A" name))
+
diff -rN -u old-qt.core/src/signal-slot/signal.lisp new-qt.core/src/signal-slot/signal.lisp
--- old-qt.core/src/signal-slot/signal.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/signal-slot/signal.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,156 @@
+(in-package :qt)
+(declaim (optimize (debug 3)))
+
+(defclass qsignal-mixin ()
+ ((signal-object :accessor signal-object
+ :initarg :signal-object
+ :initform (make-instance 'signal-object)))
+ (:documentation "in SB-PCL you can not have both
+FUNCALLABLE-STANDARD-CLASS and STANDARD-CLASS,
+thus QSIGNAL is split in three classes.
+
+See:
+ http://www.sbcl.org/manual/Metaobject-Protocol.html#index-validate_002dsuperclass-164"))
+
+(defclass signal-object (object)
+ ((argument-types :accessor argument-types
+ :initarg :argument-types
+ :documentation "List of the argument types"))
+ (:documentation "Qt Signal object.")
+ (:metaclass smoke::smoke-wrapper-class))
+
+(defclass qsignal (qsignal-mixin closer-mop:funcallable-standard-object)
+ ()
+ (:metaclass closer-mop:funcallable-standard-class)
+ (:documentation "A funcallable Qt signal.
+The argument types can be supplied by the :METHOD-TYPES initarg.
+Calling an instance emits the signal."))
+
+(defun make-signal (&rest argument-types)
+ "Returns a funcallable signal. When ARGUMENT-TYPES are not
+specified, they are determined when the first connection is made."
+ (if argument-types
+ (make-instance 'qsignal :argument-types argument-types)
+ (make-instance 'qsignal)))
+
+(defmethod id ((qsignal signal-object))
+ (cxx:method-count (cxx:meta-object qsignal)))
+
+(defmethod initialize-instance :after ((object qsignal) &rest initargs
+ &key (argument-types nil arg-types-p)
+ &allow-other-keys)
+ (declare (ignore initargs))
+ (when arg-types-p
+ (setf (argument-types (signal-object object))
+ argument-types))
+ (closer-mop:set-funcallable-instance-function object
+ #'(lambda (&rest args)
+ (apply #'emit (signal-object object) args)))
+ )
+
+(defun find-slot-id (receiver slot)
+ "Returns the ID of RECEIVER from SLOT."
+ (let ((id (cxx:index-of-slot (cxx:meta-object receiver)
+ (cxx:data (meta-object.normalized-signature slot)))))
+ (when (< id 0)
+ (error "No slot ~S for class ~S.
+The valid slots are: ~{~<~%~T~0,75:;~A ~>~}"
+ slot (class-of receiver)
+ (class-slots (class-of receiver))))
+ id))
+
+(defun connect-signal (qsignal receiver slot &optional (type 0))
+ "Connects a signal to a slot. Returns T on success and NIL otherwise."
+
+ (let ((qsignal (signal-object qsignal))
+ (slot-id (find-slot-id receiver slot)))
+ (when (not (slot-boundp qsignal 'argument-types))
+ (setf (argument-types qsignal)
+ (method-arguments-type (cxx:meta-object receiver)
+ slot-id)))
+ (assert (>= slot-id 0)
+ ()
+ "No slot ~S for class ~S."
+ slot (class-name receiver))
+ (assert (static-call "QMetaObject" "connect#$#$$$"
+ qsignal
+ (id qsignal)
+ receiver
+ slot-id
+ type
+ ;; QMetaObject::connect is responsible for freeing
+ ;; the types array.
+ (types (method-arguments-type
+ (cxx:meta-object receiver)
+ slot-id)))
+ ()
+ "Failed to connect ~S to the slot ~S of ~S."
+ qsignal slot receiver)))
+
+(defun disconnect-signal (qsignal receiver slot)
+ (let ((qsignal (signal-object qsignal))
+ (slot-id (cxx:index-of-slot (cxx:meta-object receiver)
+ (cxx:data
+ (meta-object.normalized-signature slot)))))
+ (assert (>= slot-id 0)
+ ()
+ "No slot ~S for class ~S."
+ slot (class-name receiver))
+ (assert (static-call "QMetaObject" "disconnect#$#$"
+ qsignal
+ (id qsignal)
+ receiver
+ slot-id)
+ ()
+ "Failed to disconnect ~S to the slot ~S of ~S."
+ qsignal slot receiver)))
+
+(defmethod smoke::push-lisp-object (stack object class)
+ (let ((cxx-object (make-cxx-lisp-object object)))
+ (smoke::push-cleanup stack
+
+ #'(lambda ()
+ (qt-smoke-free-lisp-object cxx-object)))
+ (smoke::push-stack2 stack
+ cxx-object
+ 0)))
+
+
+(defun emit (qsignal &rest arguments)
+ "Emits the signal QSIGNAL."
+;;; The first element of args would be used for the return value
+;;; by QMetaObject::invokeMethod(), but for signal-slot connection
+;;; it is ignored.
+ (smoke::with-stack (stack arguments
+ (argument-types qsignal))
+ (cffi:with-foreign-object (args :pointer (1+ (length arguments)))
+ (loop for i from 1 to (smoke::size stack)
+ for type in (argument-types qsignal)
+ do
+ (setf (mem-aref args :pointer i)
+ (if (or (not (typep type (find-class 'smoke::smoke-type)))
+ (= 0 (smoke::type-id type))
+ (= 13 (smoke::type-id type)))
+ (foreign-slot-value
+ (mem-aref (pointer stack)
+ 'smoke::smoke-stack-item
+ i)
+ 'smoke::smoke-stack-item 'smoke::voidp)
+ (foreign-slot-pointer
+ (mem-aref (pointer stack)
+ 'smoke::smoke-stack-item
+ i)
+ 'smoke::smoke-stack-item 'smoke::voidp))))
+ (setf (mem-aref args :pointer 0)
+ (null-pointer))
+ (smoke::static-call *qt-smoke* "QMetaObject" "activate##$?"
+ qsignal
+ (cxx:meta-object qsignal)
+ (id qsignal)
+ args))))
+
+(defmethod disconnect-all ((qsignal qsignal))
+ (unless (disconnect-id (signal-object qsignal)
+ (id (signal-object qsignal))
+ 0
+ 0)))
diff -rN -u old-qt.core/src/signal-slot/slot.lisp new-qt.core/src/signal-slot/slot.lisp
--- 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-10-30 07:34:07.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)))))
diff -rN -u old-qt.core/src/signal-slot/translate.lisp new-qt.core/src/signal-slot/translate.lisp
--- old-qt.core/src/signal-slot/translate.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/signal-slot/translate.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,83 @@
+(in-package :qt)
+
+(defun method-argument-count (metaobject index)
+ "Returns the number of arguments 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)))))
+
+(defun find-type (name &optional start end)
+ (smoke::make-smoke-type *qt-smoke* (subseq name start end)))
+
+(defun method-arguments-type (metaobject index)
+ "Returns a type name list for the arguments of method INDEX of METAOBJECT."
+ (let* ((signature (cxx:signature (cxx:method metaobject index)))
+ (arguments (subseq signature (1+ (position #\( signature))
+ (position #\) signature :from-end t)))
+ (argument-types ())
+ (last-pos (length arguments)))
+ (loop as pos = (position #\, arguments :from-end t :end last-pos)
+ while pos
+ do
+ (push (find-type arguments (1+ pos) last-pos) argument-types)
+ (setf last-pos pos))
+ (when (> last-pos 0)
+ (push (find-type arguments 0 last-pos) argument-types))))
+
+
+(defun arguments-to-lisp2 (argument types values)
+ (if (null types)
+ values
+ (arguments-to-lisp2 (inc-pointer argument (foreign-type-size :pointer))
+ (rest types)
+ (nconc values
+ (list
+ (typecase (first types)
+ ;(smoke::smoke-standard-object
+ ; (smoke::object-to-lisp
+ ; (mem-ref
+ ; (mem-ref argument
+ ; :pointer) :pointer)
+ ; (first types)))
+ (smoke::smoke-type
+ (smoke::type-to-lisp argument
+ (first types)))
+ (t
+ (translate-cxx-lisp-object
+ (mem-ref argument :pointer)))))))))
+
+(defun arguments-to-lisp (arguments types)
+ (arguments-to-lisp2 (inc-pointer arguments ;; index 0 is for the return value
+ (foreign-type-size :pointer))
+ types ()))
+
+
+(defun get-type (smoke-type)
+ (typecase smoke-type
+ (smoke::smoke-standard-object
+ (if (smoke::pointer-p smoke-type)
+ (error "FOO");;qmetatype.+voidstar+
+ (let ((type (meta-type.type (smoke::name smoke-type))))
+ (assert (/= 0 type)
+ (type)
+ "The type ~S has no QMetaType."
+ (smoke::name smoke-type))
+ type)))
+ (t
+ *cxx-lisp-object-metatype*)))
+
+
+(defun types (smoke-types)
+ ;;FIXME free TYPES on error.
+ (let ((types (cffi:foreign-alloc :int :count (1+ (length smoke-types))))
+ (index 0))
+ (dolist (type smoke-types)
+ (setf (cffi:mem-aref types :int index)
+ (get-type type))
+ (incf index))
+ (setf (cffi:mem-aref types :int index)
+ 0)
+ types))
diff -rN -u old-qt.core/src/string-list.lisp new-qt.core/src/string-list.lisp
--- old-qt.core/src/string-list.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/string-list.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,51 @@
+(in-package :qt)
+
+(defcfun qt-smoke-string-list-size :int
+ (string-list :pointer))
+
+(defcfun qt-smoke-string-list-at :pointer
+ (string-list :pointer)
+ (index :int))
+
+(defcfun qt-smoke-free-string-list :void
+ (string-list :pointer))
+
+(defcfun qt-smoke-make-string-list :pointer)
+
+(defcfun qt-smoke-string-list-append :void
+ (string-list :pointer)
+ (string :pointer)
+ (length :int))
+
+(define-foreign-type string-list ()
+ ()
+ (:actual-type :pointer))
+
+(eval-when (:load-toplevel)
+ (smoke::add-type "QStringList" 'string-list)
+ (smoke::add-type "const QStringList&" 'string-list))
+
+
+(define-parse-method string-list ()
+ (make-instance 'string-list))
+
+(defmethod translate-to-foreign (sequence (type string-list))
+ (let ((string-list (qt-smoke-make-string-list)))
+ (map nil #'(lambda (string)
+ (with-foreign-string ((data length) string :null-terminated-p nil)
+ (qt-smoke-string-list-append string-list data length)))
+ sequence)
+ string-list))
+
+
+(defmethod translate-from-foreign (string-list (type string-list))
+ (let ((vector (make-array (qt-smoke-string-list-size string-list))))
+ (dotimes (index (length vector) vector)
+ (setf (aref vector index)
+ (cxx:data (make-instance 'qt:byte-array
+ :pointer (qt-smoke-string-list-at
+ string-list index)))))))
+
+(defmethod free-translated-object (string-list (type string-list) param)
+ (declare (ignore param))
+ (qt-smoke-free-string-list string-list))
diff -rN -u old-qt.core/src/variant.lisp new-qt.core/src/variant.lisp
--- old-qt.core/src/variant.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/variant.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,59 @@
+(in-package :qt)
+
+(declaim (optimize (debug 3)))
+
+(defgeneric make-variant (value)
+ (:documentation "Returns a variant for VALUE."))
+
+(defmethod print-object ((variant variant) stream)
+ "Print the type and value of the variant."
+ (if (null-pointer-p (pointer variant))
+ (call-next-method)
+ (print-unreadable-object (variant stream :type t)
+ (format stream "~A~@[ ~S~]"
+ (cxx:type-name variant)
+ (handler-case (from-variant variant)
+ (error () nil))))))
+
+(defmethod make-variant (value)
+ "Returns a new VARIANT containing a C++ version of VALUE."
+ (make-instance 'variant :args (list value)))
+
+;; FIXME include in MAKE-VARIANT?
+(defun make-lisp-variant (value)
+ "Returns a new VARIANT that wrapps VALUE."
+ (let ((object (make-cxx-lisp-object value)))
+ (unwind-protect
+ (make-instance 'variant :args (list *cxx-lisp-object-metatype*
+ object))
+ (free-cxx-lisp-object object))))
+
+(defcfun qt-smoke-lisp-object-value :pointer
+ (variant :pointer))
+
+(defun valid-p (variant)
+ "Returns true when VARIANT is valid (has a value) and false otherwise."
+ (cxx:is-valid variant))
+
+(defun from-variant (variant)
+ "Returns the value of VARIANT."
+ (ecase (cxx:user-type variant)
+ (#.(value variant.+invalid+)
+ (cerror "Return (VALUES)" "Type of variant ~A is invalid." variant)
+ (values))
+ (#.(value variant.+string+)
+ (cxx:to-string variant))
+ (#.(value variant.+string-list+)
+ (cxx:to-string-list variant))
+ (#.(value variant.+uint+)
+ (cxx:to-uint variant))
+ (#.(value variant.+int+)
+ (cxx:to-int variant))
+ (#.(value variant.+double+)
+ (cxx:to-double variant))
+ (#.*cxx-lisp-object-metatype* ;; FIXME test this!
+ (let* ((lisp-object (qt-smoke-lisp-object-value (smoke::pointer variant)))
+ (value))
+ (setf value (translate-cxx-lisp-object lisp-object))
+ (free-cxx-lisp-object lisp-object)
+ value))))
diff -rN -u old-qt.core/test.lisp new-qt.core/test.lisp
--- old-qt.core/test.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/test.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1,21 @@
+#!/usr/bin/sbcl --script
+
+(load "/home/tobias/software/mudballs/boot.lisp")
+
+(in-package :sysdef-user)
+
+(defmacro with-extra-search-dir (path &body body)
+ "Executes BODY with PATH as additional search directory for Mudball systems."
+ `(let ((*custom-search-modules*
+ (pushnew (wildcard-searcher
+ (make-pathname :name :wild
+ :type "mbd"
+ :defaults ,path))
+ *custom-search-modules*)))
+ ,@body))
+
+(with-extra-search-dir *default-pathname-defaults*
+ (mb:clean :qt)
+ (mb:test :qt))
+
+(sb-ext:quit)
diff -rN -u old-qt.core/tests/test.lisp new-qt.core/tests/test.lisp
--- old-qt.core/tests/test.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/tests/test.lisp 2014-10-30 07:34:07.000000000 +0100
@@ -0,0 +1 @@
+(mb:test :qt.tests)