darcs - qt.core

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

3 (defvar *app*)

4 (defvar qt:*exec-p* t

5 "Run exec if true and not otherwise.")

7 (defun qt:app ()

8 "Returns the APPLICATION (or CORE-APPLICATION) object,

9 within a WITH-APP."

10 (assert (qt:app-p)

11 (*app*)

12 "No application.")

13 *app*)

15 (defun qt:app-p ()

16 "Returns t when the APPLICATION object exists and nil otherwise."

17 (boundp '*app*))

19 (defun ensure-app (&optional

20 (application 'qt:core-application)

21 (args #+sbcl sb-ext:*posix-argv*

22 #+ccl ccl:*command-line-argument-list*

23 #-(or sbcl ccl) (list (lisp-implementation-type))))

24 "Constructs the global application object, when there is none,

25 with the command line arguments ARGS.

27 Returns the application object a first value and

28 true when a new application was created and false otherwise."

29 (assert (not (null args))

30 (args)

31 "No program name supplied.")

32 (if (qt:app-p)

33 (progn

34 (assert (typep (qt:app) (find-class application))

35 (application)

36 "The existing application object ~A is

37 not of type ~A." (qt:app) (find-class application))

38 (values (qt:app) nil))

39 (progn

40 (when (not (null-pointer-p (smoke::pointer

41 (qt:core-application.instance))))

42 (cerror (format nil "Delete the active application ~A."

43 (qt:core-application.instance))

44 "Active application not created by QT:WITH-APP.")

45 (smoke::delete-pointer (smoke::pointer (qt:core-application.instance))

46 (find-class 'qt:core-application)))

47 (let* ((argc (smoke:make-auto-pointer

48 (foreign-alloc :int :initial-element (length args))))

49 (argv (smoke:make-auto-pointer

50 (foreign-alloc :string :initial-contents args)))

51 (app (make-instance application :args (list argc argv))))

52 ;; argc and argv must remain valid during the lifetime of APP.

53 (setf (qt:property app 'cmdline-args)

54 (qt:make-lisp-variant (list argc argv)))

55 (tg:cancel-finalization app)

56 (values app t)))))

58 (defgeneric delete-app (application)

59 (:method (application)

60 (unless (null-pointer-p (smoke:pointer application))

61 (cxx:quit application)

62 ;; Call the destructor; -> destructed callback is called,

63 ;; (~QApplication() is virtual) which takes care of cleanup on the

64 ;; Lisp side.

65 (smoke::delete-pointer (smoke:pointer application) (class-of application)))

66 (makunbound '*app*)))

68 (defun kill-app ()

69 (delete-app (qt:app)))

71 (defmacro with-application ((ensure-app remove-app) &body body)

72 (let ((cleanup-p (gensym)))

73 `(multiple-value-bind (*app* ,cleanup-p) ,ensure-app

74 (unwind-protect

75 (progn ,@body)

76 (when ,cleanup-p

77 ,remove-app)))))

79 (defmacro qt:with-core-app (options &body body)

80 (assert (null options)

81 (options)

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

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

84 ,@body))

86 (defun qt:exec ()

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

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

89 instance."

90 (when qt:*exec-p*

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

92 (cxx:quit (qt:app))

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

94 :report-function

95 #'(lambda (stream)

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

97 :test-function

98 #'(lambda (condition)

99 (declare (ignore condition))

100 (and (qt:app-p)

101 (find-restart 'continue)))))

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

103 (cxx:exec (qt:app))))))