repos
/
qt.core
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Make qt:application cleanup more stable
Annotate for file /src/application.lisp
2010-01-10 tobias
1
(in-package :cl-smoke.qt.core)
2009-04-05 tobias
2
17:56:16 '
3
(defvar *app*)
2009-06-21 tobias
4
(defvar qt:*exec-p* t
2009-05-24 tobias
5
"Run exec if true and not otherwise.")
2009-04-05 tobias
6
2009-06-11 tobias
7
(defun qt:app ()
2009-04-05 tobias
8
"Returns the APPLICATION (or CORE-APPLICATION) object,
17:56:16 '
9
within a WITH-APP."
2009-06-11 tobias
10
(assert (qt:app-p)
2009-05-24 tobias
11
(*app*)
14:30:31 '
12
"No application.")
2009-04-05 tobias
13
*app*)
17:56:16 '
14
2009-06-11 tobias
15
(defun qt:app-p ()
2009-04-05 tobias
16
"Returns t when the APPLICATION object exists and nil otherwise."
17:56:16 '
17
(boundp '*app*))
'
18
2009-07-22 tobias
19
(defun ensure-app (&optional
2010-01-10 tobias
20
(application 'qt:core-application)
2009-07-22 tobias
21
(args #+sbcl sb-ext:*posix-argv*
22:21:01 '
22
#+ccl ccl:*command-line-argument-list*
'
23
#-(or sbcl ccl) (list (lisp-implementation-type))))
'
24
"Constructs the global application object, when there is none,
2009-04-05 tobias
25
with the command line arguments ARGS.
17:56:16 '
26
'
27
Returns the application object a first value and
'
28
true when a new application was created and false otherwise."
2009-07-22 tobias
29
(assert (not (null args))
22:21:01 '
30
(args)
'
31
"No program name supplied.")
'
32
(if (qt:app-p)
'
33
(progn
'
34
(assert (typep (qt:app) (find-class application))
'
35
(application)
'
36
"The existing application object ~A is
2009-06-11 tobias
37
not of type ~A." (qt:app) (find-class application))
2009-07-22 tobias
38
(values (qt:app) nil))
22:21:01 '
39
(progn
'
40
(when (not (null-pointer-p (smoke::pointer
'
41
(qt:core-application.instance))))
2009-08-02 tobias
42
(cerror (format nil "Delete the active application ~A."
11:15:21 '
43
(qt:core-application.instance))
'
44
"Active application not created by QT:WITH-APP.")
2009-07-22 tobias
45
(smoke::delete-pointer (smoke::pointer (qt:core-application.instance))
22:21:01 '
46
(find-class 'qt:core-application)))
'
47
(let* ((argc (smoke:make-auto-pointer
'
48
(foreign-alloc :int :initial-element (length args))))
'
49
(argv (smoke:make-auto-pointer
'
50
(foreign-alloc :string :initial-contents args)))
2010-01-10 tobias
51
(app (make-instance application :args (list argc argv))))
2009-07-22 tobias
52
;; argc and argv must remain valid during the lifetime of APP.
22:21:01 '
53
(setf (qt:property app 'cmdline-args)
'
54
(qt:make-lisp-variant (list argc argv)))
'
55
(tg:cancel-finalization app)
'
56
(values app t)))))
2009-04-05 tobias
57
2010-01-10 tobias
58
(defgeneric delete-app (application)
08:52:09 '
59
(:method (application)
2010-02-20 tobias
60
(unless (null-pointer-p (smoke:pointer application))
21:02:38 '
61
(cxx:quit application)
'
62
;; Call the destructor; -> destructed callback is called,
'
63
;; (~QApplication() is virtual) which takes care of cleanup on the
'
64
;; Lisp side.
'
65
(smoke::delete-pointer (smoke:pointer application) (class-of application)))
2010-01-10 tobias
66
(makunbound '*app*)))
08:52:09 '
67
2009-07-22 tobias
68
(defun kill-app ()
2010-01-10 tobias
69
(delete-app (qt:app)))
2009-04-05 tobias
70
17:56:16 '
71
(defmacro with-application ((ensure-app remove-app) &body body)
2009-05-24 tobias
72
(let ((cleanup-p (gensym)))
14:30:31 '
73
`(multiple-value-bind (*app* ,cleanup-p) ,ensure-app
'
74
(unwind-protect
'
75
(progn ,@body)
'
76
(when ,cleanup-p
'
77
,remove-app)))))
2009-04-05 tobias
78
2009-07-01 tobias
79
(defmacro qt:with-core-app (options &body body)
10:58:06 '
80
(assert (null options)
'
81
(options)
'
82
"Currently no options can be passed to QT:WITH-CORE-APP.")
2010-01-10 tobias
83
`(with-application ((cl-smoke.qt.core::ensure-app 'qt:core-application) (kill-app))
2009-07-01 tobias
84
,@body))
2009-04-05 tobias
85
2009-07-01 tobias
86
(defun qt:exec ()
10:58:06 '
87
"Executes APP. When QT:*EXEC-P* is false it returns immediately
'
88
and transfers the ownership of the top-level widgets to the qt:application
'
89
instance."
2010-01-10 tobias
90
(when qt:*exec-p*
08:52:09 '
91
(restart-bind ((qt::abort-app #'(lambda ()
'
92
(cxx:quit (qt:app))
'
93
(invoke-restart (find-restart 'continue)))
'
94
:report-function
'
95
#'(lambda (stream)
'
96
(format stream "Return from the application event loop."))
'
97
:test-function
'
98
#'(lambda (condition)
'
99
(declare (ignore condition))
'
100
(and (qt:app-p)
'
101
(find-restart 'continue)))))
'
102
(let ((qt:*exec-p* nil))
'
103
(cxx:exec (qt:app))))))