mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-10 03:03:47 -08:00
638 lines
34 KiB
Common Lisp
638 lines
34 KiB
Common Lisp
;;; 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
|
|
"#include <windows.h>"
|
|
"#include <commctrl.h>"
|
|
)
|
|
|
|
;; Windows types
|
|
|
|
(def-foreign-type HANDLE :pointer-void)
|
|
(def-foreign-type LPCSTR :cstring)
|
|
(def-foreign-type WNDPROC :pointer-void)
|
|
(def-foreign-type DWORD :unsigned-int)
|
|
(def-foreign-type WORD :unsigned-short)
|
|
|
|
;; Windows constants
|
|
|
|
(defmacro define-win-constant (name value &optional (c-type :int))
|
|
`(defconstant ,name ,value))
|
|
|
|
(define-win-constant *TRUE* 1)
|
|
(define-win-constant *FALSE* 0)
|
|
|
|
(define-win-constant *WM_CLOSE* #x0010)
|
|
(define-win-constant *WM_COMMAND* #x0111)
|
|
(define-win-constant *WM_CONTEXTMENU* #x007b)
|
|
(define-win-constant *WM_COPY* #x0301)
|
|
(define-win-constant *WM_CREATE* #x0001)
|
|
(define-win-constant *WM_CUT* #x0300)
|
|
(define-win-constant *WM_DESTROY* #x0002)
|
|
(define-win-constant *WM_GETFONT* #x0031)
|
|
(define-win-constant *WM_GETMINMAXINFO* #x0024)
|
|
(define-win-constant *WM_INITMENU* #x0116)
|
|
(define-win-constant *WM_INITMENUPOPUP* #x0117)
|
|
(define-win-constant *WM_NCPAINT* #x0085)
|
|
(define-win-constant *WM_NOTIFY* #x004e)
|
|
(define-win-constant *WM_PAINT* #x000f)
|
|
(define-win-constant *WM_PASTE* #x0302)
|
|
(define-win-constant *WM_QUIT* #x0012)
|
|
(define-win-constant *WM_SETFOCUS* #x0007)
|
|
(define-win-constant *WM_SETFONT* #x0030)
|
|
(define-win-constant *WM_SIZE* #x0005)
|
|
(define-win-constant *WM_UNDO* #x0304)
|
|
(define-win-constant *WM_USER* #x0400)
|
|
|
|
(define-win-constant *WS_BORDER* #x00800000)
|
|
(define-win-constant *WS_CHILD* #x40000000)
|
|
(define-win-constant *WS_CLIPCHILDREN* #x02000000)
|
|
(define-win-constant *WS_CLIPSIBLINGS* #x04000000)
|
|
(define-win-constant *WS_DLGFRAME* #x00400000)
|
|
(define-win-constant *WS_DISABLED* #x08000000)
|
|
(define-win-constant *WS_HSCROLL* #x00100000)
|
|
(define-win-constant *WS_OVERLAPPEDWINDOW* #x00CF0000)
|
|
(define-win-constant *WS_VISIBLE* #x10000000)
|
|
(define-win-constant *WS_VSCROLL* #x00200000)
|
|
|
|
(define-win-constant *WS_EX_CLIENTEDGE* #x00000200)
|
|
|
|
(define-win-constant *RICHEDIT_CLASS* "RichEdit20A")
|
|
(define-win-constant *WC_LISTVIEW* "SysListView32")
|
|
(define-win-constant *WC_TABCONTROL* "SysTabControl32")
|
|
|
|
(define-win-constant *HWND_BOTTOM* (make-pointer 1 'HANDLE))
|
|
(define-win-constant *HWND_NOTOPMOST* (make-pointer -2 'HANDLE))
|
|
(define-win-constant *HWND_TOP* (make-pointer 0 'HANDLE))
|
|
(define-win-constant *HWND_TOPMOST* (make-pointer -1 'HANDLE))
|
|
|
|
(define-win-constant *SWP_DRAWFRAME* #x0020)
|
|
(define-win-constant *SWP_HIDEWINDOW* #x0080)
|
|
(define-win-constant *SWP_NOMOVE* #x0002)
|
|
(define-win-constant *SWP_NOOWNERZORDER* #x0200)
|
|
(define-win-constant *SWP_NOREDRAW* #x0008)
|
|
(define-win-constant *SWP_NOREPOSITION* #x0200)
|
|
(define-win-constant *SWP_NOSIZE* #x0001)
|
|
(define-win-constant *SWP_NOZORDER* #x0004)
|
|
(define-win-constant *SWP_SHOWWINDOW* #x0040)
|
|
|
|
(define-win-constant *BS_DEFPUSHBUTTON* #x00000000)
|
|
(define-win-constant *BS_PUSHBUTTON* #x00000001)
|
|
|
|
(define-win-constant *BN_CLICKED* 0)
|
|
|
|
(define-win-constant *ES_AUTOHSCROLL* #x0080)
|
|
(define-win-constant *ES_AUTOVSCROLL* #x0040)
|
|
(define-win-constant *ES_LEFT* #x0000)
|
|
(define-win-constant *ES_MULTILINE* #x0004)
|
|
|
|
(define-win-constant *EM_CANUNDO* #x00c6)
|
|
(define-win-constant *EM_SETEVENTMASK* (+ *WM_USER* 69))
|
|
(define-win-constant *EM_SETSEL* #x00b1)
|
|
(define-win-constant *EM_UNDO* #x00c7)
|
|
(define-win-constant *EN_CHANGE* #x0300)
|
|
(define-win-constant *ENM_CHANGE* #x00000001)
|
|
|
|
(define-win-constant *TCIF_IMAGE* #x0002)
|
|
(define-win-constant *TCIF_PARAM* #x0008)
|
|
(define-win-constant *TCIF_RTLREADING* #x0004)
|
|
(define-win-constant *TCIF_STATE* #x0010)
|
|
(define-win-constant *TCIF_TEXT* #x0001)
|
|
|
|
(define-win-constant *TCHT_NOWHERE* #x0001)
|
|
(define-win-constant *TCHT_ONITEM* #x0006)
|
|
(define-win-constant *TCHT_ONITEMICON* #x0002)
|
|
(define-win-constant *TCHT_ONITEMLABEL* #x0004)
|
|
|
|
(define-win-constant *TCM_FIRST* #x1300)
|
|
(define-win-constant *TCN_FIRST* #xfffffdda)
|
|
(define-win-constant *TCM_ADJUSTRECT* (+ *TCM_FIRST* 40))
|
|
(define-win-constant *TCM_DELETEITEM* (+ *TCM_FIRST* 8))
|
|
(define-win-constant *TCM_GETCURSEL* (+ *TCM_FIRST* 11))
|
|
(define-win-constant *TCM_HITTEST* (+ *TCM_FIRST* 13))
|
|
(define-win-constant *TCM_INSERTITEM* (+ *TCM_FIRST* 7))
|
|
(define-win-constant *TCM_SETCURSEL* (+ *TCM_FIRST* 12))
|
|
(define-win-constant *TCM_SETITEM* (+ *TCM_FIRST* 6))
|
|
(define-win-constant *TCN_SELCHANGE* (- *TCN_FIRST* 1))
|
|
|
|
(define-win-constant *NM_FIRST* #x100000000)
|
|
(define-win-constant *NM_CLICK* (- *NM_FIRST* 1))
|
|
(define-win-constant *NM_RCLICK* (- *NM_FIRST* 5))
|
|
|
|
(define-win-constant *SW_HIDE* 0)
|
|
(define-win-constant *SW_SHOW* 5)
|
|
(define-win-constant *SW_SHOWNORMAL* 1)
|
|
|
|
(define-win-constant *RDW_ERASE* #x0004)
|
|
(define-win-constant *RDW_FRAME* #x0400)
|
|
(define-win-constant *RDW_INTERNALPAINT* #x0002)
|
|
(define-win-constant *RDW_INVALIDATE* #x0001)
|
|
(define-win-constant *RDW_NOERASE* #x0020)
|
|
(define-win-constant *RDW_NOFRAME* #x0800)
|
|
(define-win-constant *RDW_NOINTERNALPAINT* #x0010)
|
|
(define-win-constant *RDW_VALIDATE* #x0008)
|
|
(define-win-constant *RDW_ERASENOW* #x0200)
|
|
(define-win-constant *RDW_UPDATENOW* #x0100)
|
|
(define-win-constant *RDW_ALLCHILDREN* #x0080)
|
|
(define-win-constant *RDW_NOCHILDREN* #x0040)
|
|
|
|
(define-win-constant *CW_USEDEFAULT* (- #x80000000))
|
|
|
|
(define-win-constant *IDC_ARROW* 32512)
|
|
(define-win-constant *IDI_APPLICATION* 32512)
|
|
|
|
(define-win-constant *COLOR_BACKGROUND* 1)
|
|
(define-win-constant *DEFAULT_GUI_FONT* 17)
|
|
(define-win-constant *OEM_FIXED_FONT* 10)
|
|
(define-win-constant *SYSTEM_FONT* 13)
|
|
(define-win-constant *SYSTEM_FIXED_FONT* 16)
|
|
|
|
(define-win-constant *MB_HELP* #x00004000)
|
|
(define-win-constant *MB_OK* #x00000000)
|
|
(define-win-constant *MB_OKCANCEL* #x00000001)
|
|
(define-win-constant *MB_YESNO* #x00000004)
|
|
(define-win-constant *MB_YESNOCANCEL* #x00000003)
|
|
(define-win-constant *MB_ICONEXCLAMATION* #x00000030)
|
|
(define-win-constant *MB_ICONWARNING* #x00000020)
|
|
(define-win-constant *MB_ICONERROR* #x00000010)
|
|
(define-win-constant *MB_ICONINFORMATION* #x00000040)
|
|
(define-win-constant *MB_ICONQUESTION* #x00000020)
|
|
|
|
(define-win-constant *IDCANCEL* 2)
|
|
(define-win-constant *IDNO* 7)
|
|
(define-win-constant *IDOK* 1)
|
|
(define-win-constant *IDYES* 6)
|
|
|
|
(define-win-constant *MF_BYCOMMAND* #x00000000)
|
|
(define-win-constant *MF_BYPOSITION* #x00000400)
|
|
(define-win-constant *MF_CHECKED* #x00000008)
|
|
(define-win-constant *MF_DISABLED* #x00000002)
|
|
(define-win-constant *MF_ENABLED* #x00000000)
|
|
(define-win-constant *MF_GRAYED* #x00000001)
|
|
(define-win-constant *MF_MENUBREAK* #x00000040)
|
|
(define-win-constant *MF_POPUP* #x00000010)
|
|
(define-win-constant *MF_SEPARATOR* #x00000800)
|
|
(define-win-constant *MF_STRING* #x00000000)
|
|
(define-win-constant *MF_UNCHECKED* #x00000000)
|
|
|
|
(define-win-constant *TPM_CENTERALIGN* #x0004)
|
|
(define-win-constant *TPM_LEFTALIGN* #x0000)
|
|
(define-win-constant *TPM_RIGHTALIGN* #x0008)
|
|
(define-win-constant *TPM_BOTTOMALIGN* #x0020)
|
|
(define-win-constant *TPM_TOPALIGN* #x0000)
|
|
(define-win-constant *TPM_VCENTERALIGN* #x0010)
|
|
(define-win-constant *TPM_NONOTIFY* #x0080)
|
|
(define-win-constant *TPM_RETURNCMD* #x0100)
|
|
(define-win-constant *TPM_LEFTBUTTON* #x0000)
|
|
(define-win-constant *TPM_RIGHTBUTTON* #x0002)
|
|
|
|
(define-win-constant *OFN_FILEMUSTEXIST* #x00001000)
|
|
(define-win-constant *OFN_OVERWRITEPROMPT* #x00000002)
|
|
(define-win-constant *OFN_PATHMUSTEXIST* #x00000800)
|
|
(define-win-constant *OFN_READONLY* #x00000001)
|
|
|
|
(define-win-constant *FVIRTKEY* *TRUE*)
|
|
(define-win-constant *FNOINVERT* #x02)
|
|
(define-win-constant *FSHIFT* #x04)
|
|
(define-win-constant *FCONTROL* #x08)
|
|
(define-win-constant *FALT* #x10)
|
|
|
|
(define-win-constant *VK_F1* #x70)
|
|
(define-win-constant *VK_LEFT* #x25)
|
|
(define-win-constant *VK_RIGHT* #x27)
|
|
|
|
(define-win-constant *GWL_EXSTYLE* -20)
|
|
(define-win-constant *GWL_HINSTANCE* -6)
|
|
(define-win-constant *GWL_HWNDPARENT* -8)
|
|
(define-win-constant *GWL_ID* -12)
|
|
(define-win-constant *GWL_STYLE* -16)
|
|
(define-win-constant *GWL_WNDPROC* -4)
|
|
|
|
(define-win-constant *FINDMSGSTRING* "commdlg_FindReplace")
|
|
(define-win-constant *HELPMSGSTRING* "commdlg_help")
|
|
|
|
(define-win-constant *FR_DIALOGTERM* #x00000040)
|
|
(define-win-constant *FR_DOWN* #x00000001)
|
|
(define-win-constant *FR_FINDNEXT* #x00000008)
|
|
(define-win-constant *FR_HIDEUPDOWN* #x00004000)
|
|
(define-win-constant *FR_HIDEMATCHCASE* #x00008000)
|
|
(define-win-constant *FR_HIDEWHOLEWORD* #x00010000)
|
|
(define-win-constant *FR_MATCHCASE* #x00000004)
|
|
(define-win-constant *FR_NOMATCHCASE* #x00000800)
|
|
(define-win-constant *FR_NOUPDOWN* #x00000400)
|
|
(define-win-constant *FR_NOWHOLEWORD* #x00001000)
|
|
(define-win-constant *FR_REPLACE* #x00000010)
|
|
(define-win-constant *FR_REPLACEALL* #x00000020)
|
|
(define-win-constant *FR_SHOWHELP* #x00000080)
|
|
(define-win-constant *FR_WHOLEWORD* #x00000002)
|
|
|
|
(defconstant *NULL* (make-null-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) (callback 'wndproc-proxy)
|
|
(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)|#)
|
|
(def-struct ACCEL (fVirt :byte) (key :unsigned-short) (cmd :unsigned-short))
|
|
(def-struct TCITEM (mask :unsigned-int) (dwState :unsigned-int) (dwStateMask :unsigned-int)
|
|
(pszText :cstring) (cchTextMax :int) (iImage :int) (lParam :long))
|
|
(def-struct NMHDR (hwndFrom HANDLE) (idFrom :unsigned-int) (code :unsigned-int))
|
|
(def-struct TCHITTESTINFO (pt POINT) (flag :unsigned-int))
|
|
(def-struct TPMPARAMS (cbSize :unsigned-int) (rcExclude RECT))
|
|
(def-struct FINDREPLACE (lStructSize :unsigned-int) (hwndOwner HANDLE) (hInstance HANDLE) (Flags DWORD)
|
|
(lpstrFindWhat LPCSTR) (lpstrReplaceWith LPCSTR) (wFindWhatLen WORD) (wReplaceWithLen WORD)
|
|
(lpCustData :int) (lpfnHook HANDLE) (lpTemplateName LPCSTR))
|
|
|
|
;; Windows functions
|
|
|
|
(defvar *wndproc-db* nil)
|
|
(defun register-wndproc (class-or-obj wndproc)
|
|
(let ((entry (assoc class-or-obj *wndproc-db* :test #'equal)))
|
|
(if entry
|
|
(rplacd entry wndproc)
|
|
(push (cons class-or-obj wndproc) *wndproc-db*)))
|
|
(unless (stringp class-or-obj)
|
|
(let ((old-proc (make-pointer (getwindowlong class-or-obj *GWL_WNDPROC*) 'HANDLE)))
|
|
(setwindowlong class-or-obj *GWL_WNDPROC* (make-lparam (callback 'wndproc-proxy)))
|
|
old-proc)))
|
|
(defun get-wndproc (obj)
|
|
(let ((entry (or (assoc obj *wndproc-db* :test #'equal)
|
|
(assoc (getclassname obj) *wndproc-db* :test #'equal))))
|
|
(and entry
|
|
(cdr entry))))
|
|
(defcallback (wndproc-proxy :stdcall) :int ((hnd :pointer-void) (umsg :unsigned-int) (wparam :unsigned-int) (lparam :int))
|
|
(let* ((wndproc (get-wndproc hnd)))
|
|
(unless wndproc
|
|
(error "Cannot find a registered Windows prodecure for object ~S" hnd))
|
|
(funcall wndproc hnd umsg wparam lparam)))
|
|
|
|
(defun make-ID (id) (make-pointer id :pointer-void))
|
|
(setf (symbol-function 'make-handle) #'make-ID)
|
|
(defun make-wparam (hnd) (pointer-address hnd))
|
|
(defun make-lparam (hnd) (pointer-address hnd))
|
|
(defmacro with-cast-int-pointer ((var type &optional ptr) &body body)
|
|
(unless ptr (setq ptr var))
|
|
`(let ((,var (make-pointer ,ptr ',type))) ,@body))
|
|
|
|
(defmacro def-win32-function (name args &key (returning :void) module)
|
|
`(def-function ,name ,args :returning ,returning :module ,module :call :stdcall))
|
|
(eval-when (:compile-toplevel)
|
|
(define-compiler-macro def-win32-function (name args &key (returning :void) module)
|
|
`(def-function ,name ,args :returning ,returning)))
|
|
(load-foreign-library "kernel32")
|
|
(load-foreign-library "comdlg32")
|
|
(load-foreign-library "gdi32")
|
|
(load-foreign-library "comctl32")
|
|
|
|
(def-win32-function ("RtlZeroMemory" zeromemory) ((Destination :pointer-void) (Length :unsigned-int)) :returning :void :module "kernel32")
|
|
(def-win32-function ("LoadLibraryA" loadlibrary) ((lpLibFileName LPCSTR)) :returning HANDLE :module "kernel32")
|
|
(def-win32-function ("FreeLibrary" freelibrary) ((hLibModule HANDLE)) :returning :int :module "kernel32")
|
|
(def-win32-function ("GetModuleHandleA" getmodulehandle) ((lpModuleName LPCSTR)) :returning HANDLE :module "kernel32")
|
|
(def-win32-function ("GetStockObject" getstockobject) ((fnObject :int)) :returning HANDLE :module "gdi32")
|
|
(def-win32-function ("GetTextMetricsA" gettextmetrics) ((hdc HANDLE) (lptm (* TEXTMETRIC))) :returning :int :module "gdi32")
|
|
(def-win32-function ("GetDC" getdc) ((hWnd HANDLE)) :returning HANDLE :module "user32")
|
|
(def-win32-function ("ReleaseDC" releasedc) ((hWnd HANDLE) (hdc HANDLE)) :returning :int :module "user32")
|
|
(def-win32-function ("SelectObject" selectobject) ((hdc HANDLE) (hgdiobj HANDLE)) :returning HANDLE :module "gdi32")
|
|
(def-win32-function ("GetTextExtentPoint32A" gettextextentpoint32) ((hdc HANDLE) (lpString :cstring) (cbString :int) (lpSize (* SIZE))) :returning :int :module "gdi32")
|
|
(def-win32-function ("LoadCursorA" loadcursor-string) ((hnd HANDLE) (lpCursorName LPCSTR)) :returning HANDLE :module "user32")
|
|
(def-win32-function ("LoadCursorA" loadcursor-int) ((hnd HANDLE) (lpCursorName :unsigned-int)) :returning HANDLE :module "user32")
|
|
(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-win32-function ("LoadIconA" loadicon-int) ((hnd HANDLE) (lpIconName :unsigned-int)) :returning HANDLE :module "user32")
|
|
(def-win32-function ("LoadIconA" loadicon-string) ((hnd HANDLE) (lpIconName LPCSTR)) :returning HANDLE :module "user32")
|
|
(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-win32-function ("GetLastError" getlasterror) () :returning :unsigned-int :module "kernel32")
|
|
(def-win32-function ("GetClassNameA" getclassname-i) ((hnd HANDLE) (lpClassName (* :char)) (maxCount :int)) :returning :int :module "user32")
|
|
(defun getclassname (hnd &aux (max-length 64))
|
|
(with-foreign-object (s `(:array :char ,max-length))
|
|
(let ((n (getclassname-i hnd s max-length)))
|
|
(when (= n 0)
|
|
(error "Unable to get class name for ~A" hnd))
|
|
(convert-from-foreign-string s :length n))))
|
|
(def-win32-function ("RegisterClassA" registerclass) ((lpWndClass (* WNDCLASS))) :returning :int :module "user32")
|
|
(def-win32-function ("UnregisterClassA" unregisterclass) ((lpClassName :cstring) (hInstance HANDLE)) :returning :int :module "user32")
|
|
(def-win32-function ("GetWindowLongA" getwindowlong) ((hWnd HANDLE) (nIndex :int)) :returning :long :module "user32")
|
|
(def-win32-function ("SetWindowLongA" setwindowlong) ((hWnd HANDLE) (nIndex :int) (dwNewLong :long)) :returning :long :module "user32")
|
|
(def-win32-function ("CreateWindowExA" 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 :module "user32")
|
|
(defun createwindow (&rest args)
|
|
(apply #'createwindowex 0 args))
|
|
(def-win32-function ("DestroyWindow" destroywindow) ((hWnd HANDLE)) :returning :int :module "user32")
|
|
(def-win32-function ("ShowWindow" showwindow) ((hWnd HANDLE) (nCmdShow :int)) :returning :int :module "user32")
|
|
(def-win32-function ("UpdateWindow" updatewindow) ((hWnd HANDLE)) :returning :void :module "user32")
|
|
(def-win32-function ("RedrawWindow" redrawwindow) ((hWnd HANDLE) (lprcUpdate (* RECT)) (hrgnUpdate HANDLE) (flags :unsigned-int)) :returning :int :module "user32")
|
|
(def-win32-function ("MoveWindow" movewindow) ((hWnd HANDLE) (x :int) (y :int) (nWidth :int) (nHeight :int) (bRepaint :int)) :returning :int :module "user32")
|
|
(def-win32-function ("SetWindowPos" setwindowpos) ((hWnd HANDLE) (hWndInsertAfter HANDLE) (x :int)
|
|
(y :int) (cx :int) (cy :int) (uFlags :unsigned-int)) :returning :int :module "user32")
|
|
(def-win32-function ("BringWindowToTop" bringwindowtotop) ((hWnd HANDLE)) :returning :int :module "user32")
|
|
(def-win32-function ("GetWindowTextA" getwindowtext-i) ((hWnd HANDLE) (lpString LPCSTR) (nMaxCount :int)) :returning :int :module "user32")
|
|
(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-win32-function ("GetWindowTextLengthA" getwindowtextlength) ((hWnd HANDLE)) :returning :int :module "user32")
|
|
(def-win32-function ("SetWindowTextA" setwindowtext) ((hWnd HANDLE) (lpString LPCSTR)) :returning :int :module "user32")
|
|
(def-win32-function ("GetParent" getparent) ((hWnd HANDLE)) :returning HANDLE :module "user32")
|
|
(def-win32-function ("GetClientRect" getclientrect) ((hWnd HANDLE) (lpRect (* RECT))) :returning :int :module "user32")
|
|
(def-win32-function ("GetWindowRect" getwindowrect) ((hWnd HANDLE) (lpRect (* RECT))) :returning :int :module "user32")
|
|
(def-win32-function ("InvalidateRect" invalidaterect) ((hWnd HANDLE) (lpRect (* RECT)) (bErase :int)) :returning :int :module "user32")
|
|
(def-win32-function ("SetRect" setrect) ((lpRect (* RECT)) (xLeft :int) (yTop :int) (xRight :int) (yBottom :int)) :returning :int :module "user32")
|
|
;(def-win32-function ("GetTitleBarInfo" gettitlebarinfo) ((hWnd HANDLE) (pti (* TITLEBARINFO))) :returning :int)
|
|
(def-win32-function ("SetFocus" setfocus) ((hWnd HANDLE)) :returning HANDLE :module "user32")
|
|
(def-win32-function ("PostQuitMessage" postquitmessage) ((nExitCode :int)) :returning :void :module "user32")
|
|
(def-win32-function ("SendMessageA" sendmessage) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32")
|
|
(def-win32-function ("PostMessageA" postmessage) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32")
|
|
(def-win32-function ("RegisterWindowMessageA" registerwindowmessage) ((lpString LPCSTR)) :returning :unsigned-int :module "user32")
|
|
(def-win32-function ("IsDialogMessageA" isdialogmessage) ((hDlg HANDLE) (lpMsg (* MSG))) :returning :int :module "user32")
|
|
(def-win32-function ("DefWindowProcA" defwindowproc) ((hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32")
|
|
(def-win32-function ("CallWindowProcA" callwindowproc) ((wndProc HANDLE) (hWnd HANDLE) (uMsg :unsigned-int) (wParam :unsigned-int) (lParam :int)) :returning :int :module "user32")
|
|
(defun loword (x) (logand x #xffff))
|
|
(defun hiword (x) (logand (floor x 65536) #xffff))
|
|
(defun get-x-lparam (x) (loword x))
|
|
(defun get-y-lparam (x) (hiword x))
|
|
(def-win32-function ("ScreenToClient" screentoclient) ((hWnd HANDLE) (pt (* POINT))) :returning :int :module "user32")
|
|
(def-win32-function ("MessageBoxA" messagebox) ((hWnd HANDLE) (lpText LPCSTR) (lpCaption LPCSTR) (uType :unsigned-int)) :returning :int :module "user32")
|
|
(def-win32-function ("GetOpenFileNameA" getopenfilename) ((lpofn (* OPENFILENAME))) :returning :int :module "comdlg32")
|
|
(def-win32-function ("GetSaveFileNameA" getsavefilename) ((lpofn (* OPENFILENAME))) :returning :int :module "comdlg32")
|
|
(def-win32-function ("FindTextA" findtext) ((lpfr (* FINDREPLACE))) :returning HANDLE :module "comdlg32")
|
|
(def-win32-function ("ReplaceTextA" replacetext) ((lpfr (* FINDREPLACE))) :returning HANDLE :module "comdlg32")
|
|
(def-win32-function ("GetMessageA" getmessage) ((lpMsg (* MSG)) (hWnd HANDLE) (wMsgFitlerMin :unsigned-int) (wMsgFilterMax :unsigned-int)) :returning :int :module "user32")
|
|
(def-win32-function ("TranslateMessage" translatemessage) ((lpMsg (* MSG))) :returning :int :module "user32")
|
|
(def-win32-function ("DispatchMessageA" dispatchmessage) ((lpMsg (* MSG))) :returning :int :module "user32")
|
|
(def-win32-function ("CreateMenu" createmenu) nil :returning HANDLE :module "user32")
|
|
(def-win32-function ("CreatePopupMenu" createpopupmenu) nil :returning HANDLE :module "user32")
|
|
(def-win32-function ("DestroyMenu" destroymenu) ((hMenu HANDLE)) :returning :int :module "user32")
|
|
(def-win32-function ("AppendMenuA" appendmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (uIDNewItem :unsigned-int) (lpNewItem LPCSTR)) :returning :int :module "user32")
|
|
(def-win32-function ("GetSubMenu" getsubmenu) ((hMenu HANDLE) (nPos :int)) :returning HANDLE :module "user32")
|
|
(def-win32-function ("DeleteMenu" deletemenu) ((hMenu HANDLE) (uPosition :unsigned-int) (uFlags :unsigned-int)) :returning :int :module "user32")
|
|
(def-win32-function ("RemoveMenu" removemenu) ((hMenu HANDLE) (uPosition :unsigned-int) (uFlags :unsigned-int)) :returning :int :module "user32")
|
|
(def-win32-function ("GetMenuItemCount" getmenuitemcount) ((hMenu HANDLE)) :returning :int :module "user32")
|
|
(def-win32-function ("CheckMenuItem" checkmenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int :module "user32")
|
|
(def-win32-function ("EnableMenuItem" enablemenuitem) ((hMenu HANDLE) (uIDCheckItem :unsigned-int) (uCheck :unsigned-int)) :returning :int :module "user32")
|
|
(def-win32-function ("TrackPopupMenu" trackpopupmenu) ((hMenu HANDLE) (uFlags :unsigned-int) (x :int) (y :int)
|
|
(nReserved :int) (hWnd HANDLE) (prcRect HANDLE)) :returning :int :module "user32")
|
|
(def-win32-function ("TrackPopupMenuEx" trackpopupmenuex) ((hMenu HANDLE) (fuFlags :unsigned-int) (x :int) (y :int)
|
|
(hWnd HANDLE) (lptpl (* TPMPARAMS))) :returning :int :module "user32")
|
|
(def-win32-function ("CreateAcceleratorTableA" createacceleratortable) ((lpaccl (* ACCEL)) (cEntries :int)) :returning HANDLE :module "user32")
|
|
(def-win32-function ("TranslateAcceleratorA" translateaccelerator) ((hWnd HANDLE) (hAccTable HANDLE) (lpMsg (* MSG))) :returning :int :module "user32")
|
|
(def-win32-function ("DestroyAcceleratorTable" destroyacceleratortable) ((hAccTable HANDLE)) :returning :int :module "user32")
|
|
(def-win32-function ("InitCommonControls" initcommoncontrols) () :returning :void :module "comctl32")
|
|
|
|
(defun event-loop (&key (accelTable *NULL*) (accelMain *NULL*) (dlgSym nil))
|
|
(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 (or (and (not (null-pointer-p accelTable))
|
|
(not (null-pointer-p accelMain))
|
|
(/= (translateaccelerator accelMain accelTable msg) 0))
|
|
(and dlgSym
|
|
(not (null-pointer-p (symbol-value dlgSym)))
|
|
(/= (isdialogmessage (symbol-value dlgSym) msg) 0))
|
|
(progn
|
|
(translatemessage msg)
|
|
(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-cstrings ((fn (make-string max-fn-size :initial-element #\Null))
|
|
(filter filter))
|
|
(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)))))))
|
|
|
|
(defun find-text (&key (owner *NULL*) &aux (max-txt-size 1024))
|
|
(with-foreign-object (fr 'FINDREPLACE)
|
|
(with-cstring (txt (make-string max-txt-size :initial-element #\Null))
|
|
(zeromemory fr (size-of-foreign-type 'FINDREPLACE))
|
|
(setf (get-slot-value fr 'FINDREPLACE 'lStructSize) (size-of-foreign-type 'FINDREPLACE))
|
|
(setf (get-slot-value fr 'FINDREPLACE 'hwndOwner) owner)
|
|
(setf (get-slot-value fr 'FINDREPLACE 'wFindWhatLen) max-txt-size)
|
|
;(setf (get-slot-value fr 'FINDREPLACE 'Flags) 1)
|
|
(let ((result (findtext fr)))
|
|
(print result)
|
|
txt))))
|
|
|
|
#|
|
|
(defun set-wndproc (obj fun)
|
|
(let ((cb (si:make-dynamic-callback fun (read-from-string (format nil "~A-WNDPROC" (gensym))) :int '(:pointer-void :unsigned-int :unsigned-int :int)))
|
|
(old-wndproc (make-pointer (getwindowlong obj *GWL_WNDPROC*) 'HANDLE)))
|
|
(setwindowlong obj *GWL_WNDPROC* (make-lparam cb))
|
|
old-wndproc))
|
|
|#
|
|
|
|
(provide "WIN32")
|
|
|
|
;;; 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*)
|
|
(setq hBtn nil hOk nil)
|
|
(postquitmessage 0)
|
|
0)
|
|
((= umsg *WM_CREATE*)
|
|
(setq hBtn (createwindowex 0 "BUTTON" "Hello World!" (logior *WS_VISIBLE* *WS_CHILD* *BS_PUSHBUTTON*)
|
|
0 0 50 20 hwnd (make-ID *HELLO_ID*) *NULL* *NULL*))
|
|
(setq hOk (createwindowex 0 "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)))|# 30))
|
|
(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!~%")
|
|
(get-open-filename :owner hwnd))
|
|
((= 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 (createwindowex
|
|
0
|
|
"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*)))
|
|
|