source: trunk/source/examples/mswin.lisp @ 11235

Last change on this file since 11235 was 11235, checked in by gb, 11 years ago

Finally solve the Big Mystery of why this doesn't work when running
under SLIME.

File size: 10.5 KB
Line 
1;;;-*-Mode: LISP; Package: ccl -*-
2;;;
3;;;   Copyright (C) 2008, Clozure Associates and contributors
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; This is very preliminary and very much a work-in-progress.
18
19(in-package "CL-USER")
20
21;;; This is a simple demo that creates an almost totally uninteresting
22;;; window and does limited event handling.  It's intended to excercise
23;;; Clozure CL's FFI a little and to serve as a proof of the concept
24;;; that Windows GUI programming is possible.  It's not necessarily
25;;; a good way to create or manage a window or a good way to structure
26;;; a program or much of anything else ...
27
28(eval-when (:compile-toplevel :load-toplevel :execute)
29  (open-shared-library "user32.dll"))
30
31;;; This function is called by Windows to process events ("messages")
32;;; for a given class of window.  (It's specified when the window
33;;; class is registered; see below.)  Note that - on Win32 -most
34;;; Windows API functions and the functions that they call follow an
35;;; unusual calling sequence in which the callee pops its arguments
36;;; off of the stack before returning; this is indicated by the
37;;; keyword :DISCARD-STACK-ARGS in the DEFCALLBACK argument list.
38
39(defcallback simple-wndproc (;; See comment above.
40                             :discard-stack-args
41                             ;: the window to which this message is directed,
42                             ;; of a null pointer if the message isn't
43                             ;; directed to a window:
44                             #>HWND hwnd
45                             ;; An integer which idenfifies the type
46                             ;; of message, usually matching a
47                             ;; predefined constant whose name starts
48                             ;; with WM_ :
49                             #>UINT msg
50                             ;; A parameter to the message.  In 16-bit
51                             ;; Windows, this was a 16-bit integer and
52                             ;; therefore couldn't convey much information.
53                             ;; On 32 and 64-bit Windows, it's a 32-bit
54                             ;; integer and therefore -could- contain
55                             ;; more information, but usually doesn't ...
56                             ;; Its value (and how it should be interpreted)
57                             ;; depend on the value of "msg":
58                             #>WPARAM wparam
59                             ;; Another parameter, as wide as a pointer
60                             ;; is (and sometimes used as a pointer.):
61                             #>LPARAM lparam
62                             ;; The callback function should return a
63                             ;; pointer-sized (32/64-bit) integer: 0
64                             ;; to indicate that the message was
65                             ;; handled, and non-zero otherwise.
66                             #>LRESULT)
67  ;; At a bare minimum, a windows message procedure (wndproc) like this
68  ;; one should handle the the WM_DESTROY message; if we actually did
69  ;; any drawing of the window's content, we should handle WM_PAINT
70  ;; messages, ...
71  ;; There are a fairly large number of other message constants that
72  ;; we could receive; if we don't want to handle them ourselves - and
73  ;; in this simple example, we don't - we can just pass all of our
74  ;; arguments to the default window procedure and return whatever it
75  ;; returns.
76  #+debug (format t "~& hwnd = ~s, msg = ~s, wparam = ~s, lparam = ~x"
77                  hwnd msg wparam lparam)
78  (cond ((eql msg #$WM_DESTROY)
79         ;; If there were resources attached to the window - bitmaps,
80         ;; etc. - we'd want to free them here.  Posting a quit message
81         ;; (WM_QUIT) will arrange that we receive a WM_QUIT messsage
82         ;; in very short order.
83         (#_PostQuitMessage 0)          ; exit status 0: all is well.
84         0)                             ; and we'll return 0
85        (t
86         ;; In a more realistic example, we'd handle more cases here.
87         ;; Like many functions that deal with characters and strings,
88         ;; DefWindowProc is actually implemented as two functions:
89         ;; DefWindowProcA is the "ANSI" (8-bit character) version,
90         ;; and DefWindowProcW is the wide-character (UTF-16LE)
91         ;; version.
92         (#_DefWindowProcA hwnd msg wparam lparam))))
93                             
94
95;;; Register a named window class. ("class" in this sense has nothing to
96;;; do with CLOS or any other object system: windows of the same class
97;;; share a common window procedure callback and other attributes, which
98;;; we define here.
99;;; If the registration attempt is succesful, it'll return an "atom"
100;;; (a small integer that identifies the registered class); otherwise,
101;;;  it returns 0.
102(defvar *simple-window-class-atom* nil)
103
104(defun register-simple-window-class (class-name)
105  ;; We'll use an ANSI version that accepts a simple C string as the
106  ;; class name.
107  (or *simple-window-class-atom*
108      (setq *simple-window-class-atom*
109            (with-cstrs ((cname class-name))
110              (rlet ((wc #>WNDCLASSEX)) ; an "extended" WNDCLASS structure
111                (setf (pref wc #>WNDCLASSEX.cbSize) (ccl::record-length #>WNDCLASSEX)
112                      (pref wc #>WNDCLASSEX.style) (logior #$CS_HREDRAW #$CS_VREDRAW)
113                      (pref wc #>WNDCLASSEX.lpfnWndProc) simple-wndproc
114                      (pref wc #>WNDCLASSEX.cbClsExtra) 0
115                      (pref wc #>WNDCLASSEX.cbWndExtra) 0
116                      (pref wc #>WNDCLASSEX.hInstance) (#_GetModuleHandleA (%null-ptr))
117                      (pref wc #>WNDCLASSEX.hIcon) (%null-ptr)
118                      (pref wc #>WNDCLASSEX.hCursor) (#_LoadCursorA (%null-ptr) #$IDC_ARROW)
119                      (pref wc #>WNDCLASSEX.hbrBackground) (#_GetStockObject #$WHITE_BRUSH)
120                      (pref wc #>WNDCLASSEX.lpszMenuName) (%null-ptr)
121                      (pref wc #>WNDCLASSEX.lpszClassName) cname
122                      (pref wc #>WNDCLASSEX.hIconSm) (%null-ptr))
123                (let* ((atom (#_RegisterClassExA wc)))
124                  (if (eql 0 atom)
125                    (let* ((err (#_GetLastError)))
126                      (error "Error registering windows class ~s: ~d (~a)" class-name
127                             err
128                             (ccl::%windows-error-string err))))
129                  atom))))))
130
131;;; Main function: register a window class, make an instance of that
132;;; class, handle events for that window until it's closed.
133(defun make-simple-ms-window ()
134  (let* ((class-atom (register-simple-window-class "very-simple")))
135    (with-cstrs ((title "Look! A window!"))
136      (let* ((hwnd (#_CreateWindowExA 0 ;extended style
137                                      (%int-to-ptr class-atom) ; class name/atom
138                                      title 
139                                      (logior #$WS_EX_COMPOSITED #$WS_OVERLAPPEDWINDOW) ; style
140                                      #$CW_USEDEFAULT ; x pos
141                                      #$CW_USEDEFAULT ; y pos
142                                      #$CW_USEDEFAULT ; width
143                                      #$CW_USEDEFAULT ; height
144                                      (%null-ptr) ;parent window
145                                      (%null-ptr) ; menu handle
146                                      (#_GetModuleHandleA (%null-ptr)) ; us
147                                      (%null-ptr)))) ;info for MDI parents/children
148        (when (%null-ptr-p hwnd)
149          (error "CreateWindow failed: ~a" (ccl::%windows-error-string (#_GetLastError))))
150        ;; Depending on how the lisp process was created, the first call
151        ;; to #_ShowWindow in that process might ignore its argument
152        ;; (and instead use an argument specified in the STARTUPINFO
153        ;; structure passed to #_CreateProcess.)  SLIME under FSF Emacs
154        ;; runs the lisp with this flag set, and it's possible to waste
155        ;; a week or two trying to track this down.  (Trust me.)
156        (#_ShowWindow hwnd #$SW_SHOW)
157        ;; In case the parent process said to ignore #_ShowWindow's argument
158        ;; the first time it's called, call #_ShowWindow again.  This seems
159        ;; to be harmless, if a little strange ...
160        (#_ShowWindow hwnd #$SW_SHOW)
161        (#_UpdateWindow hwnd)
162        ;; Loop, fetching messages, translating virtual key events
163        ;; into character-oriented events and dispatching each
164        ;; message until #_GetMessageA returns 0.
165        (rlet ((msg #>MSG))
166          (do* ((result (#_GetMessageA msg
167                                       (%null-ptr) ; for any window created by this thread)
168                                       0
169                                       0)
170                        (#_GetMessageA msg (%null-ptr) 0 0)))
171               ((eql 0 result)          ; message was WM_QUIT
172                (pref msg #>MSG.wParam))
173            (cond ((< result 0)
174                   (let* ((error (#_GetLastError)))
175                     (format t "~& GetMessage: error = ~d (~a)" error
176                             (ccl::%windows-error-string error)))
177                   (return))
178                  (t
179                   (#_TranslateMessage msg)
180                   (#_DispatchMessageA msg)))))))))
181                                     
182       
183#||
184
185;;; At the moment, attempts to create a window when running under SLIME
186;;; fail for unknown reasons.  If those reasons have anything to do with
187;;; the lisp process's "WindowStation" or the current thread's "Desktop"
188;;; objects, these functions (which return information about those objects)
189;;; may be useful.
190
191(defun get-ws-info (ws)
192  (rlet ((flags #>USEROBJECTFLAGS))
193    (unless (eql 0 (#_GetUserObjectInformationA ws #$UOI_FLAGS flags (ccl::record-length #>USEROBJECTFLAGS) (%null-ptr)))
194      (pref flags #>USEROBJECTFLAGS.dwFlags))))
195
196;;; This only works on Vista or later.
197(defun get-desktop-info (desktop)
198  (rlet ((pbool #>BOOLEAN #$false))
199    (if (eql 0 (#_GetUserObjectInformationA desktop 6 pbool (ccl::record-length #>BOOLEAN) (%null-ptr)))
200      (ccl::%windows-error-string (#_GetLastError))
201      (pref pbool #>BOOLEAN))))
202
203(defun get-ui-object-name (handle)
204  (%stack-block ((name 1000))
205    (unless (eql 0 (#_GetUserObjectInformationA handle #$UOI_NAME name 1000 (%null-ptr)))
206      (%get-cstring name))))
207||#
Note: See TracBrowser for help on using the repository browser.