*SMOKE-MODULE* must be passed instead of *QT-SMOKE*.
Annotate for file src/application.lisp
2010-01-10 tobias 1 (in-package :cl-smoke.qt-impl)
2009-04-05 tobias 2
2009-07-01 tobias 3 (declaim (optimize (debug 3)))
10:58:06 ' 4
2010-01-10 tobias 5 (defvar *app*)
2009-04-05 tobias 6 (defvar *widgets* nil)
2009-06-21 tobias 7 (defvar qt:*exec-p* t
2010-01-10 tobias 8 "Run exec if true and not otherwise.")
2009-04-05 tobias 9
2010-01-10 tobias 10 (defun qt:app ()
08:52:49 ' 11 "Returns the APPLICATION (or CORE-APPLICATION) object,
' 12 within a WITH-APP."
' 13 (assert (qt:app-p)
' 14 (*app*)
' 15 "No application.")
' 16 *app*)
' 17
' 18 (defun qt:app-p ()
' 19 "Returns t when the APPLICATION object exists and nil otherwise."
' 20 (boundp '*app*))
' 21
2009-07-01 tobias 22
2009-07-22 tobias 23 (let ((argv (null-pointer))
22:21:01 ' 24 (argc (null-pointer)))
' 25 (declare (cffi:foreign-pointer argv argc))
' 26 (defun ensure-app (&optional
' 27 (application 'qt:application)
' 28 (args #+sbcl sb-ext:*posix-argv*
' 29 #+ccl ccl:*command-line-argument-list*
' 30 #-(or sbcl ccl) (list (lisp-implementation-type))))
' 31 "Constructs the global application object, when there is none,
2010-01-10 tobias 32 with the command line arguments ARGS.
08:52:49 ' 33
' 34 Returns the application object a first value and
' 35 true when a new application was created and false otherwise."
2009-07-22 tobias 36 (assert (not (null args))
22:21:01 ' 37 (args)
' 38 "No program name supplied.")
' 39 (if (qt:app-p)
' 40 (progn
' 41 (assert (typep (qt:app) (find-class application))
' 42 (application)
' 43 "The existing application object ~A is
2010-01-10 tobias 44 not of type ~A." (qt:app) (find-class application))
2009-07-22 tobias 45 (values (qt:app) nil))
22:21:01 ' 46 (progn
' 47 (when (not (null-pointer-p (smoke::pointer
' 48 (qt:core-application.instance))))
' 49 (cerror "Delete the active application." "Active application not created by QT:WITH-APP.")
' 50 (smoke::delete-pointer (smoke::pointer (qt:core-application.instance))
' 51 (find-class 'qt:core-application)))
' 52 (foreign-free argv)
' 53 (foreign-free argc)
2010-01-10 tobias 54
2009-07-22 tobias 55 (setf argc (foreign-alloc :int :initial-element (length args)))
22:21:01 ' 56 (setf argv (foreign-alloc :string :initial-contents args))
' 57 (let ((app (make-instance 'qt:application :args (list argc argv))))
' 58 (tg:cancel-finalization app)
' 59 (values app t)))))
' 60 (defun kill-app ()
' 61 (when (typep (qt:app) 'qt:application)
' 62 (qt:application.close-all-windows)
' 63 ;; widgets are only valid as long, as an application object exists.
' 64 ;; QApplication::~QApplication() deletes all widgets in
' 65 ;; QApplication::allWidgets().
' 66 ;;
' 67 ;; see: qt4/src/gui/kernel/qapplication.cpp
' 68 (loop for widget across (qt:application.all-widgets) do
' 69 (trivial-garbage:cancel-finalization widget)))
' 70 (cxx:quit (qt:app))
' 71 (setf *widgets* nil)
2009-07-01 tobias 72 ;; Call the destructer; -> destructed callback is called,
2009-07-22 tobias 73 ;; (~QApplication() is virtual) which takes care of cleanup
22:21:01 ' 74 ;; on the Lisp side.
' 75 (smoke::delete-pointer (smoke::pointer (qt:app)) (class-of (qt:app)))
' 76 (setf (slot-value (qt:app) 'pointer) (null-pointer))
' 77 (makunbound '*app*)))
2010-01-10 tobias 78
08:52:49 ' 79 (defmacro with-application ((ensure-app remove-app) &body body)
' 80 (let ((cleanup-p (gensym)))
' 81 `(multiple-value-bind (*app* ,cleanup-p) ,ensure-app
' 82 (unwind-protect
' 83 (progn ,@body)
' 84 (when ,cleanup-p
' 85 ,remove-app)))))
2009-04-05 tobias 86
2009-07-01 tobias 87 (defmacro qt:with-app (&body body)
2009-04-05 tobias 88 "Ensures that a APPLICATION instance exists,
17:56:16 ' 89 evaluates BODY and executes the APPLICATION instance after BODY.
' 90 The instance can be accessed with:
2009-07-01 tobias 91 APP.
2009-04-05 tobias 92
17:56:16 ' 93 Can be nested.
' 94
' 95 When a APPLICATION was created, it will be deleted when returning
' 96 from BODY."
2010-01-10 tobias 97 `(with-application ((cl-smoke.qt-impl::ensure-app 'qt:application) (kill-app))
2009-07-01 tobias 98 ,@body))
2009-04-05 tobias 99
2009-07-01 tobias 100 (defmacro qt:with-core-app (&body body)
2010-01-10 tobias 101 `(with-application ((cl-smoke.qt-impl::ensure-app 'qt:core-application) (kill-app))
2009-07-01 tobias 102 ,@body))
2010-01-10 tobias 103
2009-07-01 tobias 104
10:58:06 ' 105 (defun qt:exec (&rest widgets)
' 106 "Executes APP."
' 107 (setf *widgets* (append widgets *widgets*))
2009-06-21 tobias 108 (when qt:*exec-p*
2009-07-01 tobias 109 (restart-bind ((qt::abort-app #'(lambda ()
10:58:06 ' 110 (cxx:quit (qt:app))
' 111 (invoke-restart (find-restart 'continue)))
' 112 :report-function
' 113 #'(lambda (stream)
' 114 (format stream "Return from the application event loop."))
' 115 :test-function
' 116 #'(lambda (condition)
' 117 (declare (ignore condition))
' 118 (and (qt:app-p)
' 119 (find-restart 'continue)))))
' 120 (cxx:exec (qt:app)))))