mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-07 09:50:25 -08:00
Code Issues Projects Releases Packages Wiki Activity

New example of using UFFI with ECL (M. Goffioul)

Browse source
This commit is contained in:
jjgarcia 2005-06-07 14:52:24 +00:00
parent ce4640bd69
commit 8e041f10b9
4 changed files with 656 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

19
contrib/win32/README Normal file
View file

@ -0,0 +1,19 @@
In this directory you will find an interesting example of an application built
using ECL's implementation of the UFFI specification.
This example consists on several files:
* win32.lsp: This is a lisp interface to the Microsoft Windows API
for the graphical user interface. It is not finished but it suffices
to demonstrate the most important ingredients you will need in a
real-world application.
* txtedit.lsp: A simple text editor written using the previous library.
* compile-and-run.lsp: This lisp script builds the Win32 library and
runs the text editor using it.
This library has been contributed by Michael Goffioul (michael dot goffioul at
swing dot be). Feel free to experiment with it and share your experience at
the ECL mailing list.

18
contrib/win32/compile-and-run.lsp Normal file
View file

@ -0,0 +1,18 @@
;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be)
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; See file '../../Copyright' for full details.
;;;
;;; COMPILE THE WIN32 EXAMPLES
;;;
(require :cmp)
(let ((c::*ld-format* (concatenate 'string c::*ld-format* " user32.lib kernel32.lib gdi32.lib comdlg32.lib")))
(compile-file "win32.lisp" :c-file t))
(load "txtedit.lsp")

184
contrib/win32/txtedit.lisp Normal file
View file

@ -0,0 +1,184 @@
;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be)
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; See file '../../Copyright' for full details.
;;;
;;; SAMPLE TEXT EDITOR APPLICATION USING THE WIN32 API
;;;
(in-package "WIN32")
(defvar *txtedit-class-registered* nil)
(defvar *txtedit-width* 800)
(defvar *txtedit-height* 600)
(defvar *txtedit-edit* *NULL*)
(defvar *txtedit-dirty* nil)
(defvar *txtedit-default-title* "ECL Text Editor")
(defparameter +IDM_OPEN+ 100)
(defparameter +IDM_QUIT+ 101)
(defparameter +IDM_SAVE+ 102)
(defparameter +IDM_SAVEAS+ 103)
(defparameter +IDM_NEW+ 104)
(defparameter +EDITCTL_ID+ 1000)
(defun create-menus ()
;(return *NULL*)
(let ((bar (createmenu))
(file_pop (createpopupmenu))
(edit_pop (createpopupmenu)))
;; File menu
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam file_pop) "File")
(appendmenu file_pop *MF_STRING* +IDM_NEW+ "New")
(appendmenu file_pop *MF_STRING* +IDM_OPEN+ "Open...")
(appendmenu file_pop *MF_SEPARATOR* 0 "")
(appendmenu file_pop *MF_STRING* +IDM_SAVE+ "Save")
(appendmenu file_pop *MF_STRING* +IDM_SAVEAS+ "Save As...")
(appendmenu file_pop *MF_SEPARATOR* 0 "")
(appendmenu file_pop *MF_STRING* +IDM_QUIT+ "Exit")
;; Edit menu
(appendmenu bar (logior *MF_STRING* *MF_POPUP*) (make-wparam edit_pop) "Edit")
bar))
(defun is-default-title (hwnd)
(string= (string-right-trim "*" (getwindowtext hwnd)) *txtedit-default-title*))
(defun unix2dos (str)
(let ((new-str (make-array (length str) :element-type 'character :adjustable t :fill-pointer 0))
(return-p nil)
c)
(with-output-to-string (out new-str)
(do ((it (si::make-seq-iterator str) (si::seq-iterator-next str it)))
((null it))
(case (setq c (si::seq-iterator-ref str it))
(#\Return (setq return-p t))
(#\Newline (unless return-p (write-char #\Return out)) (setq return-p nil))
(t (setq return-p nil)))
(write-char c out)))
new-str))
(defun read-file (pn hwnd)
(format t "~&reading ~S~%" pn)
(with-open-file (f pn)
(let* ((len (file-length f))
(buf (make-string len)))
(read-sequence buf f)
(setwindowtext *txtedit-edit* (unix2dos buf))
(setq *txtedit-dirty* nil)
(setwindowtext hwnd (namestring pn)))))
(defun save-file (pn hwnd)
(unless pn
(setq pn (string-right-trim "*" (getwindowtext hwnd))))
(with-open-file (f pn :direction :output :if-does-not-exist :create :if-exists :supersede)
(let ((txt (getwindowtext *txtedit-edit*)))
(write-sequence txt f)
(setwindowtext hwnd (namestring pn))
(setq *txtedit-dirty* nil))))
(defun txtedit-proc (hwnd umsg wparam lparam)
(cond ((= umsg *WM_DESTROY*)
(postquitmessage 0)
0)
((= umsg *WM_CLOSE*)
(if (and *txtedit-dirty*
(let ((m-result (messagebox *txtedit-edit* "Do you want to save changes?" "Confirmation"
(logior *MB_YESNOCANCEL* *MB_ICONQUESTION*))))
(cond ((= m-result *IDNO*) nil)
((= m-result *IDCANCEL*) t)
((= m-result *IDYES*) (warn "Not implemented") t))))
0
(destroywindow hwnd)))
((= umsg *WM_CREATE*)
(setq *txtedit-edit* (createwindowex *WS_EX_CLIENTEDGE* "EDIT" ""
(logior *WS_CHILD* *WS_VISIBLE* *WS_HSCROLL* *WS_VSCROLL*
*ES_AUTOHSCROLL* *ES_AUTOVSCROLL* *ES_MULTILINE* *ES_LEFT*)
0 0 0 0 hwnd (make-ID +EDITCTL_ID+) *NULL* *NULL*))
(sendmessage *txtedit-edit* *WM_SETFONT* (make-wparam (getstockobject *SYSTEM_FIXED_FONT*)) 0)
(with-cast-int-pointer (lparam CREATESTRUCT)
(let ((params (get-slot-value lparam 'CREATESTRUCT 'lpCreateParams)))
(unless (null-pointer-p params)
(read-file (convert-from-foreign-string params) hwnd))))
0)
((= umsg *WM_SIZE*)
(unless (null-pointer-p *txtedit-edit*)
(movewindow *txtedit-edit* 0 0 (loword lparam) (hiword lparam) *TRUE*))
0)
((= umsg *WM_SETFOCUS*)
(unless (null-pointer-p *txtedit-edit*)
(setfocus *txtedit-edit*))
0)
((= umsg *WM_COMMAND*)
(let ((ctrl-ID (loword wparam))
(nmsg (hiword wparam))
(hnd (make-pointer lparam 'HANDLE)))
(cond ((= ctrl-ID +EDITCTL_ID+)
(cond ((= nmsg *EN_CHANGE*)
(unless *txtedit-dirty*
(setwindowtext hwnd (concatenate 'string (getwindowtext hwnd) "*"))
(setq *txtedit-dirty* t)))
(t
)))
((= ctrl-ID +IDM_QUIT+)
(sendmessage hwnd *WM_CLOSE* 0 0))
((= ctrl-ID +IDM_OPEN+)
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
("All Files (*)" . "*")))))
(when pn
(read-file pn hwnd))))
((and (= ctrl-ID +IDM_SAVE+)
(not (is-default-title hwnd)))
(save-file nil hwnd))
((or (= ctrl-ID +IDM_SAVEAS+)
(and (= ctrl-ID +IDM_SAVE+)
(is-default-title hwnd)))
(let ((pn (get-open-filename :owner hwnd :filter '(("LISP source file (*.lisp)" . "*.lisp;*.lsp")
("All Files (*)" . "*"))
:dlgfn #'getsavefilename :flags *OFN_OVERWRITEPROMPT*)))
(when pn
(save-file pn hwnd))))
((= ctrl-ID +IDM_NEW+)
(setwindowtext *txtedit-edit* "")
(setwindowtext hwnd *txtedit-default-title*))
(t
)))
0)
(t
(defwindowproc hwnd umsg wparam lparam))
))
(defun register-txtedit-class ()
(unless *txtedit-class-registered*
(make-wndclass "SimpleTextEditor"
:lpfnWndProc #'txtedit-proc)
(setq *txtedit-class-registered* t)))
(defun unregister-txtedit-class ()
(when *txtedit-class-registered*
(unregisterclass "SimpleTextEditor" *NULL*)
(setq *txtedit-class-registered* nil)))
(defun txtedit (&optional fname)
(register-txtedit-class)
(let* ((fname-str (if fname
(convert-to-foreign-string (coerce fname 'simple-string))
*NULL*))
(w (createwindow "SimpleTextEditor"
*txtedit-default-title*
*WS_OVERLAPPEDWINDOW*
*CW_USEDEFAULT* *CW_USEDEFAULT*
*txtedit-width* *txtedit-height*
*NULL* (create-menus) *NULL* fname-str)))
(showwindow w *SW_SHOWNORMAL*)
(updatewindow w)
(event-loop)
(setq *txtedit-edit* *NULL*)
(unless (null-pointer-p fname-str)
(free-foreign-object fname-str))
(unregister-txtedit-class)
nil))

435
contrib/win32/win32.lisp Normal file
View file

@ -0,0 +1,435 @@
;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be)
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; See file '../../Copyright' for full details.
;;;
;;; FOREIGN FUNCTION INTERFACE TO MICROSOFT WINDOWS API
;;;
(defpackage "WIN32"
(:use "COMMON-LISP" "FFI")
(:export))
(in-package "WIN32")
(clines "#define WINVER 0x500")
(clines "#include <windows.h>")
;; Windows types
(def-foreign-type HANDLE :pointer-void)
(def-foreign-type LPCSTR :cstring)
(def-foreign-type WNDPROC :pointer-void)
;; Windows constants
(defmacro define-win-constant (name c-name &optional (c-type :int))
`(defconstant ,name (c-inline () () ,(ffi::%convert-to-ffi-type c-type) ,c-name :one-liner t)))
(define-win-constant *TRUE* "TRUE")
(define-win-constant *FALSE* "FALSE")
(define-win-constant *WM_CLOSE* "WM_CLOSE")
(define-win-constant *WM_COMMAND* "WM_COMMAND")
(define-win-constant *WM_CREATE* "WM_CREATE")
(define-win-constant *WM_DESTROY* "WM_DESTROY")
(define-win-constant *WM_GETFONT* "WM_GETFONT")
(define-win-constant *WM_GETMINMAXINFO* "WM_GETMINMAXINFO")
(define-win-constant *WM_QUIT* "WM_QUIT")
(define-win-constant *WM_SETFOCUS* "WM_SETFOCUS")
(define-win-constant *WM_SETFONT* "WM_SETFONT")
(define-win-constant *WM_SIZE* "WM_SIZE")
(define-win-constant *WS_BORDER* "WS_BORDER")
(define-win-constant *WS_CHILD* "WS_CHILD")
(define-win-constant *WS_DLGFRAME* "WS_DLGFRAME")
(define-win-constant *WS_DISABLED* "WS_DISABLED")
(define-win-constant *WS_HSCROLL* "WS_HSCROLL")
(define-win-constant *WS_OVERLAPPEDWINDOW* "WS_OVERLAPPEDWINDOW")
(define-win-constant *WS_VISIBLE* "WS_VISIBLE")
(define-win-constant *WS_VSCROLL* "WS_VSCROLL")
(define-win-constant *WS_EX_CLIENTEDGE* "WS_EX_CLIENTEDGE")
(define-win-constant *HWND_BOTTOM* "HWND_BOTTOM" HANDLE)
(define-win-constant *HWND_NOTOPMOST* "HWND_NOTOPMOST" HANDLE)
(define-win-constant *HWND_TOP* "HWND_TOP" HANDLE)
(define-win-constant *HWND_TOPMOST* "HWND_TOPMOST" HANDLE)
(define-win-constant *SWP_NOZORDER* "SWP_NOZORDER")
(define-win-constant *SWP_NOSIZE* "SWP_NOSIZE")
(define-win-constant *BS_DEFPUSHBUTTON* "BS_DEFPUSHBUTTON")
(define-win-constant *BS_PUSHBUTTON* "BS_PUSHBUTTON")
(define-win-constant *BN_CLICKED* "BN_CLICKED")
(define-win-constant *ES_AUTOHSCROLL* "ES_AUTOHSCROLL")
(define-win-constant *ES_AUTOVSCROLL* "ES_AUTOVSCROLL")
(define-win-constant *ES_LEFT* "ES_LEFT")
(define-win-constant *ES_MULTILINE* "ES_MULTILINE")
(define-win-constant *EN_CHANGE* "EN_CHANGE")
(define-win-constant *SW_SHOWNORMAL* "SW_SHOWNORMAL")
(define-win-constant *CW_USEDEFAULT* "CW_USEDEFAULT")
(define-win-constant *IDC_ARROW* "IDC_ARROW")
(define-win-constant *IDI_APPLICATION* "IDI_APPLICATION")
(define-win-constant *COLOR_BACKGROUND* "COLOR_BACKGROUND")
(define-win-constant *DEFAULT_GUI_FONT* "DEFAULT_GUI_FONT")
(define-win-constant *OEM_FIXED_FONT* "OEM_FIXED_FONT")
(define-win-constant *SYSTEM_FONT* "SYSTEM_FONT")
(define-win-constant *SYSTEM_FIXED_FONT* "SYSTEM_FIXED_FONT")
(define-win-constant *MB_HELP* "MB_HELP")
(define-win-constant *MB_OK* "MB_OK")
(define-win-constant *MB_OKCANCEL* "MB_OKCANCEL")
(define-win-constant *MB_YESNO* "MB_YESNO")
(define-win-constant *MB_YESNOCANCEL* "MB_YESNOCANCEL")
(define-win-constant *MB_ICONEXCLAMATION* "MB_ICONEXCLAMATION")
(define-win-constant *MB_ICONWARNING* "MB_ICONWARNING")
(define-win-constant *MB_ICONINFORMATION* "MB_ICONINFORMATION")
(define-win-constant *MB_ICONQUESTION* "MB_ICONQUESTION")
(define-win-constant *IDCANCEL* "IDCANCEL")
(define-win-constant *IDNO* "IDNO")
(define-win-constant *IDOK* "IDOK")
(define-win-constant *IDYES* "IDYES")
(define-win-constant *MF_DISABLED* "MF_DISABLED")
(define-win-constant *MF_ENABLED* "MF_ENABLED")
(define-win-constant *MF_MENUBREAK* "MF_MENUBREAK")
(define-win-constant *MF_POPUP* "MF_POPUP")
(define-win-constant *MF_SEPARATOR* "MF_SEPARATOR")
(define-win-constant *MF_STRING* "MF_STRING")
(define-win-constant *OFN_FILEMUSTEXIST* "OFN_FILEMUSTEXIST")
(define-win-constant *OFN_OVERWRITEPROMPT* "OFN_OVERWRITEPROMPT")
(define-win-constant *OFN_PATHMUSTEXIST* "OFN_PATHMUSTEXIST")
(define-win-constant *OFN_READONLY* "OFN_READONLY")
(defconstant *NULL* (make-null-pointer :pointer-void))
;; Windows structures
(def-struct WNDCLASS
(style :unsigned-int)
(lpfnWndProc WNDPROC)
(cbClsExtra :int)
(cbWndExtra :int)
(hInstance HANDLE)
(hIcon HANDLE)
(hCursor HANDLE)
(hbrBackground HANDLE)
(lpszMenuName :cstring)
(lpszClassName :cstring))
(defun make-wndclass (name &key (style 0) (lpfnWndProc nil) (cbClsExtra 0) (cbWndExtra 0) (hInstance *NULL*)
(hIcon (default-icon)) (hCursor (default-cursor)) (hbrBackground (default-background))
(lpszMenuName ""))
(with-foreign-object (cls 'WNDCLASS)
(setf (get-slot-value cls 'WNDCLASS 'style) style
(get-slot-value cls 'WNDCLASS 'lpfnWndProc) *DEFAULT_WNDPROC*
(get-slot-value cls 'WNDCLASS 'cbClsExtra) cbClsExtra
(get-slot-value cls 'WNDCLASS 'cbWndExtra) cbWndExtra
(get-slot-value cls 'WNDCLASS 'hInstance) hInstance
(get-slot-value cls 'WNDCLASS 'hIcon) hIcon
(get-slot-value cls 'WNDCLASS 'hCursor) hCursor
(get-slot-value cls 'WNDCLASS 'hbrBackground) hbrBackground
(get-slot-value cls 'WNDCLASS 'lpszMenuName) lpszMenuName
(get-slot-value cls 'WNDCLASS 'lpszClassName) (string name))
(register-wndproc (string name) lpfnWndProc)
(registerclass cls)))
(def-struct POINT
(x :int)
(y :int))
(def-struct MSG
(hwnd HANDLE)
(message :unsigned-int)
(wParam :unsigned-int)
(lParam :int)
(time :unsigned-int)
(pt POINT))
(def-struct CREATESTRUCT
(lpCreateParams :pointer-void)
(hInstance HANDLE)
(hMenu HANDLE)
(hwndParent HANDLE)
(cx :int)
(cy :int)
(x :int)
(y :int)
(style :long)
(lpszName :cstring)
(lpszClass :cstring)
(dwExStyle :unsigned-int))
(def-struct MINMAXINFO
(ptReserved POINT)
(ptMaxSize POINT)
(ptMaxPosition POINT)
(ptMinTrackSize POINT)
(ptMaxTrackSize POINT))
(def-struct TEXTMETRIC (tmHeight :long) (tmAscent :long) (tmDescent :long) (tmInternalLeading :long) (tmExternalLeading :long)
(tmAveCharWidth :long) (tmMaxCharWidth :long) (tmWeight :long) (tmOverhang :long) (tmDigitizedAspectX :long)
(tmDigitizedAspectY :long) (tmFirstChar :char) (tmLastChar :char) (tmDefaultChar :char) (tmBreakChar :char)
(tmItalic :byte) (tmUnderlined :byte) (tmStruckOut :byte) (tmPitchAndFamily :byte) (tmCharSet :byte))
(def-struct SIZE (cx :long) (cy :long))
(def-struct RECT (left :long) (top :long) (right :long) (bottom :long))
(def-struct TITLEBARINFO (cbSize :unsigned-int) (rcTitlebar RECT) (rgstate (:array :unsigned-int 6)))
(def-struct OPENFILENAME (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (lpstrFilter LPCSTR) (lpstrCustomFilter LPCSTR)
(nMaxFilter :unsigned-int) (nFilterIndex :unsigned-int) (lpstrFile LPCSTR) (nMaxFile :unsigned-int) (lpstrFileTitle LPCSTR)
(nMaxFileTitle :unsigned-int) (lpstrInitialDir LPCSTR) (lpstrTitle LPCSTR) (Flags :unsigned-int) (nFileOffset :unsigned-short)
(nFileExtension :unsigned-short) (lpstrDefExt LPCSTR) (lCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR)
(pvReserved :pointer-void) (dwReserved :unsigned-int) (FlagsEx :unsigned-int))
;; Windows functions
(defvar *wndproc-db* nil)
(defun register-wndproc (class wndproc)
(let ((entry (assoc class *wndproc-db* :test #'string-equal)))
(if entry
(rplacd entry wndproc)
(push (cons class wndproc) *wndproc-db*))))
(defun get-wndproc (class)
(let ((entry (assoc class *wndproc-db* :test #'string-equal)))
(and entry
(cdr entry))))
(eval-when (compile)
(proclaim '(si::c-export-fname win32::wndproc-proxy)))
(defun wndproc-proxy (hnd umsg wparam lparam)
(let* ((cname (getclassname hnd))
(wndproc (get-wndproc cname)))
(unless wndproc
(error "Class ~S has no registered Windows prodecure" cname))
(funcall wndproc hnd umsg wparam lparam)))
(clines "
LRESULT CALLBACK WndProc_proxy(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)
{
return object_to_fixnum(
win32_wndproc_proxy(
4,
ecl_make_foreign_data(make_keyword(\"POINTER-VOID\"),0,hwnd),
make_unsigned_integer(uMsg),
make_unsigned_integer(wParam),
make_integer(lParam)));
}
")
(defconstant *DEFAULT_WNDPROC* (c-inline () () :pointer-void "WndProc_proxy" :one-liner t))
(defun make-ID (id)
(c-inline (id :pointer-void) (:unsigned-int :object) :object "ecl_make_foreign_data(#1,0,((void*)#0))" :one-liner t))
(defun make-wparam (hnd)
(c-inline (hnd) (:pointer-void) :unsigned-int "(WPARAM)#0" :one-liner t))
(defmacro with-cast-int-pointer ((var type &optional ptr) &body body)
(unless ptr (setq ptr var))
`(let ((,var (make-pointer ,ptr ',type))) ,@body))
(def-function ("ZeroMemory" zeromemory) ((Destination :pointer-void) (Length :unsigned-int)) :returning :void)
(def-function ("GetStockObject" getstockobject) ((fnObject :int)) :returning HANDLE)
(def-function ("GetTextMetrics" gettextmetrics) ((hdc HANDLE) (lptm (* TEXTMETRIC))) :returning :int)
(def-function ("GetDC" getdc) ((hWnd HANDLE)) :returning HANDLE)
(def-function ("ReleaseDC" releasedc) ((hWnd HANDLE) (hdc HANDLE)) :returning :int)
(def-function ("SelectObject" selectobject) ((hdc HANDLE) (hgdiobj HANDLE)) :returning HANDLE)
(def-function ("GetTextExtentPoint32" gettextextentpoint32) ((hdc HANDLE) (lpString :cstring) (cbString :int) (lpSize (* SIZE))) :returning :int)
(def-function ("LoadCursor" loadcursor-string) ((hnd HANDLE) (lpCursorName LPCSTR)) :returning HANDLE)
(def-function ("LoadCursor" loadcursor-int) ((hnd HANDLE) (lpCursorName :unsigned-int)) :returning HANDLE)
(defun loadcursor (hnd cur-name)
(etypecase cur-name
(fixnum (loadcursor-int hnd cur-name))
(string (loadcursor-string hnd cur-name))))
(defun default-cursor () (loadcursor *NULL* *IDC_ARROW*))
(def-function ("LoadIcon" loadicon-int) ((hnd HANDLE) (lpIconName :unsigned-int)) :returning HANDLE)
(def-function ("LoadIcon" loadicon-string) ((hnd HANDLE) (lpIconName LPCSTR)) :returning HANDLE)
(defun loadicon (hnd cur-name)
(etypecase cur-name
(fixnum (loadicon-int hnd cur-name))
(string (loadicon-string hnd cur-name))))
(defun default-icon () (loadicon *NULL* *IDI_APPLICATION*))
(defun default-background () (getstockobject *COLOR_BACKGROUND*))
(def-function ("GetClassName" getclassname-i) ((hnd HANDLE) (lpClassName LPCSTR) (maxCount :int)) :returning :int)
(defun getclassname (hnd)
(with-cstring (s (make-string 64))
(let ((n (getclassname-i hnd s 64)))
(when (= n 0)
(error "Unable to get class name for ~A" hnd))
(subseq s 0 n))))
(def-function ("RegisterClass" registerclass) ((lpWndClass (* WNDCLASS))) :returning :int)
(def-function ("UnregisterClass" unregisterclass) ((lpClassName :cstring) (hInstance HANDLE)) :returning :int)
(def-function ("CreateWindow" createwindow) ((lpClassName :cstring) (lpWindowName :cstring) (dwStyle :unsigned-int) (x :int) (y :int)
(nWidth :int) (nHeight :int) (hWndParent HANDLE) (hMenu HANDLE) (hInstance HANDLE) (lpParam :pointer-void))
:returning HANDLE)
(def-function ("CreateWindowEx" createwindowex) ((dwExStyle :unsigned-int) (lpClassName :cstring) (lpWindowName :cstring) (dwStyle :unsigned-int)
(x :int) (y :int) (nWidth :int) (nHeight :int) (hWndParent HANDLE) (hMenu HANDLE) (hInstance HANDLE)
(lpParam :pointer-void))
:returning HANDLE)
(def-function ("DestroyWindow" destroywindow) ((hWnd HANDLE)) :returning :int)
(def-function ("ShowWindow" showwindow) ((hWnd HANDLE) (nCmdShow :int)) :returning :int)
(def-function ("UpdateWindow" updatewindow) ((hWnd HANDLE)) :returning :void)
(def-function ("MoveWindow" movewindow) ((hWnd HANDLE) (x :int) (y :int) (nWidth :int) (nHeight :int) (bRepaint :int)) :returning :int)
(def-function ("SetWindowPos" setwindowpos) ((hWnd HANDLE) (hWndInsertAfter HANDLE) (x :int)
(y :int) (cx :int) (cy :int) (uFlags :unsigned-int)) :returning :int)
(def-function ("GetWindowText" getwindowtext-i) ((hWnd HANDLE) (lpString LPCSTR) (nMaxCount :int)) :returning :int)
(defun getwindowtext (hnd)
(let ((len (1+ (getwindowtextlength hnd))))
(with-cstring (s (make-string len))
(getwindowtext-i hnd s len)
(subseq s 0 (1- len)))))
(def-function ("GetWindowTextLength" getwindowtextlength) ((hWnd HANDLE)) :returning :int)
(def-function ("SetWindowText" setwindowtext) ((hWnd HANDLE) (lpString LPCSTR)) :returning :int)
(def-function ("GetTitleBarInfo" gettitlebarinfo) ((hWnd HANDLE) (pti (* TITLEBARINFO))) :returning :int)
(def-function ("SetFocus" setfocus) ((hWnd HANDLE)) :returning HANDLE)
(def-function ("PostQuitMessage" postquitmessage) ((nExitCode :int)) :returning :void)
(def-function ("SendMessage" sendmessage) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int)
(def-function ("PostMessage" postmessage) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int)
(def-function ("DefWindowProc" defwindowproc) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int)
(def-function ("HIWORD" hiword) ((dWord :unsigned-int)) :returning :unsigned-int)
(def-function ("LOWORD" loword) ((dWord :unsigned-int)) :returning :unsigned-int)
(def-function ("MessageBox" messagebox) ((hWnd HANDLE) (lpText LPCSTR) (lpCaption LPCSTR) (uType :unsigned-int)) :returning :int)
(def-function ("GetOpenFileName" getopenfilename) ((lpofn (* OPENFILENAME))) :returning :int)
(def-function ("GetSaveFileName" getsavefilename) ((lpofn (* OPENFILENAME))) :returning :int)
(def-function ("GetMessage" getmessage) ((lpMsg (* MSG)) (hWnd HANDLE) (wMsgFitlerMin :unsigned-int) (wMsgFilterMax :unsigned-int)) :returning :int)
(def-function ("TranslateMessage" translatemessage) ((lpMsg (* MSG))) :returning :int)
(def-function ("DispatchMessage" dispatchmessage) ((lpMsg (* MSG))) :returning :int)
(def-function ("CreateMenu" createmenu) nil :returning HANDLE)
(def-function ("CreatePopupMenu" createpopupmenu) nil :returning HANDLE)
(def-function ("AppendMenu" appendmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (uIDNewItem :unsigned-int) (lpNewItem LPCSTR)) :returning :int)
(defun event-loop ()
(with-foreign-object (msg 'MSG)
(loop for bRet = (getmessage msg *NULL* 0 0)
when (= bRet 0) return bRet
if (= bRet -1)
do (error "GetMessage failed!!!")
else
do (translatemessage msg)
and do (dispatchmessage msg))))
(defun y-or-no-p (&optional control &rest args)
(let ((s (coerce (apply #'format nil control args) 'simple-string)))
(= (messagebox *NULL* s "ECL Dialog" (logior *MB_YESNO* *MB_ICONQUESTION*))
*IDYES*)))
(defun get-open-filename (&key (owner *NULL*) initial-dir filter (dlgfn #'getopenfilename)
(flags 0) &aux (max-fn-size 1024))
(flet ((null-concat (x &optional y &aux (xx (if y x (car x))) (yy (if y y (cdr x))))
(concatenate 'string xx (string #\Null) yy)))
(when filter
(setq filter (format nil "~A~C~C" (reduce #'null-concat (mapcar #'null-concat filter)) #\Null #\Null)))
(with-foreign-object (ofn 'OPENFILENAME)
(with-cstring (fn (make-string max-fn-size :initial-element #\Null))
(zeromemory ofn (size-of-foreign-type 'OPENFILENAME))
(setf (get-slot-value ofn 'OPENFILENAME 'lStructSize) (size-of-foreign-type 'OPENFILENAME))
(setf (get-slot-value ofn 'OPENFILENAME 'hwndOwner) owner)
(setf (get-slot-value ofn 'OPENFILENAME 'lpstrFile) fn)
(setf (get-slot-value ofn 'OPENFILENAME 'nMaxFile) max-fn-size)
(setf (get-slot-value ofn 'OPENFILENAME 'Flags) flags)
(when filter
(setf (get-slot-value ofn 'OPENFILENAME 'lpstrFilter) filter))
(unless (= (funcall dlgfn ofn) 0)
(pathname (string-trim (string #\Null) fn)))))))
;;; Test code
(defconstant *HELLO_ID* 100)
(defconstant *OK_ID* 101)
(defparameter hBtn nil)
(defparameter hOk nil)
(defun button-min-size (hnd)
(let ((fnt (make-pointer (sendmessage hnd *WM_GETFONT* 0 0) :pointer-void))
(hdc (getdc hnd))
(txt (getwindowtext hnd)))
(unless (null-pointer-p fnt)
(selectobject hdc fnt))
(with-foreign-objects ((sz 'SIZE)
(tm 'TEXTMETRIC))
(gettextextentpoint32 hdc txt (length txt) sz)
(gettextmetrics hdc tm)
(releasedc hnd hdc)
(list (+ (get-slot-value sz 'SIZE 'cx) 20)
(+ (get-slot-value tm 'TEXTMETRIC 'tmHeight) 10)))))
(defun get-titlebar-rect (hnd)
(with-foreign-object (ti 'TITLEBARINFO)
(setf (get-slot-value ti 'TITLEBARINFO 'cbSize) (size-of-foreign-type 'TITLEBARINFO))
(gettitlebarinfo hnd ti)
(let ((rc (get-slot-value ti 'TITLEBARINFO 'rcTitlebar)))
(list (get-slot-value rc 'RECT 'left)
(get-slot-value rc 'RECT 'top)
(get-slot-value rc 'RECT 'right)
(get-slot-value rc 'RECT 'bottom)))))
(defun test-wndproc (hwnd umsg wparam lparam)
(cond ((= umsg *WM_DESTROY*)
(postquitmessage 0)
0)
((= umsg *WM_CREATE*)
(setq hBtn (createwindow "BUTTON" "Hello World!" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*)
0 0 50 20 hwnd (make-ID *HELLO_ID*) *NULL* *NULL*))
(setq hOk (createwindow "BUTTON" "Close" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*)
0 0 50 20 hwnd (make-ID *OK_ID*) *NULL* *NULL*))
(sendmessage hBtn *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
(sendmessage hOk *WM_SETFONT* (make-wparam (getstockobject *DEFAULT_GUI_FONT*)) 0)
0)
((= umsg *WM_SIZE*)
(let* ((new-w (loword lparam))
(new-h (hiword lparam))
(wb (- new-w 20))
(hb (/ (- new-h 30) 2)))
(movewindow hBtn 10 10 wb hb *TRUE*)
(movewindow hOk 10 (+ 20 hb) wb hb *TRUE*))
0)
((= umsg *WM_GETMINMAXINFO*)
(let* ((btn1-sz (and hBtn (button-min-size hBtn)))
(btn2-sz (and hOk (button-min-size hOk)))
(rc (get-titlebar-rect hWnd))
(titleH (1+ (- (fourth rc) (second rc)))))
(when (and btn1-sz btn2-sz (> titleH 0))
(with-foreign-object (minSz 'POINT)
(setf (get-slot-value minSz 'POINT 'x) (+ (max (first btn1-sz) (first btn2-sz)) 20))
(setf (get-slot-value minSz 'POINT 'y) (+ (second btn1-sz) (second btn2-sz) 30 titleH))
(with-cast-int-pointer (lparam MINMAXINFO)
(setf (get-slot-value lparam 'MINMAXINFO 'ptMinTrackSize) minSz)))))
0)
((= umsg *WM_COMMAND*)
(let ((n (hiword wparam))
(id (loword wparam)))
(cond ((= n *BN_CLICKED*)
(cond ((= id *HELLO_ID*)
(format t "~&Hellow World!~%"))
((= id *OK_ID*)
(destroywindow hwnd))))
(t
(format t "~&Un-handled notification: ~D~%" n))))
0)
(t
(defwindowproc hwnd umsg wparam lparam))))
(defun do-test ()
(make-wndclass "MyClass"
:lpfnWndProc #'test-wndproc)
(let* ((hwnd (createwindow
"MyClass"
"ECL/Win32 test"
*WS_OVERLAPPEDWINDOW*
*CW_USEDEFAULT*
*CW_USEDEFAULT*
130
120
*NULL*
*NULL*
*NULL*
*NULL*)))
(when (si::null-pointer-p hwnd)
(error "Unable to create window"))
(showwindow hwnd *SW_SHOWNORMAL*)
(updatewindow hwnd)
(event-loop)
(unregisterclass "MyClass" *NULL*)))