/ src /
/src/application.lisp
1 (in-package :cl-smoke.kde.ui)
2
3 (defun kde:app ()
4 (assert (kde:app-p))
5 (qt:app))
6
7 (defun kde:app-p ()
8 (and (qt:app-p)
9 (typep (qt:app) (find-class 'kde:application))))
10
11 (defun kde:make-aboutdata (app-name program-name version)
12 (let ((app-name (make-instance 'qt:byte-array :args (list app-name)))
13 (catalog-name (make-instance 'qt:byte-array))
14 (program-name (kde:ki18n program-name))
15 (version (make-instance 'qt:byte-array :args (list version))))
16 (make-instance 'kde:about-data :args (list app-name catalog-name
17 program-name version))))
18
19 (let ((argv))
20 (defun ensure-app (about-data &optional (application 'kde:application)
21 (args #+sbcl sb-ext:*posix-argv*
22 #-sbcl (list "lisp")))
23 (if (qt:app-p)
24 (progn
25 (assert (typep (qt:app) (find-class 'kde:application))
26 ()
27 "The existing application object ~A is
28 not of type ~A." (qt:app) (find-class application))
29 (values (qt:app) nil))
30 (let ((args (append (list (first args))
31 '("--nocrashhandler") (rest args))))
32 (unless (null argv)
33 (foreign-free argv)
34 (setf argv (null-pointer)))
35
36 (setf argv (foreign-alloc :string :initial-contents args))
37 (kde:cmd-line-args.init (length args) argv about-data)
38 (values (make-instance 'kde:application) t))))
39 (defun kill-app ()
40 (qt:application.close-all-windows)
41 (setf cl-smoke.qt.gui::*widgets* nil)
42 ;; FIXME make it work without mem-faults
43 (trivial-garbage:cancel-finalization (kde:app))
44 (cxx:delete-later (kde:app))
45 ;(smoke::delete-pointer (smoke::pointer (app)) (class-of (app)))
46 (setf (slot-value (kde:app) 'pointer) (null-pointer))))
47
48 (defmacro kde:with-app (about-data &body body)
49 `(cl-smoke.qt.core::with-application ((ensure-app ,about-data)
50 (kill-app))
51 ,@body))
52
53 (defmacro kde:with-kde ((app-name program-name version) &body body)
54 (let ((about-data (gensym)))
55 `(let ((,about-data (kde:make-aboutdata ,app-name ,program-name ,version)))
56 (kde:with-app ,about-data
57 ,@body))))