Add a with-main-window macro.
[commonqt:commonqt.git] / qapp.lisp
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
2
3 ;;; Copyright (c) 2009 David Lichteblau. All rights reserved.
4
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
8 ;;;
9 ;;;   * Redistributions of source code must retain the above copyright
10 ;;;     notice, this list of conditions and the following disclaimer.
11 ;;;
12 ;;;   * Redistributions in binary form must reproduce the above
13 ;;;     copyright notice, this list of conditions and the following
14 ;;;     disclaimer in the documentation and/or other materials
15 ;;;     provided with the distribution.
16 ;;;
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28
29 (in-package :qt)
30 (named-readtables:in-readtable :qt)
31
32 ;;; Create a QApplication from command line arguments.
33 ;;;
34 ;;; Usually, programs just pass argc and argv from their `main' function here.
35 ;;; We take a Lisp list and set up a fresh argv array.
36 ;;;
37 ;;; First return value is the QApplication.
38 ;;;
39 ;;; Second return value is an update array of arguments.
40 ;;; For example, "-display" "foo" will have been removed afterwards.
41
42 (defvar *qapplication* nil)
43
44 (defmacro with-main-window ((window form) &body body)
45   `(progn
46      (make-qapplication)
47      (with-objects ((,window ,form))
48        ,@body
49        (#_show ,window)
50        (#_exec *qapplication*))))
51
52 (defun make-qapplication (&rest args)
53   (cond (*qapplication*)
54         (t
55          (ensure-smoke :qtcore)
56          (ensure-smoke :qtgui)
57          (let ((instance (#_QCoreApplication::instance)))
58            (setf *qapplication*
59                  (if (null-qobject-p instance)
60                      (%make-qapplication (cons "argv0dummy" args))
61                      instance))))))
62
63 (defun %make-qapplication (args &optional (guip t))
64   (unless args
65     (error "argv[0] not specified"))
66   (mapc (lambda (arg) (check-type arg string)) args)
67   (let* ((args (coerce args 'simple-vector))
68          (argv
69           ;; Memory leak: This array must not be freed earlier than the
70           ;; QApplication.  Let's just leak it.
71           (string-vector-to-char** args))
72          (&argc
73           ;; Apparently this, too, needs to have extent for more than the ctor.
74           (cffi:foreign-alloc :int)))
75     (setf (cffi:mem-aref &argc :int) (length args))
76     (let* ((qapplication
77             (if guip
78                 (#_new QApplication &argc argv)
79                 (#_new QCoreApplication &argc argv)))
80            (updated-argc (cffi:mem-aref &argc :int)))
81       (values qapplication
82               (char**-to-string-vector argv updated-argc nil)))))
83
84 (defun describe-metaobject-methods (mo)
85   (let* ((offset (#_methodOffset mo)))
86     (format t "Metaobject ~A~%" mo)
87     (format t "  superClass:~%")
88     (format t "~10T~A~%" (#_superClass mo))
89     (format t "  inherited methods:~%")
90     (dotimes (i offset)
91       (format t "~10T~A~%" (#_signature (#_method mo i))))
92     (format t "  direct methods:~%")
93     (loop for i from offset below (#_methodCount mo) do
94       (format t "~10T~A~%" (#_signature (#_method mo i))))))
95
96 (defun describe-metamethods (object)
97   (format t "Metaobject for ~A:~%" object)
98   (describe-metaobject-methods (qobject-metaobject object)))
99
100 (defmacro enable-syntax ()
101   `(named-readtables:in-readtable :qt))
102
103 (defun windows-version ()
104   (let ((v (sw_windows_version)))
105     (if (minusp v) nil v)))
106
107 (defvar +xp+ #x30)
108 (defvar +2003+ #x40)
109 (defvar +vista+ #x80)
110
111 (defun set-nice-theme ()
112   ;; This function isn't called by CommonQt automatically, but user
113   ;; code can use it if desired.
114   ;;
115   ;; The native look on Vista is great, but XP's widgets look antiquated.
116   ;; Let's use Plastique on XP instead.
117   ;;
118   ;; On non-Windows, we don't have this problem, so do nothing.
119   ;;
120   (ensure-smoke :qtcore)
121   (ensure-smoke :qtgui)
122   (let ((v (windows-version)))
123     (when (and v (< v +vista+))
124       (#_QApplication::setStyle "Plastique"))))
125
126 (defmacro with-int& ((var value) &body body)
127   `(invoke-with-int& (lambda (,var) ,@body) ,value))
128
129 (defun invoke-with-int& (fun value)
130   (cffi:with-foreign-object (reference :int)
131     (setf (cffi:mem-aref reference :int) value)
132     (funcall fun reference)
133     (cffi:mem-aref reference :int)))
134
135 (defmacro with-&bool ((var value) &body body)
136   `(invoke-with-&bool (lambda (,var) ,@body) ,value))
137
138 (defun invoke-with-&bool (fun value)
139   (cffi:with-foreign-object (reference :int)
140     (setf (cffi:mem-aref reference :int) (if value 1 0))
141     (funcall fun reference)
142     (logtest 1 (cffi:mem-aref reference :int))))
143
144 (defmacro with-char** ((var string-list) &body body)
145   `(invoke-with-char** (lambda (,var) ,@body) ,string-list))
146
147 (defun invoke-with-char** (fun data)
148   (loop
149      for item across data
150      do (check-type item string))
151   (cffi:with-foreign-object (argv :pointer (length data))
152     (string-vector-to-char**! argv data)
153     (funcall fun argv)
154     (char**-to-string-vector! data argv (length data) t)))