repos
/
kde.ui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Workaround segfault on exit & run test on commit
Annotate for file src/application.lisp
2010-04-03 tobias
1
(in-package :kde)
2009-04-05 tobias
2
2010-04-03 tobias
3
(declaim (optimize (debug 3)))
17:29:08 '
4
2009-05-26 tobias
5
;;; FIXME crash on quit, Called from ~KIconLoader():
15:46:14 '
6
;;; CL-USER> (cffi:defcfun (kbacktrace "_Z14kRealBacktracei") :pointer
'
7
;;; (levels :int))
'
8
;;; KBACKTRACE
'
9
;;; CL-USER> (kbacktrace -1)
'
10
;;;
'
11
;;; Unhandled memory fault at #x0.
'
12
2010-04-03 tobias
13
(defun app ()
17:29:08 '
14
(assert (app-p))
2009-04-05 tobias
15
(qt:app))
15:36:16 '
16
2010-04-03 tobias
17
(defun app-p ()
2009-04-05 tobias
18
(and (qt:app-p)
2010-04-03 tobias
19
(typep (qt:app) (find-class 'application))))
2009-04-05 tobias
20
2010-04-03 tobias
21
(defun make-aboutdata (app-name program-name version)
2009-04-05 tobias
22
(let ((app-name (make-instance 'qt:byte-array :args (list app-name)))
15:36:16 '
23
(catalog-name (make-instance 'qt:byte-array))
'
24
(program-name (kde:ki18n program-name))
'
25
(version (make-instance 'qt:byte-array :args (list version))))
2010-04-03 tobias
26
(make-instance 'about-data :args (list app-name catalog-name
17:29:08 '
27
program-name version))))
2009-04-05 tobias
28
15:36:16 '
29
(let ((argv))
2010-04-03 tobias
30
(defun ensure-app (about-data &optional (application 'application)
2009-04-05 tobias
31
(args #+sbcl sb-ext:*posix-argv*
15:36:16 '
32
#-sbcl (list "lisp")))
'
33
(if (qt:app-p)
'
34
(progn
2010-04-03 tobias
35
(assert (typep (qt:app) (find-class application))
2009-04-05 tobias
36
()
15:36:16 '
37
"The existing application object ~A is
'
38
not of type ~A." (qt:app) (find-class application))
'
39
(values (qt:app) nil))
'
40
(let ((args (append (list (first args))
'
41
'("--nocrashhandler") (rest args))))
'
42
(unless (null argv)
'
43
(foreign-free argv)
'
44
(setf argv (null-pointer)))
'
45
'
46
(setf argv (foreign-alloc :string :initial-contents args))
'
47
(kde:cmd-line-args.init (length args) argv about-data)
2010-04-03 tobias
48
(values (make-instance 'application) t))))
2009-04-05 tobias
49
(defun kill-app ()
15:36:16 '
50
(qt:application.close-all-windows)
2009-06-11 tobias
51
(setf qt::*widgets* nil)
2009-04-05 tobias
52
;; FIXME make it work without mem-faults
2010-04-03 tobias
53
(trivial-garbage:cancel-finalization (app))
17:29:08 '
54
(cxx:delete-later (app))
2009-05-24 tobias
55
;(smoke::delete-pointer (smoke::pointer (app)) (class-of (app)))
2010-04-03 tobias
56
(setf (slot-value (app) 'pointer) (null-pointer))))
2009-04-05 tobias
57
2010-04-03 tobias
58
(defmacro with-app (about-data &body body)
2009-06-11 tobias
59
`(qt::with-application ((ensure-app ,about-data)
2009-04-05 tobias
60
(kill-app))
15:36:16 '
61
,@body))
'
62
2010-04-03 tobias
63
(defmacro with-kde ((app-name program-name version) &body body)
2009-04-05 tobias
64
(let ((about-data (gensym)))
2010-04-03 tobias
65
`(let ((,about-data (make-aboutdata ,app-name ,program-name ,version)))
17:29:08 '
66
(with-app ,about-data
'
67
,@body))))