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

Last change on this file since 11220 was 11220, checked in by gb, 12 years ago

new file; needs some work ..

File size: 9.7 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 0 (format t "~& hwnd = ~s, msg = ~s, wparam = ~s, lparam = ~s"
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        ((eql msg #$WM_CREATE)
86         0)
87        (t
88         ;; In a more realistic example, we'd handle more cases here.
89         ;; Like many functions that deal with characters and strings,
90         ;; DefWindowProc is actually implemented as two functions:
91         ;; DefWindowProcA is the "ANSI" (8-bit character) version,
92         ;; and DefWindowProcW is the wide-character (UTF-16LE)
93         ;; version.
94         (#_DefWindowProcA hwnd msg wparam lparam))))
95                             
96
97;;; Register a named window class. ("class" in this sense has nothing to
98;;; do with CLOS or any other object system: windows of the same class
99;;; share a common window procedure callback and other attributes, which
100;;; we define here.
101;;; If the registration attempt is succesful, it'll return an "atom"
102;;; (a small integer that identifies the registered class); otherwise,
103;;;  it returns 0.
104(defvar *simple-window-class-atom* nil)
105
106(defun register-simple-window-class (class-name)
107  ;; We'll use an ANSI version that accepts a simple C string as the
108  ;; class name.
109  (or *simple-window-class-atom*
110      (setq *simple-window-class-atom*
111            (with-cstrs ((cname class-name))
112              (rlet ((wc #>WNDCLASSEX)) ; an "extended" WNDCLASS structure
113                (setf (pref wc #>WNDCLASSEX.cbSize) (ccl::record-length #>WNDCLASSEX)
114                      (pref wc #>WNDCLASSEX.style) (logior #$CS_HREDRAW #$CS_VREDRAW)
115                      (pref wc #>WNDCLASSEX.lpfnWndProc) simple-wndproc
116                      (pref wc #>WNDCLASSEX.cbClsExtra) 0
117                      (pref wc #>WNDCLASSEX.cbWndExtra) 0
118                      (pref wc #>WNDCLASSEX.hInstance) (#_GetModuleHandleA (%null-ptr))
119                      (pref wc #>WNDCLASSEX.hIcon) (%null-ptr)
120                      (pref wc #>WNDCLASSEX.hCursor) (#_LoadCursorA (%null-ptr) #$IDC_ARROW)
121                      (pref wc #>WNDCLASSEX.hbrBackground) (#_GetStockObject #$WHITE_BRUSH)
122                      (pref wc #>WNDCLASSEX.lpszMenuName) (%null-ptr)
123                      (pref wc #>WNDCLASSEX.lpszClassName) cname
124                      (pref wc #>WNDCLASSEX.hIconSm) (%null-ptr))
125                (let* ((atom (#_RegisterClassExA wc)))
126                  (if (eql 0 atom)
127                    (let* ((err (#_GetLastError)))
128                      (error "Error registering windows class ~s: ~d (~a)" class-name
129                             err
130                             (ccl::%windows-error-string err))))
131                  atom))))))
132
133;;; Main function: register a window class, make an instance of that
134;;; class, handle events for that window until it's closed.
135(defun make-simple-ms-window ()
136  (let* ((class-atom (register-simple-window-class "very-simple")))
137    (with-cstrs ((title "Look! A window!"))
138      (let* ((hwnd (#_CreateWindowExA 0 ;extended style
139                                      (%int-to-ptr class-atom) ; class name/atom
140                                      title 
141                                      (logior #$WS_EX_COMPOSITED #$WS_OVERLAPPEDWINDOW) ; style
142                                      #$CW_USEDEFAULT ; x pos
143                                      #$CW_USEDEFAULT ; y pos
144                                      #$CW_USEDEFAULT ; width
145                                      #$CW_USEDEFAULT ; height
146                                      (%null-ptr) ;parent window
147                                      (%null-ptr) ; menu handle
148                                      (#_GetModuleHandleA (%null-ptr)) ; us
149                                      (%null-ptr)))) ;info for MDI parents/children
150        (when (%null-ptr-p hwnd)
151          (error "CreateWindow failed: ~a" (ccl::%windows-error-string (#_GetLastError))))
152        (#_ShowWindow hwnd #$true)
153        (#_UpdateWindow hwnd)
154        ;; Loop, fetching messages, translating virtual key events
155        ;; into character-oriented events and dispatching each
156        ;; message until #_GetMessageA returns 0.
157        (rlet ((msg #>MSG))
158          (do* ((result (#_GetMessageA msg
159                                       (%null-ptr) ; for any window created by this thread)
160                                       0
161                                       0)
162                        (#_GetMessageA msg (%null-ptr) 0 0)))
163               ((eql 0 result)          ; message was WM_QUIT
164                (pref msg #>MSG.wParam))
165            (cond ((< result 0)
166                   (let* ((error (#_GetLastError)))
167                     (format t "~& GetMessage: error = ~d (~a)" error
168                             (ccl::%windows-error-string error)))
169                   (return))
170                  (t
171                   (#_TranslateMessage msg)
172                   (#_DispatchMessageA msg)))))))))
173                                     
174       
175#||
176
177;;; At the moment, attempts to create a window when running under SLIME
178;;; fail for unknown reasons.  If those reasons have anything to do with
179;;; the lisp process's "WindowStation" or the current thread's "Desktop"
180;;; objects, these functions (which return information about those objects)
181;;; may be useful.
182
183(defun get-ws-info (ws)
184  (rlet ((flags #>USEROBJECTFLAGS))
185    (unless (eql 0 (#_GetUserObjectInformationA ws #$UOI_FLAGS flags (ccl::record-length #>USEROBJECTFLAGS) (%null-ptr)))
186      (pref flags #>USEROBJECTFLAGS.dwFlags))))
187
188(defun get-desktop-info (desktop)
189  (rlet ((pbool #>BOOLEAN #$false))
190    (if (eql 0 (#_GetUserObjectInformationA desktop 6 pbool (ccl::record-length #>BOOLEAN) (%null-ptr)))
191      (pref pbool #>BOOLEAN)
192      (ccl::%windows-error-string (#_GetLastError)))))
193||#
Note: See TracBrowser for help on using the repository browser.