From 8e041f10b9e6977d17df4d27164ef044cc104e15 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Tue, 7 Jun 2005 14:52:24 +0000 Subject: [PATCH] New example of using UFFI with ECL (M. Goffioul) --- contrib/win32/README | 19 ++ contrib/win32/compile-and-run.lsp | 18 ++ contrib/win32/txtedit.lisp | 184 +++++++++++++ contrib/win32/win32.lisp | 435 ++++++++++++++++++++++++++++++ 4 files changed, 656 insertions(+) create mode 100644 contrib/win32/README create mode 100644 contrib/win32/compile-and-run.lsp create mode 100644 contrib/win32/txtedit.lisp create mode 100644 contrib/win32/win32.lisp diff --git a/contrib/win32/README b/contrib/win32/README new file mode 100644 index 000000000..e236dc304 --- /dev/null +++ b/contrib/win32/README @@ -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. + diff --git a/contrib/win32/compile-and-run.lsp b/contrib/win32/compile-and-run.lsp new file mode 100644 index 000000000..66bf14a0b --- /dev/null +++ b/contrib/win32/compile-and-run.lsp @@ -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") + diff --git a/contrib/win32/txtedit.lisp b/contrib/win32/txtedit.lisp new file mode 100644 index 000000000..6982991d3 --- /dev/null +++ b/contrib/win32/txtedit.lisp @@ -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)) diff --git a/contrib/win32/win32.lisp b/contrib/win32/win32.lisp new file mode 100644 index 000000000..cb16a77b5 --- /dev/null +++ b/contrib/win32/win32.lisp @@ -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 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*))) +