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