src/application.lisp
Sun Apr 5 19:56:16 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
--- old-qt.core/src/application.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/application.lisp 2014-11-11 13:36:41.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))))