darcs - qt.gui

1 (in-package :cl-smoke.qt.gui)

3 (defvar *widgets* nil)

5 (defmethod cl-smoke.qt.core:delete-app :around ((application qt:application))

6 (qt:application.close-all-windows)

7 ;; widgets are only valid as long, as an application object

8 ;; exists. QApplication::~QApplication() deletes all widgets in

9 ;; QApplication::allWidgets().

10 ;;

11 ;; see: qt4/src/gui/kernel/qapplication.cpp

12 (loop for widget across (qt:application.all-widgets) do

13 (tg:cancel-finalization widget))

14 ;; QPaintDevices are only valid when a application object exists.

15 (loop for object being the hash-values of smoke::*object-map* do

16 (when (typep object 'qt:paint-device)

17 (delete-object object)))

18 ;; Finalize other stuff before deleting the QApplication,

19 ;; e.g. QGraphicsScene

20 (tg:gc :full t)

21 (call-next-method)

22 (setf *widgets* nil))

24 (defmacro qt:with-app (options &body body)

25 "Ensures that a APPLICATION instance exists,

26 evaluates BODY and executes the APPLICATION instance after BODY.

27 The instance can be accessed with:

28 QT:APP.

30 Can be nested.

32 When a APPLICATION was created, it will be deleted when returning

33 from BODY."

34 (assert (null options)

35 (options)

36 "Currently no options can be passed to QT:WITH-APP.")

37 `(cl-smoke.qt.core:with-application ((cl-smoke.qt.core:ensure-app 'qt:application)

38 (cl-smoke.qt.core:kill-app))

39 ,@body))

41 (defun qt:exec ()

42 "Executes APP. When QT:*EXEC-P* is false it returns immediately

43 and transfers the ownership of the top-level widgets to the qt:application

44 instance."

45 (if qt:*exec-p*

46 (restart-bind ((qt::abort-app #'(lambda ()

47 (cxx:quit (qt:app))

48 (invoke-restart (find-restart 'continue)))

49 :report-function

50 #'(lambda (stream)

51 (format stream "Return from the application event loop."))

52 :test-function

53 #'(lambda (condition)

54 (declare (ignore condition))

55 (and (qt:app-p)

56 (find-restart 'continue)))))

57 (let ((qt:*exec-p* nil))

58 (cxx:exec (qt:app))))

59 (when (typep (qt:app) 'qt:application)

60 (setf *widgets* (qt:application.top-level-widgets)))))