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