source: release/1.9/source/examples/mswin.lisp @ 15774

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

Fix comment.

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.