repos / qt.gui / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
Transfer ownerhip only for smoke classes.
Annotate for file src/application.lisp
2009-06-11 tobias 1 (in-package :qt)
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 *exec-p* t
2010-01-10 tobias 8 "Run exec if true and not otherwise.")
2009-04-05 tobias 9
2009-06-11 tobias 10 (defun app ()
2010-01-10 tobias 11 "Returns the APPLICATION (or CORE-APPLICATION) object,
08:52:49 ' 12 within a WITH-APP."
2009-06-11 tobias 13 (assert (app-p)
2010-01-10 tobias 14 (*app*)
08:52:49 ' 15 "No application.")
' 16 *app*)
' 17
2009-06-11 tobias 18 (defun app-p ()
2010-01-10 tobias 19 "Returns t when the APPLICATION object exists and nil otherwise."
08:52:49 ' 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
2009-06-11 tobias 27 (application 'application)
2009-07-22 tobias 28 (args #+sbcl sb-ext:*posix-argv*
22:21:01 ' 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.")
2009-06-11 tobias 39 (if (app-p)
2009-07-22 tobias 40 (progn
2009-06-11 tobias 41 (assert (typep (app) (find-class application))
2009-07-22 tobias 42 (application)
22:21:01 ' 43 "The existing application object ~A is
2009-06-11 tobias 44 not of type ~A." (app) (find-class application))
14:59:48 ' 45 (values (app) nil))
2009-07-22 tobias 46 (progn
2009-06-11 tobias 47 (assert (null-pointer-p (smoke::pointer (core-application.instance)))
14:59:48 ' 48 ()
' 49 "Active QCoreApplication not created by QT:WITH-APP.")
2009-07-22 tobias 50 (foreign-free argv)
22:21:01 ' 51 (foreign-free argc)
2010-01-10 tobias 52
2009-07-22 tobias 53 (setf argc (foreign-alloc :int :initial-element (length args)))
2009-06-10 tobias 54 (setf argv (foreign-alloc :string :initial-contents args))
2009-07-22 tobias 55 (let ((app (make-instance 'qt:application :args (list argc argv))))
22:21:01 ' 56 (tg:cancel-finalization app)
' 57 (values app t)))))
' 58 (defun kill-app ()
2009-06-11 tobias 59 (when (typep (app) 'application)
14:59:48 ' 60 (application.close-all-windows)
2009-07-22 tobias 61 ;; widgets are only valid as long, as an application object exists.
22:21:01 ' 62 ;; QApplication::~QApplication() deletes all widgets in
' 63 ;; QApplication::allWidgets().
' 64 ;;
' 65 ;; see: qt4/src/gui/kernel/qapplication.cpp
2009-06-11 tobias 66 (loop for widget across (application.all-widgets) do
2009-07-22 tobias 67 (trivial-garbage:cancel-finalization widget)))
2009-06-11 tobias 68 (cxx:quit (app))
2009-07-22 tobias 69 (setf *widgets* nil)
2009-07-01 tobias 70 ;; Call the destructer; -> destructed callback is called,
2009-07-22 tobias 71 ;; (~QApplication() is virtual) which takes care of cleanup
22:21:01 ' 72 ;; on the Lisp side.
2009-06-11 tobias 73 (smoke::delete-pointer (smoke::pointer (app)) (class-of (app)))
14:59:48 ' 74 (setf (slot-value (app) 'pointer) (null-pointer))
2009-07-22 tobias 75 (makunbound '*app*)))
2010-01-10 tobias 76
08:52:49 ' 77 (defmacro with-application ((ensure-app remove-app) &body body)
' 78 (let ((cleanup-p (gensym)))
' 79 `(multiple-value-bind (*app* ,cleanup-p) ,ensure-app
' 80 (unwind-protect
' 81 (progn ,@body)
' 82 (when ,cleanup-p
' 83 ,remove-app)))))
2009-04-05 tobias 84
2009-06-11 tobias 85 (defmacro with-app (&body body)
2009-04-05 tobias 86 "Ensures that a APPLICATION instance exists,
17:56:16 ' 87 evaluates BODY and executes the APPLICATION instance after BODY.
' 88 The instance can be accessed with:
2009-07-01 tobias 89 APP.
2009-04-05 tobias 90
17:56:16 ' 91 Can be nested.
' 92
' 93 When a APPLICATION was created, it will be deleted when returning
' 94 from BODY."
2009-06-11 tobias 95 `(with-application ((ensure-app 'application) (kill-app))
2009-07-01 tobias 96 ,@body))
2009-04-05 tobias 97
2009-06-11 tobias 98 (defmacro with-core-app (&body body)
14:59:48 ' 99 `(with-application ((ensure-app 'core-application) (kill-app))
2009-07-01 tobias 100 ,@body))
2010-01-10 tobias 101
2009-07-01 tobias 102
2009-06-11 tobias 103 (defun exec (&rest widgets)
2009-07-01 tobias 104 "Executes APP."
10:58:06 ' 105 (setf *widgets* (append widgets *widgets*))
2009-06-21 tobias 106 (when *exec-p*
2009-06-11 tobias 107 (restart-bind ((abort-app #'(lambda ()
14:59:48 ' 108 (cxx:quit (app))
2009-07-01 tobias 109 (invoke-restart (find-restart 'continue)))
10:58:06 ' 110 :report-function
' 111 #'(lambda (stream)
' 112 (format stream "Return from the application event loop."))
' 113 :test-function
' 114 #'(lambda (condition)
' 115 (declare (ignore condition))
2009-06-11 tobias 116 (and (app-p)
2009-07-01 tobias 117 (find-restart 'continue)))))
2009-06-11 tobias 118 (cxx:exec (app)))))
Crece desde el pueblo el futuro / crece desde el pie