repos / qt.gui / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
Cleanup app in with-app
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)
17:56:16 ' 7
2009-06-11 tobias 8 (defun app ()
2010-01-10 tobias 9 "Returns the APPLICATION (or CORE-APPLICATION) object,
08:52:49 ' 10 within a WITH-APP."
2009-06-11 tobias 11 (assert (app-p)
2009-05-24 tobias 12 (*app*)
14:30:31 ' 13 "No application.")
2010-01-10 tobias 14 *app*)
08:52:49 ' 15
2009-06-11 tobias 16 (defun app-p ()
2010-01-10 tobias 17 "Returns t when the APPLICATION object exists and nil otherwise."
08:52:49 ' 18 (boundp '*app*))
' 19
2009-07-01 tobias 20
2009-07-22 tobias 21 (let ((argv (null-pointer))
22:21:01 ' 22 (argc (null-pointer)))
' 23 (declare (cffi:foreign-pointer argv argc))
' 24 (defun ensure-app (&optional
2009-06-11 tobias 25 (application 'application)
2009-07-22 tobias 26 (args #+sbcl sb-ext:*posix-argv*
2009-05-24 tobias 27 #-sbcl (list (lisp-implementation-type))))
2009-07-22 tobias 28 "Constructs the global application object, when there is none,
2010-01-10 tobias 29 with the command line arguments ARGS.
08:52:49 ' 30
' 31 Returns the application object a first value and
' 32 true when a new application was created and false otherwise."
2009-07-22 tobias 33 (assert (not (null args))
22:21:01 ' 34 (args)
' 35 "No program name supplied.")
2009-06-11 tobias 36 (if (app-p)
2009-07-22 tobias 37 (progn
2009-06-11 tobias 38 (assert (typep (app) (find-class application))
2009-07-22 tobias 39 (application)
22:21:01 ' 40 "The existing application object ~A is
2009-06-11 tobias 41 not of type ~A." (app) (find-class application))
14:59:48 ' 42 (values (app) nil))
2009-07-22 tobias 43 (progn
2009-05-24 tobias 44 ;(assert (null-pointer-p (smoke::pointer (core-application.instance))))
14:30:31 ' 45 (foreign-free argv)
' 46 (foreign-free argc)
2010-01-10 tobias 47
2009-06-10 tobias 48 (setf argv (foreign-alloc :string :initial-contents args))
2009-07-22 tobias 49 (setf argc (foreign-alloc :int :initial-element (length args)))
2009-05-24 tobias 50 (values (make-instance 'qt:application :args (list argc argv)) t))))
2009-07-22 tobias 51 (defun kill-app ()
2009-06-11 tobias 52 (cxx:quit (app))
2009-05-24 tobias 53 ; (when (typep (app) (find-class 'qt:application))
14:30:31 ' 54 ; (application.close-all-windows))
2009-07-22 tobias 55 (setf *widgets* nil)
2009-06-03 tobias 56 (trivial-garbage:cancel-finalization (app))
2009-05-24 tobias 57 (smoke::remove-object (smoke::pointer (app)))
14:30:31 ' 58 ;; FIXME leak memory or memory fault!
' 59 ;(smoke::delete-pointer (smoke::pointer (app)) (class-of (app)))
2009-06-11 tobias 60 (setf (slot-value (app) 'pointer) (null-pointer))
2009-07-22 tobias 61 (makunbound '*app*)))
2010-01-10 tobias 62
08:52:49 ' 63 (defmacro with-application ((ensure-app remove-app) &body body)
2009-05-24 tobias 64 (let ((cleanup-p (gensym)))
14:30:31 ' 65 `(multiple-value-bind (*app* ,cleanup-p) ,ensure-app
' 66 (unwind-protect
' 67 (progn ,@body)
' 68 (when ,cleanup-p
' 69 ,remove-app)))))
2009-04-05 tobias 70
2009-06-11 tobias 71 (defmacro with-app (&body body)
2009-04-05 tobias 72 "Ensures that a APPLICATION instance exists,
17:56:16 ' 73 evaluates BODY and executes the APPLICATION instance after BODY.
' 74 The instance can be accessed with:
2009-07-01 tobias 75 APP.
2009-04-05 tobias 76
17:56:16 ' 77 Can be nested.
' 78
' 79 When a APPLICATION was created, it will be deleted when returning
' 80 from BODY."
2009-06-11 tobias 81 `(with-application ((ensure-app 'application) (kill-app))
2009-07-01 tobias 82 ,@body))
2009-04-05 tobias 83
2009-06-11 tobias 84 (defmacro with-core-app (&body body)
14:59:48 ' 85 `(with-application ((ensure-app 'core-application) (kill-app))
2009-07-01 tobias 86 ,@body))
2010-01-10 tobias 87
2009-07-01 tobias 88
2009-06-11 tobias 89 (defun exec (&rest widgets)
2009-07-01 tobias 90 "Executes APP."
10:58:06 ' 91 (setf *widgets* (append widgets *widgets*))
2009-05-24 tobias 92 (restart-bind ((abort-app #'(lambda ()
15:02:00 ' 93 (application.close-all-windows)
' 94 (cxx:quit (app))
' 95 (invoke-restart (find-restart 'continue)))
' 96 :report-function
' 97 #'(lambda (stream)
' 98 (format stream "Return from the application event loop."))))
' 99 (cxx:exec (app))))
Crece desde el pueblo el futuro / crece desde el pie