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