├── COPYRIGHT ├── NEWS ├── README ├── TODO ├── com ├── enumerations.lisp ├── errors.lisp ├── functions.lisp ├── interface-defs.lisp ├── interface.lisp ├── interfaces.lisp ├── object.lisp ├── package.lisp ├── structures.lisp ├── tests.lisp ├── unknown.lisp └── wrapper.lisp ├── doors.asd ├── doors.examples.asd ├── examples ├── com.lisp ├── helloworld.midl ├── helloworld.reg ├── helloworld.tlb └── packages.lisp ├── gdi ├── bitmaps.lisp ├── package.lisp └── rectangles.lisp ├── ole ├── interfaces.lisp └── package.lisp ├── security ├── authentication.lisp ├── authorization.lisp └── package.lisp ├── system ├── console.lisp ├── dlls.lisp ├── errors.lisp ├── features.lisp ├── guid.lisp ├── handles.lisp ├── hresult.lisp ├── libraries.lisp ├── memory.lisp ├── osversion.lisp ├── package.lisp ├── processes.lisp ├── psapi.lisp ├── registry.lisp ├── sysinfo.lisp ├── threads.lisp ├── time.lisp └── wintypes.lisp └── ui ├── configuration.lisp ├── input.lisp ├── nls.lisp ├── packages.lisp ├── window-classes.lisp ├── windows-aux.lisp └── windows.lisp /COPYRIGHT: -------------------------------------------------------------------------------- 1 | Copyright (C) 2010-2011, Dmitry Ignatiev 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, copy, 7 | modify, merge, publish, distribute, sublicense, and/or sell copies 8 | of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | DEALINGS IN THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- 1 | v0.4.3 2 | * bug fix: com-wrapper's methods are now specialized on particular 3 | wrapper class 4 | 5 | v0.4.2 6 | * new feature: COM-WRAPPER-CLASS and COM-WRAPPER classes 7 | ** COM-WRAPPER encapsulates particular com-object and 8 | all of its interfaces. It is roughly identical to 9 | .NET's "runtime callable wrapper". 10 | It calls CoCreateInstanceEx inside its SHARED-INITIALIZE 11 | method. 12 | ** COM-WRAPPER-CLASS is a metaclass for all COM-WRAPPERs. 13 | In addition to CLSID it holds all of the interface 14 | classes that particular com class implements. 15 | * :clsid initarg for COM-CLASSes now accepts a string. 16 | In this case, string is converted into CLSID by the mean of 17 | CLSID-FROM-STRING(i.e. "CLSIDFromString") function 18 | * Interface's translator(CONVERT-VALUE) now accepts 19 | COM-OBJECTs and COM-WRAPPERs 20 | 21 | v0.4.1 22 | * COM-CLASS now inherits from COM-OBJECT 23 | * REGISTER-CLASS-OBJECT function does not accept 24 | UNKNOWN parameter any more. An interface is acquired directly 25 | from the class metaobject 26 | 27 | v0.4.0 28 | * Hugely improved COM-related part of the library. 29 | ** FIND-INTERFACE-CLASS-BY-IID function has been removed. 30 | FIND-INTERFACE-CLASS function now accepts IID structures. 31 | ** New class: COM-CLASS. A metaclass for all COM-OBJECT's 32 | descendants that must be registrable by COM runtime. 33 | ** New function: FIND-COM-CLASS. This function is identical to 34 | FIND-INTERFACE-CLASS function except that is performs 35 | a lookup for COM-CLASS rather than for COM-INTERFACE-CLASS 36 | ** IID and CLSID types have been redefined to be interface and class 37 | designators respectively. Their translators now accept not only 38 | GUID structures but also interface/object classes and symbols 39 | which designate those classes(i.e. their names). 40 | ** COM interface methods' generic functions must now be of 41 | COM-GENERIC-FUNCTION class 42 | ** Added more COM-related constants, functions, structures 43 | and error codes 44 | ** Added CLASS-FACTORY(i.e. IClassFactory) interface 45 | * Notice that COM interop works only partially on SBCL: 46 | COM interfaces which are implemented by lisp-side COM-objects 47 | should not be passed into foreign code. 48 | SBCL does not support stdcall callbacks at the moment, so calling 49 | lisp interfaces from anywhere except lisp will likely cause 50 | stack corruption. 51 | * Added some examples of COM usage. 52 | * Added more bindings(e.g. system time stuff) 53 | * Some minor changes in DOORS package: 54 | ** OS-VERSION-INFO's constructor is now named MAKE-OS-VERSION-INFO 55 | ** Several error code constants were moved into DOORS.COM package 56 | ** WINDOWS-CONDITION's printer now uses FormatMessage for all 57 | system error codes 58 | 59 | v0.3.2 60 | * bug fix: The process of determining OS version was erroneous 61 | 62 | v0.3.1 63 | * bug fix: Fixed COM-OBJECT's RELEASE method 64 | 65 | v0.3.0 66 | * Fixed some misprints in src/console.lisp 67 | * PEB, TEB and associated structures were removed 68 | * Added PSAPI bindings 69 | 70 | v0.2.3 71 | * Fixed various bugs and misprints. Now the library could be compiled 72 | under Vista and Win7. 73 | 74 | v0.2.2 75 | * All struct constructors w/o parameters were replaced by constructors 76 | with keyword parameters, so the library could be built on CCL 77 | 78 | v0.2.1 79 | * All "-ex" suffixes were substituted by "*" suffixes. 80 | (i.e. LOAD-LIBRARY-EX was renamed LOAD-LIBRARY* and so on) 81 | This makes names more lispy. 82 | 83 | v0.2.0 84 | * UUID, CLSID, FMTID and IID types have been redefined as and aliases for 85 | GUID. Also, removed all related stuff, such as their accessors and so 86 | on. Use GUID stuff 87 | * CLSID and IID symbols now belong to DOORS.COM package 88 | * Names of external functions were lispified even more: 89 | ** Every function name that has a "Get" prefix is translated by 90 | removing that prefix 91 | ** Every function name that has a "Set" prefix is translated by 92 | removing that prefix and forming a (SETF name) function name 93 | ** For every function which name has a "Get" or "Set" prefix and which 94 | either has no parameters at all or all parameters of which are 95 | either optional or keyword there is also a corresponding 96 | symbol macro. 97 | ** Every function name that has a "Query" prefix and for which there 98 | exists a corresponding setter (a function which name begins with 99 | "Set") is translated as a name that has a "Get" prefix. 100 | Example: "GetConsoleMode" ==> CONSOLE-MODE 101 | "SetConsoleMode" ==> (SETF CONSOLE-MODE) 102 | + CONSOLE-MODE symbol macro 103 | * Most enums were converted to Virgil's strongly typed enums 104 | * Security stuff has been moved from #:DOORS package into #:DOORS.SECURITY 105 | package 106 | * Added "pascal string" type 107 | * Added more system stuff(handle, process and dll stuff) 108 | 109 | v0.1.1 110 | * bug fix: Fixed return value processing in READ-CONSOLE and 111 | READ-CONSOLE-INPUT functions 112 | 113 | v0.1.0 114 | * Bingings to console subsystem 115 | 116 | v0.0.3 117 | * Interface methods in interface definition can now refer to 118 | that interface type. 119 | 120 | v0.0.2 121 | * Fixed some bugs with interface reference counting 122 | 123 | v0.0.1 124 | * Initial release. 125 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Doors is a lisper's gateway to Windows. It aims to cover only essential 2 | features of that operating system, such as basic WinAPI, COM and OLE. 3 | 4 | Here's the list of dependencies in no particular order: 5 | * alexandria http://common-lisp.net/project/alexandria/ 6 | * trivial-features http://www.cliki.net/trivial-features 7 | * virgil http://github.com/Lovesan/virgil 8 | which, in turns, also depends on: 9 | ** cffi http://common-lisp.net/project/cffi/ 10 | ** babel http://common-lisp.net/project/babel/ 11 | * trivial-garbage http://www.cliki.net/trivial-garbage 12 | * bordeaux-threads http://common-lisp.net/project/bordeaux-threads/ 13 | * closer-mop http://common-lisp.net/project/closer/closer-mop.html 14 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | MORE FEATURES AND BINDINGS 2 | Development is just started... 3 | 4 | INTERFACE TO OLE AUTOMATION 5 | IDispatch and so on. 6 | 7 | TESTS 8 | Tests needed. 9 | 10 | DOCUMENTATION 11 | Although most of the documentation can be found on MSDN, we also 12 | need some. 13 | -------------------------------------------------------------------------------- /com/enumerations.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.com) 26 | 27 | (define-enum (com-rights 28 | (:base-type dword)) 29 | (:execute 1) 30 | (:execute-local 2) 31 | (:execute-remote 4) 32 | (:activate-local 8) 33 | (:activate-remote 16)) 34 | 35 | (define-enum (class-object-registration-flags 36 | (:base-type dword) 37 | (:conc-name regcls-) 38 | (:list t)) 39 | (:single-use 0) 40 | (:multiple-use 1) 41 | (:multi-separate 2) 42 | (:suspended 4) 43 | (:surrogate 8)) 44 | 45 | (define-enum (class-context-flags 46 | (:base-type dword) 47 | (:conc-name clsctx-) 48 | (:list t)) 49 | (:inproc-server #x1) 50 | (:inproc-handler #x2) 51 | (:inproc #x3) 52 | (:local-server #x4) 53 | (:remote-server #x10) 54 | (:server #x15) 55 | (:no-code-download #x400) 56 | (:no-custom-marshal #x1000) 57 | (:enable-code-download #x2000) 58 | (:no-failure-log #x4000) 59 | (:disable-aaa #x8000) 60 | (:enable-aaa #x10000) 61 | (:from-default-context #x20000) 62 | (:activate-32-bit-server #x40000) 63 | (:activate-64-bit-server #x80000) 64 | (:enable-cloaking #x100000) 65 | (:all #x17) 66 | (:ps-dll #x80000000)) 67 | 68 | (define-enum (com-init-flags 69 | (:base-type dword) 70 | (:list t) 71 | (:conc-name coinit-)) 72 | (:multithreaded 0) 73 | (:apartment-threaded 2) 74 | (:disable-ole1-dde 4) 75 | (:speed-over-memory 8)) 76 | 77 | (define-enum (bind-flags 78 | (:conc-name bind-) 79 | (:base-type dword) 80 | (:list t)) 81 | (:may-bother-user 1) 82 | (:just-test-existence 2)) 83 | 84 | (define-enum (stgm-flags 85 | (:base-type dword) 86 | (:conc-name stgm-)) 87 | (:read #x00000000) 88 | (:write #x00000001) 89 | (:read-write #x00000002) 90 | (:share-deny-none #x00000040) 91 | (:share-deny-read #x00000030) 92 | (:share-deny-write #x00000020) 93 | (:share-exclusive #x00000010) 94 | (:priority #x00040000) 95 | (:create #x00001000) 96 | (:convert #x00020000) 97 | (:fail-if-there #x00000000) 98 | (:direct #x00000000) 99 | (:transacted #x00010000) 100 | (:no-scratch #x00100000) 101 | (:no-snapshot #x00200000) 102 | (:simple #x08000000) 103 | (:direct-swmr #x00400000) 104 | (:delete-on-release #x04000000)) 105 | -------------------------------------------------------------------------------- /com/errors.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.com) 26 | 27 | (define-results com-error (windows-error) 28 | () 29 | ((not-implemented #x80004001 30 | "Not implemented") 31 | (no-interface #x80004002 32 | "No such interface supported") 33 | (invalid-pointer #x80004003 34 | "Invalid pointer") 35 | (abort #x80004004 36 | "Operation aborted") 37 | (failure #x80004005 38 | "Unspecified error") 39 | (data-pending #x8000000A 40 | "The data necessary to complete this operation is not yet available") 41 | (class-not-available #x8040111 42 | "ClassFactory cannot supply requested class") 43 | (class-not-registered #x80040154 44 | "Class not registered")) 45 | (:conc-name error-)) 46 | 47 | (defun com-error-code (error) 48 | (declare (type com-error error)) 49 | (slot-value error 'code)) 50 | -------------------------------------------------------------------------------- /com/functions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.com) 26 | 27 | (define-external-function 28 | ("CoRegisterClassObject" register-class-object) 29 | (:stdcall ole32) 30 | (hresult rv register) 31 | "Registers an EXE class object with OLE so other applications can connect to it." 32 | (clsid (& clsid)) 33 | (unknown unknown :aux (if (typep clsid 'com-class) 34 | clsid 35 | (find-com-class clsid))) 36 | (class-context class-context-flags :optional :server) 37 | (flags class-object-registration-flags :optional :multiple-use) 38 | (register (& dword :out) :aux)) 39 | 40 | (define-external-function 41 | ("CoRevokeClassObject" revoke-class-object) 42 | (:stdcall ole32) 43 | (hresult) 44 | "Informs OLE that a class object is no longer available for use." 45 | (register-token dword)) 46 | 47 | (define-external-function 48 | ("CoGetClassObject" class-object) 49 | (:stdcall ole32) 50 | (hresult rv (translate-interface 51 | (com-interface-pointer object) 52 | iid 53 | T)) 54 | "Provides a pointer to an interface on a class object associated with a specified CLSID. " 55 | (clsid (& clsid)) 56 | (context class-context-flags :optional :server) 57 | (server-info (& server-info :in t) :optional void) 58 | (iid (& iid)) 59 | (object (& unknown :out) :aux)) 60 | 61 | (define-external-function 62 | ("CoCreateInstance" create-com-instance) 63 | (:stdcall ole32) 64 | (hresult rv (translate-interface 65 | (com-interface-pointer object) 66 | iid 67 | t)) 68 | "Creates an instance of a specific class on a specific computer." 69 | (clsid (& clsid)) 70 | (aggregate-unknown unknown :optional) 71 | (context class-context-flags :optional :server) 72 | (iid (& iid)) 73 | (object (& unknown :out) :aux)) 74 | 75 | (define-external-function 76 | ("CoInitialize" initialize-com) 77 | (:stdcall ole32) 78 | (dword rv (handler-bind 79 | ((windows-status (lambda (c) 80 | (external-function-call 81 | "CoUninitialize" 82 | ((:stdcall ole32) 83 | (void))) 84 | (muffle-warning c)))) 85 | (translate rv 'hresult))) 86 | "Initializes the COM library on the current thread and identifies the concurrency model as single-thread apartment (STA)." 87 | (reserved pointer :aux &0)) 88 | 89 | (define-external-function 90 | ("CoUninitialize" uninitialize-com) 91 | (:stdcall ole32) 92 | (void rv (values)) 93 | "Closes the COM library on the current thread, unloads all DLLs loaded by the thread, frees any other resources that the thread maintains, and forces all RPC connections on the thread to close. ") 94 | 95 | (define-external-function 96 | ("CoTaskMemAlloc" task-mem-alloc) 97 | (:stdcall ole32) 98 | (pointer rv (if (or (&? rv) (zerop size)) 99 | rv 100 | (error 'windows-error :code error-out-of-memory))) 101 | "Allocates a block of task memory." 102 | (size size-t)) 103 | 104 | (define-external-function 105 | ("CoTaskMemFree" task-mem-free) 106 | (:stdcall ole32) 107 | (void) 108 | "Frees a block of task memory." 109 | (pointer pointer)) 110 | 111 | (define-external-function 112 | ("CoTaskMemRealloc" task-mem-realloc) 113 | (:stdcall ole32) 114 | (pointer rv (if (or (&? rv) (zerop size)) 115 | rv 116 | (error 'windows-error :code error-out-of-memory))) 117 | "Changes the size of a previously allocated block of task memory." 118 | (pointer pointer :optional &0) 119 | (size size-t)) 120 | 121 | (define-external-function 122 | ("StringFromIID" string-from-iid) 123 | (:stdcall ole32) 124 | (hresult rv (prog1 125 | (translate lpsz '(& wstring)) 126 | (task-mem-free lpsz))) 127 | "Converts an interface identifier into a string of printable characters." 128 | (iid (& iid)) 129 | (lpsz (& pointer :out) :aux)) 130 | 131 | (define-external-function 132 | ("IIDFromString" iid-from-string) 133 | (:stdcall ole32) 134 | (hresult rv iid) 135 | "Converts a string generated by the STRING-FROM-IID function back into the original interface identifier (IID)." 136 | (string (& wstring)) 137 | (iid (& iid :out) :aux)) 138 | 139 | (define-external-function 140 | ("CoInitializeEx" initialize-com*) 141 | (:stdcall ole32) 142 | (dword rv (handler-bind 143 | ((windows-status (lambda (c) 144 | (external-function-call 145 | "CoUninitialize" 146 | ((:stdcall ole32) 147 | (void))) 148 | (muffle-warning c)))) 149 | (translate rv 'hresult))) 150 | "Initializes the COM library for use by the calling thread, sets the thread's concurrency model, and creates a new apartment for the thread if one is required." 151 | (reserved pointer :aux &0) 152 | (flags com-init-flags :optional)) 153 | 154 | (define-external-function 155 | ("CoGetObject" com-object) 156 | (:stdcall ole32) 157 | (hresult rv (translate-interface 158 | (com-interface-pointer object) 159 | iid 160 | t)) 161 | "Converts a display name into a moniker that identifies the object named, and then binds to the object identified by the moniker." 162 | (name (& wstring)) 163 | (bind-options (& bind-options :in t) :optional) 164 | (iid (& iid)) 165 | (object (& unknown :out) :aux)) 166 | 167 | (define-external-function 168 | ("CLSIDFromProgID" clsid-from-progid) 169 | (:stdcall ole32) 170 | (hresult rv clsid) 171 | "Looks up a CLSID in the registry, given a ProgID." 172 | (progid (& wstring)) 173 | (clsid (& clsid :out) :aux)) 174 | 175 | (define-external-function 176 | ("CLSIDFromProgIDEx" clsid-from-progid*) 177 | (:stdcall ole32) 178 | (hresult rv clsid) 179 | "Triggers automatic installation if the COMClassStore policy is enabled." 180 | (progid (& wstring)) 181 | (clsid (& clsid :out) :aux)) 182 | 183 | (define-external-function 184 | ("CLSIDFromString" clsid-from-string) 185 | (:stdcall ole32) 186 | (hresult rv clsid) 187 | "Converts a string generated by the string-from-clsid function back into the original CLSID. " 188 | (progid (& wstring)) 189 | (clsid (& clsid :out) :aux)) 190 | 191 | (define-external-function 192 | ("StringFromCLSID" string-from-clsid) 193 | (:stdcall ole32) 194 | (hresult rv (prog1 195 | (translate lpsz '(& wstring)) 196 | (task-mem-free lpsz))) 197 | "Converts a CLSID into a string of printable characters." 198 | (clsid (& clsid)) 199 | (lpsz (& pointer :out) :aux)) 200 | 201 | (define-external-function 202 | ("ProgIDFromCLSID" progid-from-clsid) 203 | (:stdcall ole32) 204 | (hresult rv (prog1 205 | (translate lpsz '(& wstring)) 206 | (task-mem-free lpsz))) 207 | "Retrieves the ProgID for a given CLSID. " 208 | (clsid (& clsid)) 209 | (lpsz (& pointer :out) :aux)) 210 | 211 | (define-external-function 212 | ("StringFromGUID2" string-from-guid) 213 | (:stdcall ole32) 214 | ((last-error int doors::not-zero) rv buffer) 215 | "Converts a globally unique identifier (GUID) into a string of printable characters. " 216 | (guid (& guid)) 217 | (buffer (& (~ wchar nil simple-string) :out) 218 | :aux (make-string 38 :initial-element #\space)) 219 | (max int :aux 39)) 220 | 221 | (define-external-function 222 | ("CoCreateInstanceEx" create-com-instance*) 223 | (:stdcall ole32) 224 | (hresult rv results) 225 | "Creates an instance of a specific class on a specific computer." 226 | (clsid (& clsid)) 227 | (outer unknown :key) 228 | (context class-context-flags :key :server) 229 | (server-info (& server-info :in t) :key) 230 | (count dword :key (array-total-size results)) 231 | (results (& (simple-array multi-qi) :inout))) 232 | 233 | (define-external-function 234 | ("CoAddRefServerProcess" add-ref-server-process) 235 | (:stdcall ole32) 236 | (ulong) 237 | "Increments a global per-process reference count") 238 | 239 | (define-external-function 240 | ("CoReleaseServerProcess" release-server-process) 241 | (:stdcall ole32) 242 | (ulong) 243 | "Decrements the global per-process reference count.") 244 | 245 | (define-external-function 246 | ("CoResumeClassObjects" resume-class-objects) 247 | (:stdcall ole32) 248 | (hresult) 249 | "Called by a server that can register multiple class objects to inform the SCM about all registered classes, and permits activation requests for those class objects.") 250 | 251 | (define-external-function 252 | ("CoSuspendClassObjects" suspend-class-objects) 253 | (:stdcall ole32) 254 | (hresult) 255 | "Prevents any new activation requests from the SCM on all class objects registered within the process.") 256 | -------------------------------------------------------------------------------- /com/interfaces.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.com) 26 | 27 | (define-interface class-factory 28 | ((iid-class-factory "{00000001-0000-0000-C000-000000000046}") 29 | unknown) 30 | "Enables a class of objects to be created." 31 | (create-instance 32 | (hresult rv (translate-interface 33 | (com-interface-pointer object) 34 | iid 35 | t)) 36 | "Creates an uninitialized object." 37 | (outer unknown :optional) 38 | (iid (& iid)) 39 | (object (& unknown :out) :aux)) 40 | (lock-server 41 | (hresult) 42 | "Locks an object application open in memory." 43 | (lock bool))) 44 | -------------------------------------------------------------------------------- /com/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:cl-user) 26 | 27 | (defpackage #:doors.com 28 | (:use #:cl #:alexandria #:trivial-garbage #:virgil #:doors) 29 | (:nicknames #:com) 30 | (:export 31 | 32 | #:iid 33 | #:clsid 34 | 35 | ;;errors 36 | #:com-error 37 | #:com-error-code 38 | 39 | #:error-not-implemented 40 | #:error-no-interface 41 | #:error-invalid-pointer 42 | #:error-abort 43 | #:error-failure 44 | #:error-data-pending 45 | #:error-class-not-available 46 | #:error-class-not-registered 47 | 48 | #:error-unexpected-failure 49 | #:error-not-implemented 50 | 51 | ;;com-interface related stuff 52 | #:com-interface-class 53 | #:com-interface 54 | #:com-generic-function 55 | #:find-interface-class 56 | #:com-interface-pointer 57 | #:com-interface-method-pointer 58 | #:translate-interface 59 | #:convert-interface 60 | #:define-interface 61 | #:define-interface-method 62 | 63 | ;;com-object related stuff 64 | #:com-class 65 | #:com-object 66 | #:find-com-class 67 | #:acquire-interface 68 | #:deinitialize-vtables 69 | #:reinitialize-vtables 70 | 71 | ;;IUnknown 72 | #:iid-unknown 73 | #:unknown 74 | #:query-interface 75 | #:add-ref 76 | #:release 77 | 78 | #:with-interface 79 | #:with-interfaces 80 | 81 | ;;enumerations 82 | #:com-rights 83 | #:com-rights-execute 84 | #:com-rights-execute-local 85 | #:com-rights-execute-remote 86 | #:com-rights-activate-local 87 | #:com-rights-activate-remote 88 | #:class-object-registration-flags 89 | #:regcls-single-use 90 | #:regcls-miltiple-use 91 | #:regcls-multi-separate 92 | #:regcls-suspended 93 | #:regcls-surrogate 94 | #:class-context-flags 95 | #:clsctx-inproc-server 96 | #:clsctx-inproc-handler 97 | #:clsctx-inproc 98 | #:clsctx-local-server 99 | #:clsctx-remote-server 100 | #:clsctx-no-code-download 101 | #:clsctx-no-custom-marshal 102 | #:clsctx-enable-code-download 103 | #:clsctx-no-failure-log 104 | #:clsctx-disable-aaa 105 | #:clsctx-enable-aaa 106 | #:clsctx-form-default-context 107 | #:clsctx-activate-32-bit-server 108 | #:clsctx-activate-64-bit-server 109 | #:clsctx-enable-cloaking 110 | #:clsctx-all 111 | #:clsctx-server 112 | #:clsctx-ps-dll 113 | #:com-init-flags 114 | #:coinit-multithreaded 115 | #:coinit-apartament-threaded 116 | #:coinit-disable-ole1-dde 117 | #:coinit-speed-over-memory 118 | #:bind-flags 119 | #:bind-may-bother-user 120 | #:bind-just-test-existence 121 | #:stgm-flags 122 | #:stgm-read 123 | #:stgm-write 124 | #:stgm-read-wrie 125 | #:stgm-share-deny-none 126 | #:stgm-share-deny-read 127 | #:stgm-share-deny-write 128 | #:stgm-share-exclusive 129 | #:stgm-priority 130 | #:stgm-create 131 | #:stgm-convert 132 | #:stgm-fail-if-there 133 | #:stgm-direct 134 | #:stgm-transacted 135 | #:stgm-no-scratch 136 | #:stgm-no-snapshot 137 | #:stgm-simple 138 | #:stgm-direct-swmr 139 | #:stgm-delete-on-release 140 | 141 | ;;structures 142 | #:server-info 143 | #:make-server-info 144 | #:server-info-name 145 | #:server-info-auth-info 146 | #:auth-info 147 | #:make-auth-info 148 | #:auth-info-authn-svc 149 | #:auth-info-authz-svc 150 | #:auth-info-server-principal-name 151 | #:auth-info-auth-level 152 | #:auth-info-impersonation-level 153 | #:auth-info-auth-identity-data 154 | #:auth-info-capabilities 155 | #:bind-options 156 | #:make-bind-options 157 | #:bind-opt-flags 158 | #:bind-opt-mode 159 | #:bind-opt-tick-count-deadline 160 | #:multi-qi 161 | #:make-multi-qi 162 | #:multi-qi-iid 163 | #:multi-qi-interface 164 | #:multi-qi-hresult 165 | 166 | ;;interfaces 167 | #:class-factory 168 | #:iid-class-factory 169 | #:create-instance 170 | #:lock-server 171 | 172 | ;;functions 173 | #:register-class-object 174 | #:revoke-class-object 175 | #:class-object 176 | #:create-com-instance 177 | #:initialize-com 178 | #:uninitialize-com 179 | #:task-mem-alloc 180 | #:task-mem-realloc 181 | #:task-mem-free 182 | #:string-from-iid 183 | #:iid-from-string 184 | #:initialize-com* 185 | #:clsid-from-progid 186 | #:clsid-from-progid* 187 | #:clsid-from-string 188 | #:string-from-clsid 189 | #:progid-from-clsid 190 | #:string-from-guid 191 | #:create-com-instance* 192 | #:add-ref-server-process 193 | #:release-server-process 194 | #:suspend-class-objects 195 | #:resume-class-objects 196 | 197 | ;;wrapper stuff 198 | #:com-wrapper-class 199 | #:com-wrapper 200 | #:com-wrapper-context 201 | #:com-wrapper-server-info 202 | )) 203 | -------------------------------------------------------------------------------- /com/structures.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.com) 26 | 27 | (define-struct (auth-info) 28 | "Contains the authentication settings used while making a remote activation request." 29 | (authn-svc (enum (:base-type dword) 30 | (:none 0) 31 | (:dce-private 1) 32 | (:dce-public 2) 33 | (:dec-public 4) 34 | (:gss-negotiate 9) 35 | (:winnt 10) 36 | (:gss-schannell 14) 37 | (:gss-kerberos 16) 38 | (:dpa 17) 39 | (:msn 18) 40 | (:kernel 20) 41 | (:digest 21) 42 | (:nego-extender 30) 43 | (:pku2u 31) 44 | (:mq 100) 45 | (:default #xffffffff))) 46 | (authz-svc (enum (:base-type dword) 47 | :none 48 | :name 49 | :dce 50 | (:default #xFFFFFFFF))) 51 | (server-principal-name (& wstring)) 52 | (authn-level (enum (:base-type dword) 53 | (:default 0) 54 | (:none 1) 55 | (:connect 2) 56 | (:call 3) 57 | (:level-pkt 4) 58 | (:pkt-integrity 5) 59 | (:pkt-privacy 6))) 60 | (impersonation-level (enum (:base-type dword) 61 | (:default 0) 62 | (:anonymous 1) 63 | (:identity 2) 64 | (:impersonate 3) 65 | (:delegate 4))) 66 | (auth-identity-data pointer) 67 | (capabilities (enum (:base-type dword) 68 | :none 69 | :mutual-auth))) 70 | 71 | (define-struct (server-info 72 | (:constructor make-server-info (&key name auth-info))) 73 | "Identifies a remote computer resource to the activation functions. " 74 | (reserved1 dword) 75 | (name (& wstring)) 76 | (auth-info (& auth-info :in t)) 77 | (reserved2 dword)) 78 | 79 | (define-struct (bind-options 80 | (:conc-name bind-opt-) 81 | (:constructor make-bind-options 82 | (&key flags mode tick-count-deadline))) 83 | "Contains parameters used during a moniker-binding operation." 84 | (cb dword :initform (sizeof 'bind-options)) 85 | (flags bind-flags) 86 | (mode stgm-flags) 87 | (tick-count-deadline dword)) 88 | 89 | (define-struct (multi-qi 90 | (:reader %mqi-reader)) 91 | "Represents an interface in a query for multiple interfaces." 92 | (iid (& (const iid))) 93 | (interface (unknown t)) 94 | (hresult hresult)) 95 | 96 | (defun %mqi-reader (pointer out) 97 | (declare (type pointer pointer)) 98 | (let* ((out (or out (make-multi-qi))) 99 | (iid (deref pointer 'iid)) 100 | (unk (deref pointer 'unknown (offsetof 'multi-qi 'interface))) 101 | (hresult (handler-case 102 | (deref pointer 'hresult (offsetof 'multi-qi 'hresult)) 103 | (windows-condition (c) c)))) 104 | (declare (type multi-qi out) 105 | (type unknown unk) 106 | (type hresult hresult) 107 | (type iid iid)) 108 | (unless (null unk) 109 | (setf unk (translate-interface 110 | (com-interface-pointer unk) 111 | iid 112 | t))) 113 | (setf (multi-qi-iid out) iid 114 | (multi-qi-interface out) unk 115 | (multi-qi-hresult out) hresult) 116 | out)) 117 | -------------------------------------------------------------------------------- /com/tests.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.com) 26 | 27 | (defalias float4 () '(simple-array float (4))) 28 | (defun float4 (x y z w) 29 | (make-array 4 :element-type 'single 30 | :initial-contents (list x y z w))) 31 | 32 | (define-interface vector-adder () 33 | (add-vectors (void rv out) 34 | (out (& float4 :inout) :optional) 35 | (a (& float4)) 36 | (b (& float4)))) 37 | 38 | (defclass vector-adder-object (com-object) 39 | ()) 40 | 41 | (defmethod add-vectors ((object vector-adder-object) a b 42 | &optional (out (float4 0.0 0.0 0.0 0.0))) 43 | (values void (map-into out #'+ a b) a b)) 44 | 45 | (defun vector-adder-test () 46 | (let* ((object (make-instance 'vector-adder-object)) 47 | (interface (acquire-interface object 'vector-adder t)) 48 | (v1 (float4 1.0 2.0 3.0 4.0)) 49 | (v2 (float4 5.0 6.0 7.0 8.0))) 50 | (finalize interface (lambda () 51 | (write-line "ADDER interface disposing" 52 | *error-output*))) 53 | (finalize object (lambda () 54 | (write-line "ADDER-OBJECT object disposing" 55 | *error-output*))) 56 | (add-vectors interface v1 v2 v1) 57 | (every (complement #'null) 58 | (map 'vector #'= 59 | (add-vectors interface v1 v2) 60 | #(11.0 14.0 17.0 20.0))))) 61 | 62 | (define-guid iid-stack 63 | #xCAFEBABE #xF001 #xBABE 0 0 0 0 #x0B #xAD #xF0 #x0D) 64 | 65 | (define-interface stack (iid-stack unknown) 66 | (stack-push (void) (value int)) 67 | (stack-pop (hresult rv value) (value (& int :out) :aux))) 68 | 69 | (defclass stack-object (com-object) 70 | ((stack :initform '() 71 | :accessor stack-object-stack))) 72 | 73 | (defmethod stack-push ((object stack-object) value) 74 | (push value (stack-object-stack object)) 75 | (values void value)) 76 | 77 | (defmethod stack-pop ((object stack-object)) 78 | (if (endp (stack-object-stack object)) 79 | (error 'windows-error :code error-failure) 80 | (values nil (pop (stack-object-stack object))))) 81 | 82 | (defun stack-test () 83 | (let* ((object (make-instance 'stack-object))) 84 | (with-interfaces ((unknown (acquire-interface object 'unknown)) 85 | (stack (query-interface unknown iid-stack))) 86 | (add-ref stack) 87 | (finalize stack (lambda () 88 | (write-line "STACK interface disposing" 89 | *error-output*))) 90 | (finalize object (lambda () 91 | (write-line "STACK-OBJECT object disposing" 92 | *error-output*))) 93 | (stack-push stack 123) 94 | (and (eql 123 (stack-pop stack)) 95 | (handler-case 96 | (progn (stack-pop stack) nil) 97 | (error (error) 98 | (and (typep error 'windows-error) 99 | (= (windows-error-code error) 100 | error-failure)))))))) 101 | -------------------------------------------------------------------------------- /com/unknown.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.com) 26 | 27 | (define-interface unknown 28 | ((iid-unknown "{00000000-0000-0000-C000-000000000046}")) 29 | "Lisp wrapper for IUnknown interface" 30 | (query-interface 31 | ((hresult com-error) rv 32 | (translate-interface interface iid T)) 33 | (iid (& iid)) 34 | (interface (& pointer :out) :aux)) 35 | (add-ref (ulong)) 36 | (release (ulong))) 37 | 38 | (closer-mop:defmethod add-ref :around ((object unknown)) 39 | (let ((token (%com-interface-token object))) 40 | (unless (cdr token) 41 | (call-next-method) 42 | (setf (cdr token) (%add-to-git (com-interface-pointer object)))) 43 | 1)) 44 | 45 | (closer-mop:defmethod release :around ((object unknown)) 46 | (let ((token (%com-interface-token object))) 47 | (when (cdr token) 48 | (%revoke-from-git (cdr token)) 49 | (setf (cdr token) nil)) 50 | 0)) 51 | 52 | (closer-mop:defmethod shared-initialize :after 53 | ((object unknown) slot-names &rest initargs &key &allow-other-keys) 54 | (declare (ignore slot-names initargs)) 55 | (let* ((token (%com-interface-token object)) 56 | (finalizer (lambda (token) 57 | (declare (type cons token)) 58 | (when (cdr token) 59 | (%revoke-from-git (cdr token)) 60 | (setf (cdr token) nil))))) 61 | (declare (type function finalizer) 62 | (type cons token)) 63 | (setf (car token) t) 64 | (finalize object (lambda () 65 | #+thread-support 66 | (bt:with-lock-held (*mta-post-mortem-lock*) 67 | (push (list finalizer token) *mta-post-mortem-queue*) 68 | (bt:condition-notify *mta-post-mortem-condvar*)) 69 | #-thread-support 70 | (funcall finalizer token))))) 71 | 72 | (defmacro with-interface ((var interface) &body body) 73 | `(let ((,var ,interface)) 74 | (unwind-protect 75 | (locally ,@body) 76 | (release ,var)))) 77 | 78 | (defmacro with-interfaces ((&rest specs) &body body) 79 | (if (null specs) 80 | `(locally ,@body) 81 | `(with-interface ,(car specs) 82 | (with-interfaces ,(rest specs) 83 | ,@body)))) 84 | -------------------------------------------------------------------------------- /com/wrapper.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.com) 26 | 27 | (closer-mop:defclass com-wrapper-class (com-class) 28 | ()) 29 | 30 | (closer-mop:defmethod closer-mop:validate-superclass 31 | ((class com-wrapper-class) (superclass com-wrapper-class)) 32 | nil) 33 | 34 | (closer-mop:defmethod shared-initialize :around ((class com-wrapper-class) slot-names &rest initargs 35 | &key direct-superclasses &allow-other-keys) 36 | (remf initargs :direct-superclasses) 37 | (let ((direct-superclasses (if (find-if (lambda (superclass) 38 | (subtypep (class-name superclass) 'com-wrapper)) 39 | direct-superclasses) 40 | direct-superclasses 41 | (append direct-superclasses (list (find-class 'com-wrapper)))))) 42 | (apply #'call-next-method 43 | class 44 | slot-names 45 | :direct-superclasses direct-superclasses 46 | initargs))) 47 | 48 | (closer-mop:defmethod shared-initialize :after 49 | ((class com-wrapper-class) slot-names &rest initargs 50 | &key interfaces &allow-other-keys) 51 | (declare (ignore slot-names initargs)) 52 | (let ((interfaces (mapcar (lambda (interface-class) 53 | (unless (typep interface-class 54 | 'com-interface-class) 55 | (setf interface-class 56 | (find-interface-class interface-class))) 57 | (assert (guidp (uuid-of interface-class)) 58 | (interface-class) 59 | "Interface class' IID is invalid") 60 | (maphash 61 | (lambda (name fspec &aux (gf (fdefinition name))) 62 | (destructuring-bind 63 | (function . primary) fspec 64 | (add-method 65 | gf 66 | (make-instance 'closer-mop:standard-method 67 | :lambda-list 68 | (closer-mop:generic-function-lambda-list gf) 69 | :specializers 70 | (if (consp name) 71 | (list* (find-class t) 72 | class 73 | (mapcar (constantly (find-class t)) 74 | (cdr primary))) 75 | (list* class (mapcar (constantly (find-class t)) 76 | primary))) 77 | :function function)))) 78 | (%interface-class-wrapper-functions 79 | interface-class)) 80 | interface-class) 81 | (remove-duplicates (cons (find-class 'unknown) interfaces))))) 82 | (setf (slot-value class '%interfaces) interfaces))) 83 | 84 | (closer-mop:defmethod shared-initialize :after 85 | ((object com-wrapper) slot-names &rest initargs 86 | &key context server-info &allow-other-keys) 87 | (declare (ignore slot-names initargs)) 88 | (check-type server-info (or null void server-info)) 89 | (unless server-info (setf server-info void)) 90 | (let* ((context (convert context 'class-context-flags)) 91 | (class (let ((class (class-of object))) 92 | (assert (typep class 'com-wrapper-class) () 93 | 'type-error :datum class :expected-type 'com-wrapper-class) 94 | class)) 95 | (unknown-class (find-class 'unknown)) 96 | (unknown (with-pointer (pmqi (make-multi-qi :iid unknown-class) 97 | 'multi-qi) 98 | (external-function-call 99 | "CoCreateInstanceEx" 100 | ((:stdcall ole32) 101 | (hresult rv) 102 | ((& clsid) clsid :aux class) 103 | (pointer aggregate :aux &0) 104 | (dword ctx :aux context) 105 | ((& server-info :in t) sinfo :aux server-info) 106 | (dword count :aux 1) 107 | (pointer results :aux pmqi))) 108 | (deref pmqi 'hresult (offsetof 'multi-qi 'hresult)) 109 | (deref pmqi 'pointer (offsetof 'multi-qi 'interface)))) 110 | (unknown-cookie (%add-to-git unknown)) 111 | (interfaces (setf (%wrapper-interface-pointers object) 112 | (make-hash-table :test #'eq))) 113 | (interface-cookies (make-hash-table :test #'eq)) 114 | (token (%com-wrapper-token object)) 115 | (finalizer (lambda (token) 116 | (declare (type cons token)) 117 | (destructuring-bind 118 | (unknown-cookie . interface-cookies) token 119 | (when unknown-cookie 120 | (%revoke-from-git unknown-cookie) 121 | (setf (car token) nil)) 122 | (when interface-cookies 123 | (loop :for cookie :of-type dword :being :the :hash-values 124 | :of interface-cookies 125 | :do (%revoke-from-git cookie)) 126 | (setf (cdr token) nil)))))) 127 | (declare (type pointer unknown) 128 | (type cons token) 129 | (type dword unknown-cookie) 130 | (type function finalizer) 131 | (type hash-table interfaces interface-cookies)) 132 | (setf (car token) unknown-cookie 133 | (cdr token) interface-cookies) 134 | (finalize object (lambda () 135 | #+thread-support 136 | (bt:with-lock-held (*mta-post-mortem-lock*) 137 | (push (list finalizer token) 138 | *mta-post-mortem-queue*) 139 | (bt:condition-notify *mta-post-mortem-condvar*)) 140 | #-thread-support 141 | (funcall finalizer token))) 142 | (setf (gethash 'unknown interfaces) unknown) 143 | (dolist (interface-class (remove unknown-class (slot-value class '%interfaces))) 144 | (let ((interface (external-pointer-call 145 | (deref (deref unknown '*) '*) 146 | ((:stdcall) 147 | (hresult rv ptr) 148 | (pointer this :aux unknown) 149 | ((& iid) iid :aux interface-class) 150 | ((& pointer :out) ptr :aux &0))))) 151 | (setf (gethash (class-name interface-class) interfaces) 152 | interface 153 | (gethash (class-name interface-class) interface-cookies) 154 | (%add-to-git interface)))))) 155 | 156 | (closer-mop:defmethod add-ref :around ((object com-wrapper)) 157 | (if (car (the cons (%com-wrapper-token object))) 158 | 1 159 | 0)) 160 | 161 | (closer-mop:defmethod release :around ((object com-wrapper)) 162 | (let ((token (the cons (%com-wrapper-token object)))) 163 | (destructuring-bind 164 | (unknown-cookie . interface-cookies) token 165 | (when unknown-cookie 166 | (%revoke-from-git unknown-cookie) 167 | (setf (car token) nil)) 168 | (when interface-cookies 169 | (loop :for cookie :of-type dword :being :the :hash-values 170 | :of interface-cookies 171 | :do (%revoke-from-git cookie)) 172 | (setf (cdr token) nil)))) 173 | 0) 174 | -------------------------------------------------------------------------------- /doors.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE. 24 | 25 | (asdf:defsystem #:doors 26 | :version "0.4.3" 27 | :description "Doors, a lisper's gateway to Windows" 28 | :author "Dmitry Ignatiev " 29 | :maintainer "Dmitry Ignatiev " 30 | :licence "MIT" 31 | :depends-on (#:trivial-features #:alexandria #:virgil #:trivial-garbage #:closer-mop #:bordeaux-threads) 32 | :serial t 33 | :components ((:module "system" 34 | :serial t 35 | :components ((:file "package") 36 | (:file "libraries") 37 | (:file "features") 38 | (:file "wintypes") 39 | (:file "osversion") 40 | (:file "hresult") 41 | (:file "errors") 42 | (:file "guid") 43 | (:file "handles") 44 | (:file "dlls") 45 | (:file "time") 46 | (:file "sysinfo") 47 | )) 48 | (:module "com" 49 | :serial t 50 | :components ((:file "package") 51 | (:file "errors") 52 | (:file "interface") 53 | (:file "interface-defs") 54 | (:file "object") 55 | (:file "unknown") 56 | )) 57 | (:module "security" 58 | :serial t 59 | :components ((:file "package") 60 | (:file "authentication") 61 | (:file "authorization") 62 | )) 63 | (:module "system-aux" 64 | :pathname "system" 65 | :serial t 66 | :components ((:file "console") 67 | (:file "registry") 68 | (:file "memory") 69 | (:file "processes") 70 | (:file "psapi") 71 | (:file "threads") 72 | )) 73 | (:module "com-aux" 74 | :pathname "com" 75 | :serial t 76 | :components ((:file "enumerations") 77 | (:file "structures") 78 | (:file "interfaces") 79 | (:file "functions") 80 | (:file "wrapper"))) 81 | 82 | (:module "gdi" 83 | :serial t 84 | :components ((:file "package") 85 | (:file "rectangles") 86 | (:file "bitmaps") 87 | )) 88 | (:module "ui" 89 | :serial t 90 | :components ((:file "packages") 91 | (:file "window-classes") 92 | (:file "windows") 93 | (:file "input") 94 | (:file "windows-aux") 95 | (:file "configuration") 96 | )) 97 | )) 98 | 99 | ;; vim: ft=lisp et 100 | -------------------------------------------------------------------------------- /doors.examples.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (defsystem #:doors.examples 26 | :author "Dmitry Ignatiev " 27 | :maintainer "Dmitry Ignatiev " 28 | :licence "MIT" 29 | :depends-on (#:doors #:virgil #:alexandria) 30 | :serial t 31 | :components ((:module "examples" 32 | :serial t 33 | :components ((:file "packages") 34 | (:file "com") 35 | )))) 36 | 37 | ;; vim: ft=lisp et 38 | -------------------------------------------------------------------------------- /examples/com.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.com.examples) 26 | 27 | (closer-mop:defclass factory-class (com-class) 28 | ((server-atom :initform nil)) 29 | (:interfaces class-factory) 30 | (:metaclass com-class)) 31 | 32 | (closer-mop:defmethod create-instance ((class factory-class) iid &optional outer) 33 | (if outer 34 | (error 'com-error :code error-not-implemented) 35 | (let ((object (make-instance class))) 36 | (values nil outer iid (acquire-interface object iid))))) 37 | 38 | (closer-mop:defmethod lock-server ((class factory-class) lock) 39 | (if lock 40 | (add-ref-server-process) 41 | (when (zerop (release-server-process)) 42 | (post-quit-message))) 43 | (values nil lock)) 44 | 45 | (define-interface hello-world 46 | ("{F9210244-38D1-49C0-A848-684EDD3DBFF0}" unknown) 47 | (hello-world (hresult) 48 | (string (& wstring) :optional "Hello, world!"))) 49 | 50 | (closer-mop:defclass hello-world-object (com-object) 51 | () 52 | (:metaclass factory-class) 53 | (:interfaces hello-world) 54 | (:clsid . "{DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF}")) 55 | 56 | (closer-mop:defmethod hello-world ((object hello-world-object) 57 | &optional (string "Hello, world!")) 58 | (write-line string) 59 | (values nil string)) 60 | 61 | (defmethod add-ref :after ((object hello-world-object)) 62 | (add-ref-server-process)) 63 | 64 | (defmethod release :after ((object hello-world-object)) 65 | (when (zerop (release-server-process)) 66 | (post-quit-message))) 67 | 68 | (defun register-server () 69 | (let ((class (find-class 'hello-world-object))) 70 | (when (slot-value class 'server-atom) 71 | (ignore-errors (revoke-class-object (slot-value class 'server-atom)))) 72 | (setf (slot-value class 'server-atom) 73 | (register-class-object class 74 | '(:inproc-server :local-server) 75 | '(:multiple-use :suspended)))) 76 | (resume-class-objects)) 77 | 78 | (closer-mop:defclass hello-world-wrapper () 79 | () 80 | (:metaclass com-wrapper-class) 81 | (:interfaces hello-world) 82 | (:clsid . "{DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF}")) 83 | 84 | (defun run-server () 85 | (initialize-com) 86 | (loop :with atom = (prog1 87 | (register-class-object 'hello-world-object 88 | :local-server 89 | '(:multiple-use :suspended)) 90 | (resume-class-objects)) 91 | :for msg = (get-message) :until (null msg) 92 | :do (dispatch-message msg) 93 | :finally (revoke-class-object atom)) 94 | (uninitialize-com)) 95 | -------------------------------------------------------------------------------- /examples/helloworld.midl: -------------------------------------------------------------------------------- 1 | [ 2 | uuid(6070E712-55CC-4434-849E-36C7C6987ACC), 3 | helpstring("HELLO-WORLD-OBJECT Type Library"), 4 | version(1.0) 5 | ] 6 | library DoorsHelloWorld 7 | { 8 | importlib("stdole32.tlb"); 9 | 10 | [ 11 | uuid(F9210244-38D1-49C0-A848-684EDD3DBFF0), // IID_HelloWorld 12 | oleautomation, 13 | object 14 | ] 15 | interface IHelloWorld : IUnknown 16 | { 17 | HRESULT HelloWorld([in] LPWSTR message); 18 | } 19 | 20 | [ 21 | uuid(DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF), // CLSID_HelloWorld 22 | appobject 23 | ] 24 | coclass HelloWorld 25 | { 26 | [default] interface IHelloWorld; 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /examples/helloworld.reg: -------------------------------------------------------------------------------- 1 | REGEDIT4 2 | 3 | [HKEY_CLASSES_ROOT\Doors.HelloWorld] 4 | @="Doors' HELLO-WORLD-OBJECT server" 5 | [HKEY_CLASSES_ROOT\Doors.HelloWorld\CLSID] 6 | @="{DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF}" 7 | 8 | [HKEY_CLASSES_ROOT\CLSID\{DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF}] 9 | @="Doors.HelloWorld" 10 | [HKEY_CLASSES_ROOT\CLSID\{DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF}\LocalServer32] 11 | @="D:/SBCL/Doors.HelloWorld.exe" 12 | [HKEY_CLASSES_ROOT\CLSID\{DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF}\ProgId] 13 | @="Doors.HelloWorld" 14 | [HKEY_CLASSES_ROOT\CLSID\{DF748DA7-BCB9-4F67-8D32-F9AA1AAA3ABF}\TypeLib] 15 | @="{6070E712-55CC-4434-849E-36C7C6987ACC}" 16 | 17 | [HKEY_CLASSES_ROOT\TypeLib\{6070E712-55CC-4434-849E-36C7C6987ACC}] 18 | [HKEY_CLASSES_ROOT\TypeLib\{6070E712-55CC-4434-849E-36C7C6987ACC}\1.0] 19 | @="Doors.HelloWorld Type Library" 20 | [HKEY_CLASSES_ROOT\TypeLib\{6070E712-55CC-4434-849E-36C7C6987ACC}\1.0\9\win32] 21 | @="D:/lisplibs/doors/examples/helloworld.tlb" 22 | 23 | [HKEY_CLASSES_ROOT\Interface\{F9210244-38D1-49C0-A848-684EDD3DBFF0}] 24 | @="IHelloWorld" 25 | [HKEY_CLASSES_ROOT\Interface\{F9210244-38D1-49C0-A848-684EDD3DBFF0}\TypeLib] 26 | @="{6070E712-55CC-4434-849E-36C7C6987ACC}" 27 | [HKEY_CLASSES_ROOT\Interface\{F9210244-38D1-49C0-A848-684EDD3DBFF0}\ProxyStubClsid32] 28 | @="{00020424-0000-0000-C000-000000000046}" 29 | -------------------------------------------------------------------------------- /examples/helloworld.tlb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Lovesan/doors/0a852454209c194321bf442ec27329a8192f72e3/examples/helloworld.tlb -------------------------------------------------------------------------------- /examples/packages.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:cl-user) 26 | 27 | (defpackage #:doors.com.examples 28 | (:use #:cl #:trivial-garbage #:alexandria #:virgil #:doors #:doors.com #:doors.ui) 29 | (:nicknames #:com.examples) 30 | (:export 31 | #:hello-world 32 | #:hello-world-object 33 | #:hello-world-wrapper 34 | #:register-server 35 | #:run-server)) 36 | -------------------------------------------------------------------------------- /gdi/bitmaps.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.gdi) 26 | 27 | (declaim (inline size make-size copy-size size-p 28 | size-cx size-cy 29 | (setf size-cx) (setf size-cy))) 30 | (define-struct (size 31 | (:constructor make-size) 32 | (:constructor size (cx cy))) 33 | "The SIZE structure specifies the width and height of a rectangle." 34 | (cx long) 35 | (cy long)) 36 | 37 | (define-struct (blend-function 38 | (:conc-name bf-) 39 | (:constructor make-bf (&optional (source-constant-alpha 255)))) 40 | "The BLEND-FUNCTION structure controls blending by specifying the blending functions for source and destination bitmaps." 41 | (blend-op byte :initform 0) 42 | (blend-flags byte :initform 0) 43 | (source-constant-alpha byte) 44 | (alpha-format byte :initform 1)) 45 | -------------------------------------------------------------------------------- /gdi/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:cl-user) 26 | 27 | (defpackage #:doors.gdi 28 | (:use #:cl #:alexandria #:virgil #:doors) 29 | (:nicknames #:gdi) 30 | (:export 31 | 32 | ;;rectangles 33 | #:rect 34 | #:make-rect 35 | #:copy-rect 36 | #:rect-p 37 | #:rect-left 38 | #:rect-top 39 | #:rect-right 40 | #:rect-bottom 41 | #:point 42 | #:make-point 43 | #:copy-point 44 | #:point-p 45 | #:pt-x 46 | #:pt-y 47 | #:point* 48 | #:make-point* 49 | #:copy-point* 50 | #:point-p* 51 | #:pt-x* 52 | #:pt-y* 53 | 54 | ;;bitmaps 55 | #:size 56 | #:make-size 57 | #:copy-size 58 | #:size-p 59 | #:size-cx 60 | #:size-cy 61 | #:blend-function 62 | #:make-bf 63 | #:bf-source-constant-alpha 64 | 65 | )) 66 | -------------------------------------------------------------------------------- /gdi/rectangles.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.gdi) 26 | 27 | (declaim (inline rect make-rect copy-rect rect-p 28 | rect-left rect-top rect-right rect-bottom 29 | (setf rect-left) (setf rect-top) 30 | (setf rect-right) (setf rect-bottom))) 31 | (define-struct (rect 32 | (:constructor make-rect) 33 | (:constructor rect (left top right bottom))) 34 | "The RECT structure defines the coordinates of the upper-left and lower-right corners of a rectangle." 35 | (left long) 36 | (top long) 37 | (right long) 38 | (bottom long)) 39 | 40 | (declaim (inline point make-point copy-point point-p 41 | pt-x pt-y (setf pt-x) (setf pt-y))) 42 | (defstruct (point 43 | (:conc-name pt-) 44 | (:constructor make-point) 45 | (:constructor point (x y))) 46 | "The POINT structure defines the x- and y- coordinates of a point." 47 | (x 0 :type long) 48 | (y 0 :type long)) 49 | 50 | (define-immediate-type point-type () 51 | () 52 | (:base-type qword) 53 | (:lisp-type (type) 'point) 54 | (:simple-parser point) 55 | (:prototype (type) (point 0 0)) 56 | (:prototype-expansion (type) `(point 0 0)) 57 | (:translator (value type) 58 | (point (make-long (ldb (byte 16 0) value) 59 | (ldb (byte 16 16) value)) 60 | (make-long (ldb (byte 16 32) value) 61 | (ldb (byte 16 48) value)))) 62 | (:translator-expansion (value type) 63 | (once-only ((value `(the qword ,value))) 64 | `(point (make-long (ldb (byte 16 0) ,value) 65 | (ldb (byte 16 16) ,value)) 66 | (make-long (ldb (byte 16 32) ,value) 67 | (ldb (byte 16 48) ,value))))) 68 | (:converter (point type) 69 | (make-qword (pt-x point) (pt-y point))) 70 | (:converter-expansion (point type) 71 | (once-only ((point `(the point ,point))) 72 | `(make-qword (pt-x ,point) (pt-y ,point)))) 73 | (:allocator-expansion (value type) 74 | `(alloc 'qword)) 75 | (:deallocator-expansion (pointer type) 76 | `(free ,pointer)) 77 | (:cleaner-expansion (pointer value type) 78 | ())) 79 | 80 | (declaim (inline point* make-point* copy-point* point-p* 81 | pt-x* pt-y* (setf pt-x*) (setf pt-y*))) 82 | (defstruct (point* 83 | (:conc-name pt-) 84 | (:constructor make-point* 85 | (&key (x 0) (y 0) &aux (x* x) (y* y))) 86 | (:constructor point* (x y &aux (x* x) (y* y)))) 87 | "The POINT* structure defines the x- and y- coordinates of a point." 88 | (x* 0 :type short) 89 | (y* 0 :type short)) 90 | 91 | (define-immediate-type point-type* () 92 | () 93 | (:base-type dword) 94 | (:lisp-type (type) 'point*) 95 | (:simple-parser point*) 96 | (:prototype (type) (point* 0 0)) 97 | (:prototype-expansion (type) `(point* 0 0)) 98 | (:translator (value type) 99 | (point* (make-short (ldb (byte 8 0) value) 100 | (ldb (byte 8 8) value)) 101 | (make-short (ldb (byte 8 16) value) 102 | (ldb (byte 8 24) value)))) 103 | (:translator-expansion (value type) 104 | (once-only ((value `(the dword ,value))) 105 | `(point* (make-short (ldb (byte 8 0) ,value) 106 | (ldb (byte 8 8) ,value)) 107 | (make-short (ldb (byte 8 16) ,value) 108 | (ldb (byte 8 24) ,value))))) 109 | (:converter (point type) 110 | (make-dword (pt-x* point) (pt-y* point))) 111 | (:converter-expansion (point type) 112 | (once-only ((point `(the point* ,point))) 113 | `(make-dword (pt-x* ,point) (pt-y* ,point)))) 114 | (:allocator-expansion (value type) 115 | `(alloc 'dword)) 116 | (:deallocator-expansion (pointer type) 117 | `(free ,pointer)) 118 | (:cleaner-expansion (pointer value type) 119 | ())) 120 | -------------------------------------------------------------------------------- /ole/interfaces.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.ole) 26 | 27 | (defmacro define-ole-guid (name dw w1 w2) 28 | `(define-guid ,name ,dw ,w1 ,w2 #xC0 #x00 #x00 #x00 #x00 #x00 #x00 #x46)) 29 | -------------------------------------------------------------------------------- /ole/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:cl-user) 26 | 27 | (defpackage #:doors.ole 28 | (:use #:cl #:alexandria #:virgil #:doors #:doors.com) 29 | (:export 30 | 31 | #:define-ole-guid)) 32 | -------------------------------------------------------------------------------- /security/authentication.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.security) 26 | 27 | (define-struct %string 28 | (length ushort) 29 | (maximum-length ushort) 30 | (buffer pointer)) 31 | 32 | (defun %read-string (pointer out encoding) 33 | (declare (type pointer pointer)) 34 | (let ((len (deref pointer 'ushort))) 35 | (read-cstring (deref pointer 'pointer (offsetof '%string 36 | 'buffer)) 37 | :encoding encoding 38 | :byte-length len 39 | :out out))) 40 | 41 | (defun %write-string (value pointer encoding) 42 | (declare (type pointer pointer)) 43 | (let ((len (min (cstring-size value :encoding encoding) 44 | (deref pointer 'ushort (offsetof '%string 45 | 'maximum-length)))) 46 | (buffer (deref pointer 'pointer (offsetof '%string 47 | 'buffer)))) 48 | (declare (type ushort len)) 49 | (setf (deref pointer 'ushort) len) 50 | (write-cstring value 51 | buffer 52 | :encoding encoding 53 | :byte-length len))) 54 | 55 | (defun %string-size (value encoding) 56 | (multiple-value-bind 57 | (data-len bom-len) (cstring-size value :encoding encoding) 58 | (the ushort (+ data-len bom-len)))) 59 | 60 | (defun %allocate-string (value encoding) 61 | (let* ((maxlen (%string-size value encoding)) 62 | (p (raw-alloc (sizeof '%string))) 63 | (buffer (raw-alloc maxlen))) 64 | (setf (deref p 'ushort) 0 65 | (deref p 'ushort (offsetof '%string 66 | 'maximum-length)) maxlen 67 | (deref p 'pointer (offsetof '%string 68 | 'buffer)) buffer) 69 | p)) 70 | 71 | (defun %free-string (pointer) 72 | (raw-free (deref pointer 'pointer (offsetof '%string 'buffer))) 73 | (raw-free pointer)) 74 | 75 | (define-translatable-type %string-type () 76 | ((encoding :initform :ascii :initarg :encoding 77 | :accessor %string-encoding)) 78 | (:fixed-size (type) 79 | (sizeof '%string)) 80 | (:align (type) 81 | (length 82 | (babel-encodings:enc-nul-encoding 83 | (babel-encodings:get-character-encoding 84 | (%string-encoding type))))) 85 | (:prototype (type) "") 86 | (:prototype-expansion (type) "") 87 | (:lisp-type (type) 'string) 88 | (:allocator (value type) 89 | (%allocate-string value (%string-encoding type))) 90 | (:allocator-expansion (value type) 91 | `(%allocate-string ,value ',(%string-encoding type))) 92 | (:deallocator (pointer type) 93 | (%free-string pointer)) 94 | (:deallocator-expansion (pointer type) 95 | `(%free-string ,pointer)) 96 | (:cleaner (pointer value type) nil) 97 | (:cleaner-expansion (pointer value type) nil) 98 | (:reader (pointer out type) 99 | (%read-string pointer out (%string-encoding type))) 100 | (:reader-expansion (pointer out type) 101 | `(%read-string ,pointer ,out ',(%string-encoding type))) 102 | (:writer (value pointer type) 103 | (%write-string value pointer (%string-encoding type))) 104 | (:writer-expansion (value pointer type) 105 | `(%write-string ,value ,pointer ',(%string-encoding type))) 106 | (:reference-dynamic-extent-expansion 107 | (var size-var value-var body mode type) 108 | (with-gensyms (buffer size pointer) 109 | `(with-raw-pointer (,pointer ,(sizeof '%string) ,size-var) 110 | (let* ((,size (%string-size ,value-var ',(%string-encoding type))) 111 | (,buffer (raw-alloc ,size)) 112 | (,var ,pointer)) 113 | (unwind-protect 114 | (progn (setf (deref ,pointer 'pointer (offsetof '%string 115 | 'buffer)) 116 | ,buffer 117 | (deref ,pointer 'ushort (offsetof '%string 118 | 'maximum-length)) 119 | ,size) 120 | nil 121 | ,(ecase mode 122 | (:in `(progn (%write-string ,value-var ,pointer 123 | ',(%string-encoding type)) 124 | nil 125 | ,@body)) 126 | (:out `(prog1 (progn ,@body) 127 | (%read-string ,pointer ,value-var 128 | ',(%string-encoding type)))) 129 | (:inout `(prog1 (progn 130 | (%write-string ,value-var ,pointer 131 | ',(%string-encoding type)) 132 | nil 133 | ,@body) 134 | (%read-string ,pointer ,value-var 135 | ',(%string-encoding type)))))) 136 | (raw-free ,buffer))))))) 137 | 138 | (define-type-parser string* (&optional (encoding :ascii)) 139 | (check-type encoding keyword) 140 | (make-instance '%string-type :encoding encoding)) 141 | 142 | (defmethod unparse-type ((type %string-type)) 143 | `(string* ,(%string-encoding type))) 144 | 145 | (defalias astring* () '(string* :ascii)) 146 | (defalias wstring* () '(string* :utf-16le)) 147 | (defalias tstring* () #+doors.unicode 'wstring* 148 | #-doors.unicode 'astring*) 149 | 150 | (define-struct (auth-identity) 151 | "Contains a user name and password." 152 | (user (& tstring)) 153 | (user-length ulong) 154 | (domain (& tstring)) 155 | (domain-length ulong) 156 | (password (& tstring)) 157 | (password-length ulong) 158 | (flags (enum (:base-type ulong) 159 | (:ansi 1) 160 | (:unicode 2)) 161 | :initform #+doors.unicode :unicode 162 | #-doors.unicode :ansi)) 163 | -------------------------------------------------------------------------------- /security/authorization.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.security) 26 | 27 | (define-struct (security-attributes 28 | (:conc-name security-) 29 | (:constructor security-attributes 30 | (descriptor &optional inherit-handle))) 31 | (attributes-struct-size 32 | dword :initform (sizeof 'security-attributes)) 33 | (descriptor pointer) 34 | (inherit-handle bool)) 35 | 36 | (define-struct (luid (:constructor luid (low-part high-part))) 37 | (low-part dword) 38 | (high-part long)) 39 | 40 | (define-enum (trustee-form 41 | (:conc-name trustee-is-)) 42 | :sid 43 | :name 44 | :bad-form 45 | :objects-and-sid 46 | :objects-and-name) 47 | 48 | (define-enum (trustee-type 49 | (:conc-name trustee-is-)) 50 | :unknown 51 | :user 52 | :group 53 | :domain 54 | :alias 55 | :well-known-group 56 | :deleted 57 | :invalid 58 | :computer) 59 | 60 | (define-enum (se-object-type (:conc-name se-)) 61 | :unknown-object-type 62 | :file-object 63 | :service 64 | :printer 65 | :registry-key 66 | :lmshare 67 | :kernel-object 68 | :window-object 69 | :ds-object 70 | :ds-object-all 71 | :provider-defined-object 72 | :wmi-guid-object 73 | :registry-wow64-32-key) 74 | 75 | (define-struct (objects-and-name) 76 | (objects-present (enum (:base-type dword) 77 | (:object-type-present 1) 78 | (:inherited-object-type-present 2))) 79 | (object-type se-object-type) 80 | (object-type-name (& tstring)) 81 | (inherited-object-type-name (& tstring)) 82 | (name (& tstring))) 83 | 84 | (define-struct (objects-and-sid) 85 | (objects-present (enum (:base-type dword) 86 | (:object-type-present 1) 87 | (:inherited-object-type-present 2))) 88 | (object-type-guid guid) 89 | (inherited-object-type-guid guid) 90 | (sid pointer)) 91 | 92 | (defalias trustee-name () '(union () 93 | (sid pointer) 94 | (name (& tstring)) 95 | (objects-and-name (& objects-and-name)) 96 | (objects-and-sid (& objects-and-sid)))) 97 | 98 | (define-struct (trustee 99 | (:reader %trustee-reader) 100 | (:constructor make-trustee (&key form type name)) 101 | (:constructor trustee (form type name))) 102 | (reserved pointer :initform &0) 103 | (multiple-trustee-operation 104 | (enum () :no-multiple-trustee-operation) 105 | :initform :no-multiple-trustee-operation) 106 | (form trustee-form) 107 | (type trustee-type) 108 | (name trustee-name :initform &0)) 109 | 110 | (declaim (notinline %trustee-writer)) 111 | (defun %trustee-writer (value pointer) 112 | (declare (type pointer pointer) 113 | (type trustee value)) 114 | (setf (deref pointer 'trustee-type (offsetof 'trustee 'type)) 115 | (trustee-type value) 116 | (deref pointer 'trustee-form (offsetof 'trustee 'form)) 117 | (trustee-form value) 118 | (deref pointer 'trustee-name (offsetof 'trustee 'name)) 119 | (trustee-name value) 120 | (deref pointer 'pointer) 121 | &0 122 | (deref pointer 'int (offsetof 'trustee 'multiple-trustee-operation)) 123 | 0) 124 | value) 125 | 126 | (declaim (notinline %trustee-reader)) 127 | (defun %trustee-reader (p out) 128 | (declare (type pointer p)) 129 | (let* ((form (deref p 'trustee-form (offsetof 'trustee 'form))) 130 | (out (or out (trustee 131 | form 132 | (deref p 'trustee-type (offsetof 'trustee 'type)) 133 | &0)))) 134 | (setf (trustee-name out) 135 | (case form 136 | (:name (deref p 'tstring (offsetof 'trustee 'name))) 137 | (:objects-and-name (deref p 'objects-and-name 138 | (offsetof 'trustee 'name))) 139 | (:objects-and-sid (deref p 'objects-and-sid 140 | (offsetof 'trustee 'name))) 141 | (T (deref p 'pointer (offsetof 'trustee 'name))))) 142 | out)) 143 | 144 | (define-enum (actrl-access-flags 145 | (:conc-name actrl-) 146 | (:base-type ulong)) 147 | (:access-allowed 1) 148 | (:access-denied 2) 149 | (:audit-success 4) 150 | (:audit-failure 8)) 151 | 152 | (define-enum (actrl-standard-rights 153 | (:base-type ulong) 154 | (:conc-name actrl-)) 155 | (:system-access #x04000000) 156 | (:delete #x08000000) 157 | (:read-control #x10000000) 158 | (:change-access #x20000000) 159 | (:synchronize #x80000000) 160 | (:std-rights-all #xf8000000) 161 | (:std-rights-required #x78000000)) 162 | 163 | (define-enum (inheritance-flags 164 | (:base-type dword) 165 | (:conc-name nil)) 166 | (:no-inheritance #x0) 167 | (:container-inherit-ace #x2) 168 | (:inherit-only-ace #x8) 169 | (:no-propagate-inherit-ace #x4) 170 | (:object-inherit-ace #x1) 171 | (:sub-containers-and-objects-inherit #x3) 172 | (:sub-containers-only-inherit #x2) 173 | (:sub-objects-only-inherit #x1)) 174 | 175 | (define-struct (actrl-access-entry 176 | (:constructor make-actrl-ae) 177 | (:conc-name actrl-ae-)) 178 | "Contains access-control information for a specified trustee. " 179 | (trustee trustee) 180 | (access-flags actrl-access-flags) 181 | (access actrl-standard-rights) 182 | (prov-specific-access dword) 183 | (inheritance inheritance-flags) 184 | (inherit-property (& tstring :in t))) 185 | 186 | (define-struct (actrl-access-entry-list 187 | (:constructor make-actrl-ael (&key list)) 188 | (:conc-name actrl-ael-) 189 | (:reader %actrl-ael-reader) 190 | (:writer %actrl-ael-writer)) 191 | "Contains a list of access entries." 192 | (entries ulong) 193 | (list (& (~ actrl-access-entry) :in t))) 194 | 195 | (defun %actrl-ael-reader (pointer out) 196 | (declare (type pointer pointer)) 197 | (let* ((out (or out (make-actrl-ael))) 198 | (n (deref pointer 'ulong)) 199 | (v (map-into (make-array n) #'make-actrl-ae)) 200 | (pv (deref pointer '* (offsetof 'actrl-access-entry-list 'list)))) 201 | (if (and (/= 0 n) (&? pv)) 202 | (setf (actrl-ael-list out) 203 | (deref pv '(simple-array actrl-access-entry) 0 v) 204 | (actrl-ael-entries out) n) 205 | (setf (actrl-ael-list out) void 206 | (actrl-ael-entries out) 0)) 207 | out)) 208 | 209 | (defun %actrl-ael-writer (value pointer) 210 | (declare (type pointer pointer) 211 | (type actrl-access-entry-list value)) 212 | (let ((list (actrl-ael-list value))) 213 | (setf (deref pointer 'ulong) 214 | (if (voidp list) 0 (length (actrl-ael-list value))) 215 | (deref pointer 216 | '(& (~ actrl-access-entry) :in t) 217 | (offsetof 'actrl-access-entry-list 'list)) 218 | list)) 219 | value) 220 | 221 | (defconstant actrl-access-not-protected 0) 222 | (defconstant actrl-access-protected 1) 223 | 224 | (define-struct (actrl-property-entry 225 | (:constructor make-actrl-pe) 226 | (:conc-name actrl-pe-)) 227 | "Contains a list of access-control entries for an object or a specified property on an object. " 228 | (property (& (const tstring))) 229 | (access-entry-list (& actrl-access-entry-list :in t)) 230 | (list-flags (enum (:base-type ulong) 231 | :not-protected 232 | :protected))) 233 | 234 | (define-struct (actrl-access 235 | (:constructor make-actrl-access (&key list)) 236 | (:reader %actrl-access-reader) 237 | (:writer %actrl-access-writer)) 238 | "Contains an array of access-control lists for an object and its properties." 239 | (entries ulong) 240 | (list (& (~ actrl-property-entry) :in t))) 241 | 242 | (defun %actrl-access-reader (pointer out) 243 | (declare (type pointer pointer)) 244 | (let* ((out (or out (make-actrl-access))) 245 | (n (deref pointer 'ulong)) 246 | (v (map-into (make-array n) #'make-actrl-pe)) 247 | (pv (deref pointer '* (offsetof 'actrl-access 'list)))) 248 | (if (and (/= 0 n) (&? pv)) 249 | (setf (actrl-access-list out) 250 | (deref pv '(simple-array actrl-property-entry) 0 v) 251 | (actrl-access-entries out) n) 252 | (setf (actrl-access-entries out) 0 253 | (actrl-access-list out) void)) 254 | out)) 255 | 256 | (defun %actrl-access-writer (value pointer) 257 | (declare (type pointer pointer) 258 | (type actrl-access value)) 259 | (let ((list (actrl-access-list value))) 260 | (setf (deref pointer 'ulong) 261 | (if (voidp list) 0 (length (actrl-access-list value))) 262 | (deref pointer 263 | '(& (~ actrl-property-entry) :in t) 264 | (offsetof 'actrl-access 'list)) 265 | list)) 266 | value) 267 | -------------------------------------------------------------------------------- /security/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:cl-user) 26 | 27 | (defpackage #:doors.security 28 | (:use #:cl #:alexandria #:virgil #:doors #:doors.com) 29 | (:export 30 | 31 | ;;authentication stuff 32 | #:string* 33 | #:astring* 34 | #:wstring* 35 | #:tstring* 36 | #:auth-identity 37 | 38 | ;;authorization stuff 39 | #:security-attributes 40 | #:security-atributes-descriptor 41 | #:security-attributes-inherit-handle 42 | #:luid 43 | #:luid-low-part 44 | #:luid-high-part 45 | #:trustee 46 | #:trustee-name 47 | #:trustee-form 48 | #:trustee-type 49 | #:trustee-is-sid 50 | #:trustee-is-name 51 | #:trustee-is-bad-form 52 | #:trustee-is-objects-and-sid 53 | #:trustee-is-objects-and-name 54 | #:trustee-is-unknown 55 | #:trustee-is-user 56 | #:trustee-is-group 57 | #:trustee-is-domain 58 | #:trustee-is-alias 59 | #:trustee-is-well-known-group 60 | #:trustee-is-deleted 61 | #:trustee-is-invalid 62 | #:trustee-is-compute 63 | #:se-object-type 64 | #:se-unknown-object-type 65 | #:se-file-object 66 | #:se-service 67 | #:se-printer 68 | #:se-registry-key 69 | #:se-lmshare 70 | #:se-kernel-object 71 | #:se-window-object 72 | #:se-ds-object 73 | #:se-ds-object-all 74 | #:se-provider-defined-object 75 | #:se-wmi-guid-object 76 | #:se-registry-wow64-32-key 77 | #:objects-and-name 78 | #:make-objects-and-name 79 | #:objects-and-name 80 | #:objects-and-name-objects-present 81 | #:objects-and-name-object-type 82 | #:objects-and-name-object-type-name 83 | #:objects-and-name-inherited-object-type-name 84 | #:objects-and-name-name 85 | #:object-and-sid 86 | #:make-objects-and-sid 87 | #:objects-and-sid-objects-present 88 | #:objects-and-sid-object-type-guid 89 | #:objects-and-sid-inherited-object-type-guid 90 | #:objects-and-sid-sid 91 | #:actrl-access-flags 92 | #:actrl-access-allowed 93 | #:actrl-denied 94 | #:actrl-audit-success 95 | #:actrl-audit-failure 96 | #:actrl-standard-rights 97 | #:actrl-system-access 98 | #:actrl-delete 99 | #:actrl-read-control 100 | #:actrl-change-access 101 | #:actrl-synchronize 102 | #:actrl-std-rights-all 103 | #:actrl-std-rights-required 104 | #:inheritance-flags 105 | #:no-inheritance 106 | #:container-inherit-ace 107 | #:inherit-only-ace 108 | #:no-propagate-inherit-ace 109 | #:object-inherit-ace 110 | #:sub-containers-and-objects-inherit 111 | #:sub-containers-only-inherit 112 | #:sub-objects-only-inherit 113 | #:actrl-access-entry 114 | #:make-actrl-ae 115 | #:actrl-ae-trustee 116 | #:actrl-ae-access-flags 117 | #:actrl-ae-access 118 | #:actrl-ae-prov-specific-access 119 | #:actrl-ae-inheritance 120 | #:actrl-ae-inherit-property 121 | #:actrl-access-entry-list 122 | #:make-actrl-ael 123 | #:actrl-ael-list 124 | #:actrl-access-protected 125 | #:actrl-access-not-protected 126 | #:actrl-property-entry 127 | #:make-actrl-pe 128 | #:actrl-pe-property 129 | #:actrl-pe-access-entry-list 130 | #:actrl-pe-list-flags 131 | #:actrl-access 132 | #:make-actrl-access 133 | #:actrl-access-list 134 | )) 135 | -------------------------------------------------------------------------------- /system/dlls.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (define-external-function 28 | ("DisableThreadLibraryCalls" (:camel-case)) 29 | (:stdcall kernel32) 30 | ((last-error bool)) 31 | (module handle)) 32 | 33 | (define-external-function 34 | ("FreeLibrary" (:camel-case)) 35 | (:stdcall kernel32) 36 | ((last-error bool)) 37 | "Frees the loaded dynamic-link library (DLL) module and, if necessary, decrements its reference count." 38 | (module handle)) 39 | 40 | (define-external-function 41 | ("FreeLibraryAndExitThread" (:camel-case)) 42 | (:stdcall kernel32) 43 | (void) 44 | "Decrements the reference count of a loaded dynamic-link library (DLL) by one, then calls ExitThread to terminate the calling thread. The function does not return." 45 | (module handle) 46 | (exit-code dword :optional 0)) 47 | 48 | #-win2000 49 | (define-external-function 50 | (#+doors.unicode "GetDllDirectoryW" 51 | #-doors.unicode "GetDllDirectoryA" 52 | dll-directory) 53 | (:stdcall kernel32) 54 | (dword rv (if (zerop rv) 55 | (invoke-last-error) 56 | (subseq buffer 0 rv))) 57 | "Retrieves the application-specific portion of the search path used to locate DLLs for the application." 58 | (buffer-length dword :optional 256) 59 | (buffer (& tstring :out) :aux (make-string buffer-length))) 60 | 61 | #-win2000 62 | (define-symbol-macro dll-directory (dll-directory)) 63 | 64 | (define-external-function 65 | (#+doors.unicode "GetModuleFileNameW" 66 | #-doors.unicode "GetModuleFileNameA" 67 | module-file-name) 68 | (:stdcall kernel32) 69 | (dword rv (if (and (zerop rv) (not (zerop buffer-size))) 70 | (invoke-last-error) 71 | (subseq buffer 0 rv))) 72 | "Retrieves the fully-qualified path for the file that contains the specified module." 73 | (module handle :optional nil) 74 | (buffer (& tstring :out) :aux (make-string buffer-size)) 75 | (buffer-size dword :optional 256)) 76 | 77 | (define-symbol-macro module-file-name (module-file-name)) 78 | 79 | (define-external-function 80 | (#+doors.unicode "GetModuleHandleW" 81 | #-doors.unicode "GetModuleHandleA" 82 | module-handle) 83 | (:stdcall kernel32) 84 | ((last-error handle)) 85 | "Retrieves a module handle for the specified module. The module must have been loaded by the calling process." 86 | (module-name (& tstring :in t) :optional void)) 87 | 88 | (define-symbol-macro module-handle (module-handle)) 89 | 90 | (define-enum (module-handle-flags 91 | (:base-type dword) 92 | (:list t) 93 | (:conc-name module-handle-flag-)) 94 | (:inc-refcount #x00000000) 95 | (:from-address #x00000004) 96 | (:pin #x00000001) 97 | (:unchanged-refcount #x00000002)) 98 | 99 | #-win2000 100 | (define-external-function 101 | (#+doors.unicode "GetModuleHandleExW" 102 | #-doors.unicode "GetModuleHandleExA" 103 | module-handle*) 104 | (:stdcall kernel32) 105 | ((last-error bool) rv module) 106 | "Retrieves a module handle for the specified module. The module must have been loaded by the calling process." 107 | (flags module-handle-flags) 108 | (module-name (union () 109 | (ptr pointer) 110 | (name (& tstring :in t))) 111 | :optional void) 112 | (module (& handle :out) :aux)) 113 | 114 | #-win2000 115 | (define-symbol-macro module-handle* (module-handle*)) 116 | 117 | (define-external-function 118 | ("GetProcAddress" proc-address) 119 | (:stdcall kernel32) 120 | ((last-error pointer &?)) 121 | "Retrieves the address of an exported function or variable from the specified dynamic-link library (DLL)." 122 | (module handle) 123 | (proc-name (union () 124 | (number size-t) 125 | (name (& astring))))) 126 | 127 | (define-external-function 128 | (#+doors.unicode "LoadLibraryW" 129 | #-doors.unicode "LoadLibraryA" 130 | load-library) 131 | (:stdcall kernel32) 132 | ((last-error handle)) 133 | "Loads the specified module into the address space of the calling process." 134 | (filename (& tstring))) 135 | 136 | (define-enum (load-library-flags 137 | (:base-type dword) 138 | (:list t) 139 | (:conc-name load-library-)) 140 | (:dont-resolve-dll-references #x00000001) 141 | (:ignore-code-authz-level #x00000010) 142 | (:as-datafile #x00000002) 143 | (:as-datafile-exclusive #x00000040) 144 | (:as-image-resource #x00000020) 145 | (:with-altered-search-path #x00000008)) 146 | 147 | (define-external-function 148 | (#+doors.unicode "LoadLibraryExW" 149 | #-doors.unicode "LoadLibraryExA" 150 | load-library*) 151 | (:stdcall kernel32) 152 | ((last-error handle)) 153 | "Loads the specified module into the address space of the calling process. The specified module may cause other modules to be loaded." 154 | (filename (& tstring)) 155 | (hfile handle :aux nil) 156 | (flags load-library-flags)) 157 | 158 | (define-struct (load-params 159 | (:constructor make-load-params) 160 | (:constructor 161 | load-params (cmd-line &optional cmd-show env-address))) 162 | (env-address (& astring :in t) :initform void) 163 | (cmd-line (& pascal-string)) 164 | (cmd-show (& dword) :initform #x00000002) 165 | (reserved dword :initform 0)) 166 | 167 | (define-external-function 168 | ("LoadModule" (:camel-case)) 169 | (:stdcall kernel32) 170 | (dword rv (if (> rv 31) 171 | t 172 | (error 'windows-error 173 | :code (if (zerop rv) 174 | error-out-of-memory 175 | (hresult-from-win32 rv))))) 176 | "Loads and executes an application or creates a new instance of an existing application." 177 | (module-name (& astring)) 178 | (parameter-block (& load-params))) 179 | 180 | #-win2000 181 | (define-external-function 182 | (#+doors.unicode "SetDllDirectoryW" 183 | #-doors.unicode "SetDllDirectoryA" 184 | (setf dll-directory)) 185 | (:stdcall kernel32) 186 | ((last-error bool) rv pathname) 187 | "Adds a directory to the search path used to locate DLLs for the application." 188 | (pathname (& tstring :in t))) 189 | -------------------------------------------------------------------------------- /system/errors.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (define-results windows-status (warning) 28 | () 29 | ((ok 0 "No error occurred") 30 | (false 1 "Successful but nonstandard completion of operation")) 31 | (:conc-name status-) 32 | (:default-initargs :code status-false)) 33 | 34 | (defun windows-status-code (windows-status) 35 | (declare (type windows-status windows-status)) 36 | (slot-value windows-status 'code)) 37 | 38 | (define-results windows-error (error) 39 | () 40 | ((success 0 "No error occurred") 41 | (unexpected-failure #x8000FFFF 42 | "Catastrophic failure") 43 | (invalid-info-class #xC0000003 44 | "The specified information class is not a valid information class for the specified object.") 45 | (more-data #x800700EA 46 | "More data is available.") 47 | (out-of-memory #x8007000E 48 | "Ran out of memory") 49 | (not-enough-memory #x80070008 50 | "Not enough storage is available to process this command.") 51 | (invalid-arg #x80070057 52 | "One or more arguments are invalid") 53 | (invalid-handle #x80070006 54 | "Invalid handle") 55 | (bad-length #x80070018 56 | "The program issued a command but the command length is incorrect.") 57 | (insufficient-buffer #x8007007A 58 | "The data area passed to a system call is too small") 59 | (buffer-overflow #x8007006F 60 | "The file name is too long.") 61 | (access-denied #x80070005 62 | "General access denied error")) 63 | (:conc-name error-) 64 | (:default-initargs :code error-unexpected-failure)) 65 | 66 | (defun windows-error-code (windows-error) 67 | (declare (type windows-error windows-error)) 68 | (slot-value windows-error 'code)) 69 | 70 | (define-condition non-system-error (windows-error) 71 | () 72 | (:report (lambda (condition stream) 73 | (format stream "Non-system error. Code: ~s" 74 | (windows-condition-code condition)) 75 | condition))) 76 | 77 | (declaim (inline system-error-code-p)) 78 | (defun system-error-code-p (code) 79 | (declare (type dword code)) 80 | (not (logbitp 29 code))) 81 | 82 | (define-external-function ("GetLastError" last-error) 83 | (:stdcall kernel32) 84 | (dword)) 85 | 86 | (define-external-function ("SetLastError" (setf last-error)) 87 | (:stdcall kernel32) 88 | (void rv error-code) 89 | (error-code dword)) 90 | 91 | (define-symbol-macro last-error (last-error)) 92 | 93 | (defun invoke-last-error (&optional (error-if-no-error T) default-value) 94 | (let ((last-error-code last-error)) 95 | (if (system-error-code-p last-error-code) 96 | (let ((result (hresult-from-win32 last-error-code))) 97 | (if (hresult-error-p result) 98 | (error 'windows-error :code result) 99 | (if error-if-no-error 100 | (error 'windows-error) 101 | default-value))) 102 | (error 'non-system-error :code last-error-code)))) 103 | 104 | (defun %invoke-last-error (value) 105 | (declare (ignore value)) 106 | (invoke-last-error)) 107 | 108 | (declaim (inline not-null)) 109 | (defun not-null (x) 110 | (not (null x))) 111 | 112 | (declaim (inline not-zero)) 113 | (defun not-zero (x) 114 | (not (zerop x))) 115 | 116 | (defalias last-error (type &optional (predicate 'not-null)) 117 | `(filtered ,type ,predicate %invoke-last-error)) 118 | 119 | (define-external-function "Beep" 120 | (:stdcall kernel32) 121 | ((last-error bool)) 122 | (frequency dword) 123 | (duration dword)) 124 | 125 | (define-external-function 126 | (#+doors.unicode "FatalAppExitW" 127 | #-doors.unicode "FatalAppExitA" 128 | fatal-app-exit) 129 | (:stdcall kernel32) 130 | (void) 131 | (action uint :aux 0) 132 | (message-text (& tstring))) 133 | 134 | (define-external-function 135 | ("FlashWindow" (:camel-case)) 136 | (:stdcall user32) 137 | (bool) 138 | (hwnd handle) 139 | (invert boolean)) 140 | 141 | (define-enum (flash-window-flags 142 | (:list t) 143 | (:conc-name flashw-)) 144 | (:stop 0) 145 | (:caption 1) 146 | (:tray 2) 147 | (:all 3) 148 | (:timer 4) 149 | (:timer-no-fg #xC)) 150 | 151 | (define-struct (flash-window-info 152 | (:conc-name flash-window-) 153 | (:constructor flash-window-info 154 | (&key hwnd flags count timeout))) 155 | (size uint :initform (sizeof 'flash-window-info)) 156 | (hwnd handle) 157 | (flags flash-window-flags) 158 | (count uint) 159 | (timeout dword)) 160 | 161 | (define-external-function 162 | ("FlashWindowEx" flash-window*) 163 | (:stdcall user32) 164 | (bool) 165 | (fwinfo (& flash-window-info))) 166 | 167 | (define-enum (format-message-flags 168 | (:base-type dword) 169 | (:list t) 170 | (:conc-name format-message-)) 171 | (:allocate-buffer #x00000100) 172 | (:argument-array #x00002000) 173 | (:from-module #x00000800) 174 | (:from-string #x00000400) 175 | (:from-system #x00001000) 176 | (:ignore-inserts #x00000200) 177 | (:max-width-mask #x000000FF)) 178 | 179 | (define-external-function 180 | (#+doors.unicode "FormatMessageW" 181 | #-doors.unicode "FormatMessageA" 182 | format-message) 183 | (:stdcall kernel32) 184 | ((last-error dword not-zero)) 185 | (flags format-message-flags) 186 | (source pointer :key) 187 | (message-id dword :key) 188 | (language-id dword :key 0) 189 | (buffer pointer) 190 | (size dword :key) 191 | (arguments pointer :key)) 192 | 193 | (define-enum (system-error-mode 194 | (:conc-name sem-) 195 | (:list t) 196 | (:base-type uint)) 197 | (:fail-critical-errors 1) 198 | (:no-alignment-fault-exception 4) 199 | (:no-page-fault-error-box 2) 200 | (:no-open-file-error-box #x8000)) 201 | 202 | #-(or :win2000 :winxp :winx64 :winserver2003 :winhomeserver) 203 | (define-external-function 204 | ("GetErrorMode" error-mode) 205 | (:stdcall kernel32) 206 | (system-error-mode)) 207 | 208 | #-(or :win2000 :winxp :winx64 :winserver2003 :winhomeserver :winvista 209 | :winserver2008) 210 | (define-external-function 211 | ("GetThreadErrorMode" thread-error-mode) 212 | (:stdcall kernel32) 213 | (system-error-mode)) 214 | 215 | #-(or :win2000 :winxp :winx64 :winserver2003 :winhomeserver) 216 | (define-external-function 217 | ("SetErrorMode" (setf error-mode)) 218 | (:stdcall kernel32) 219 | (system-error-mode) 220 | (new-mode system-error-mode)) 221 | 222 | #-(or :win2000 :winxp :winx64 :winserver2003 :winhomeserver 223 | :winvista :winserver2008) 224 | (define-external-function 225 | ("SetThreadErrorMode" (setf thread-error-mode)) 226 | (:stdcall kernel32) 227 | (system-error-mode) 228 | (new-mode system-error-mode)) 229 | 230 | #-(or :win2000 :winxp :winx64 :winserver2003 :winhomeserver) 231 | (define-symbol-macro error-mode (error-mode)) 232 | #-(or :win2000 :winxp :winx64 :winserver2003 :winhomeserver 233 | :winvista :winserver2008) 234 | (define-symbol-macro thread-error-mode (thread-error-mode)) 235 | 236 | (define-external-function 237 | ("MessageBeep" (:camel-case)) 238 | (:stdcall user32) 239 | ((last-error bool)) 240 | (type (enum (:base-type uint) 241 | (:simple #xFFFFFFFF) 242 | (:asterisk #x40) 243 | (:exclamation #x30) 244 | (:error #x10) 245 | (:hand #x10) 246 | (:information #x40) 247 | (:question #x20) 248 | (:stop #x10) 249 | (:warning #x30) 250 | (:ok 0)) 251 | :optional :simple)) 252 | -------------------------------------------------------------------------------- /system/features.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | #+windows 28 | (pushnew :doors *features*) 29 | #-windows 30 | (error "Operating system not supported") 31 | 32 | (eval-when (:compile-toplevel :load-toplevel :execute) 33 | (when (equal (ignore-errors 34 | (with-pointer (p "test" '(string :encoding :utf-16le)) 35 | (deref p '(string :encoding :utf-16le)))) 36 | "test") 37 | (pushnew :doors.unicode *features*))) 38 | -------------------------------------------------------------------------------- /system/guid.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (declaim (inline guid guidp make-guid guid-dw guid-w1 guid-w2 28 | guid-b1 guid-b2 guid-b3 guid-b4 29 | guid-b5 guid-b6 guid-b7 guid-b8 30 | %guid-reader %guid-writer %guid-cleaner)) 31 | (define-struct 32 | (guid 33 | (:constructor guid (dw w1 w2 b1 b2 b3 b4 b5 b6 b7 b8)) 34 | (:constructor make-guid) 35 | (:predicate guidp) 36 | (:cleaner %guid-cleaner) 37 | (:reader %guid-reader) 38 | (:writer %guid-writer) 39 | (:print-object (lambda (object stream) 40 | (print-unreadable-object (object stream :type t) 41 | (with-accessors 42 | ((dw guid-dw) (w1 guid-w1) (w2 guid-w2) 43 | (b1 guid-b1) (b2 guid-b2) (b3 guid-b3) (b4 guid-b4) 44 | (b5 guid-b5) (b6 guid-b6) (b7 guid-b7) (b8 guid-b8)) 45 | object 46 | (format 47 | stream 48 | "{~8,'0X-~{~4,'0X-~}~{~2,'0X~}-~{~2,'0X~}}" 49 | dw 50 | (list w1 w2) 51 | (list b1 b2) 52 | (list b3 b4 b5 b6 b7 b8)))) 53 | object))) 54 | (dw uint32) 55 | (w1 uint16) 56 | (w2 uint16) 57 | (b1 uint8) 58 | (b2 uint8) 59 | (b3 uint8) 60 | (b4 uint8) 61 | (b5 uint8) 62 | (b6 uint8) 63 | (b7 uint8) 64 | (b8 uint8)) 65 | 66 | (defmacro with-guid-accessors ((dw w1 w2 b1 b2 b3 b4 b5 b6 b7 b8) 67 | guid 68 | &body body) 69 | `(with-accessors ((,dw guid-dw) (,w1 guid-w1) (,w2 guid-w2) 70 | (,b1 guid-b1) (,b2 guid-b2) (,b3 guid-b3) (,b4 guid-b4) 71 | (,b5 guid-b5) (,b6 guid-b6) (,b7 guid-b7) (,b8 guid-b8)) 72 | (the guid ,guid) 73 | ,@body)) 74 | 75 | (defun %guid-reader (p o) 76 | (declare (type pointer p)) 77 | (let ((out (or o (guid 0 0 0 0 0 0 0 0 0 0 0)))) 78 | (declare (type guid out)) 79 | (with-guid-accessors 80 | (dw w1 w2 b1 b2 b3 b4 b5 b6 b7 b8) out 81 | (setf dw (deref p 'dword (offsetof 'guid 'dw)) 82 | w1 (deref p 'word (offsetof 'guid 'w1)) 83 | w2 (deref p 'word (offsetof 'guid 'w2)) 84 | b1 (deref p 'byte (offsetof 'guid 'b1)) 85 | b2 (deref p 'byte (offsetof 'guid 'b2)) 86 | b3 (deref p 'byte (offsetof 'guid 'b3)) 87 | b4 (deref p 'byte (offsetof 'guid 'b4)) 88 | b5 (deref p 'byte (offsetof 'guid 'b5)) 89 | b6 (deref p 'byte (offsetof 'guid 'b6)) 90 | b7 (deref p 'byte (offsetof 'guid 'b7)) 91 | b8 (deref p 'byte (offsetof 'guid 'b8))) 92 | out))) 93 | (defun %guid-writer (v p) 94 | (declare (type pointer p) (type guid v)) 95 | (with-guid-accessors 96 | (dw w1 w2 b1 b2 b3 b4 b5 b6 b7 b8) v 97 | (setf (deref p 'dword (offsetof 'guid 'dw)) dw 98 | (deref p 'word (offsetof 'guid 'w1)) w1 99 | (deref p 'word (offsetof 'guid 'w2)) w2 100 | (deref p 'byte (offsetof 'guid 'b1)) b1 101 | (deref p 'byte (offsetof 'guid 'b2)) b2 102 | (deref p 'byte (offsetof 'guid 'b3)) b3 103 | (deref p 'byte (offsetof 'guid 'b4)) b4 104 | (deref p 'byte (offsetof 'guid 'b5)) b5 105 | (deref p 'byte (offsetof 'guid 'b6)) b6 106 | (deref p 'byte (offsetof 'guid 'b7)) b7 107 | (deref p 'byte (offsetof 'guid 'b8)) b8) 108 | v)) 109 | (defun %guid-cleaner (p v) 110 | (declare (ignore p v)) 111 | nil) 112 | 113 | (declaim (inline guid-equal)) 114 | (defun guid-equal (guid1 guid2) 115 | (declare (type guid guid1 guid2)) 116 | (with-accessors 117 | ((dw-1 guid-dw) (w1-1 guid-w1) (w2-1 guid-w2) 118 | (b1-1 guid-b1) (b2-1 guid-b2) (b3-1 guid-b3) (b4-1 guid-b4) 119 | (b5-1 guid-b5) (b6-1 guid-b6) (b7-1 guid-b7) (b8-1 guid-b8)) 120 | guid1 121 | (with-accessors 122 | ((dw-2 guid-dw) (w1-2 guid-w1) (w2-2 guid-w2) 123 | (b1-2 guid-b1) (b2-2 guid-b2) (b3-2 guid-b3) (b4-2 guid-b4) 124 | (b5-2 guid-b5) (b6-2 guid-b6) (b7-2 guid-b7) (b8-2 guid-b8)) 125 | guid2 126 | (and (= dw-1 dw-2) (= w1-1 w1-2) (= w2-1 w2-2) 127 | (= b1-1 b1-2) (= b2-1 b2-2) (= b3-1 b3-2) (= b4-1 b4-2) 128 | (= b5-1 b5-2) (= b6-1 b6-2) (= b7-1 b7-2) (= b8-1 b8-2))))) 129 | 130 | (defalias uuid () 'guid) 131 | (deftype uuid () 'guid) 132 | 133 | (eval-when (:compile-toplevel :load-toplevel :execute) 134 | (defmethod make-load-form ((object guid) &optional env) 135 | (declare (ignore env)) 136 | (with-guid-accessors (dw w1 w2 b1 b2 b3 b4 b5 b6 b7 b8) 137 | object 138 | `(load-time-value 139 | (guid ,dw ,w1 ,w2 ,b1 ,b2 ,b3 ,b4 ,b5 ,b6 ,b7 ,b8) 140 | t)))) 141 | 142 | (defmacro %define-guid (name dw w1 w2 b1 b2 b3 b4 b5 b6 b7 b8) 143 | (check-type name symbol) 144 | (check-type dw dword) 145 | (check-type w1 word) 146 | (check-type w2 word) 147 | (check-type b1 ubyte) 148 | (check-type b2 ubyte) 149 | (check-type b3 ubyte) 150 | (check-type b4 ubyte) 151 | (check-type b5 ubyte) 152 | (check-type b6 ubyte) 153 | (check-type b7 ubyte) 154 | (check-type b8 ubyte) 155 | `(eval-when (:compile-toplevel :load-toplevel :execute) 156 | (define-constant ,name (load-time-value 157 | (guid ,dw ,w1 ,w2 ,b1 ,b2 ,b3 ,b4 ,b5 ,b6 ,b7 ,b8) 158 | t) 159 | :test #'equalp) 160 | ',name)) 161 | 162 | (defmacro define-guid (name &rest values) 163 | (check-type name symbol) 164 | (cond 165 | ((stringp (first values)) 166 | (assert (null (rest values)) (values)) 167 | (with-guid-accessors 168 | (dw w1 w2 b1 b2 b3 b4 b5 b6 b7 b8) 169 | (external-function-call 170 | "IIDFromString" 171 | ((:stdcall ole32) 172 | (hresult rv guid) 173 | ((& wstring)) 174 | ((& guid :out) guid :aux)) 175 | (car values)) 176 | `(%define-guid ,name ,dw ,w1 ,w2 ,b1 ,b2 ,b3 ,b4 ,b5 ,b6 ,b7 ,b8))) 177 | (T (assert (= 11 (length values)) (values)) 178 | `(%define-guid ,name ,@values)))) 179 | 180 | (define-guid uuid-null 0 0 0 0 0 0 0 0 0 0 0) 181 | 182 | (defgeneric uuid-of (class) 183 | (:method (class) 184 | (error 'windows-error :code error-invalid-arg)) 185 | (:method ((class symbol)) 186 | (uuid-of (find-class class))) 187 | (:method ((class null)) 188 | uuid-null)) 189 | 190 | (define-compiler-macro uuid-of (&whole form class) 191 | (if (constantp class) 192 | (uuid-of (eval class)) 193 | form)) 194 | 195 | (define-condition invalid-guid-format (windows-error) 196 | ((%string :accessor invalid-guid-format-string 197 | :initform "" 198 | :initarg :string)) 199 | (:report (lambda (c s) 200 | (pprint-logical-block (s nil) 201 | (format s "~s is an invalid representation of GUID." 202 | (invalid-guid-format-string c)) 203 | (pprint-newline :mandatory s) 204 | (write-string 205 | "String must be of form \"{XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX}\"" 206 | s) 207 | (pprint-newline :mandatory s)) 208 | c)) 209 | (:documentation 210 | "Signalled when GUID-FROM-STRING function recieves string of invalid format.")) 211 | 212 | (defun string-from-guid (guid) 213 | (declare (type guid guid)) 214 | "Converts a GUID structure to its string representation." 215 | (external-function-call 216 | "StringFromGUID2" 217 | ((:stdcall ole32) 218 | (int rv buffer) 219 | ((& guid) guid :aux guid) 220 | ((& wstring :out) buffer :aux (make-string 38)) 221 | (int cch :aux 39)))) 222 | 223 | (defun guid-from-string (string) 224 | (declare (type string string)) 225 | "Converts a string representation of GUID into GUID structure." 226 | (external-function-call 227 | "IIDFromString" 228 | ((:stdcall ole32) 229 | (dword rv (if (zerop rv) 230 | guid 231 | (error 'invalid-guid-format 232 | :string string))) 233 | ((& wstring) string :aux string) 234 | ((& guid :out) guid :aux)))) 235 | 236 | (define-external-function 237 | ("CoCreateGuid" create-guid) 238 | (:stdcall ole32) 239 | (hresult rv guid) 240 | "Creates a GUID, a unique 128-bit integer used for CLSIDs and interface identifiers. " 241 | (guid (& guid :out) :aux)) 242 | -------------------------------------------------------------------------------- /system/handles.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (define-external-function 28 | ("CloseHandle" (:camel-case)) 29 | (:stdcall kernel32) 30 | ((last-error bool)) 31 | "Closes an open object handle." 32 | (handle handle)) 33 | 34 | (define-external-function 35 | ("DuplicateHandle" (:camel-case)) 36 | (:stdcall kernel32) 37 | ((last-error bool) rv target-handle) 38 | "Duplicates an object handle." 39 | (process handle :key (external-function-call 40 | "GetCurrentProcess" 41 | ((:stdcall kernel32) 42 | (handle)))) 43 | (source-handle handle) 44 | (target-process handle :key process) 45 | (target-handle (& handle :out) :aux) 46 | (desired-access dword :key) 47 | (inherit-handle boolean :key) 48 | (options (enum (:base-type dword :list t) 49 | (:close-source 1) 50 | (:same-access 2)) 51 | :key :same-access)) 52 | 53 | (define-enum (handle-flags 54 | (:list t) 55 | (:conc-name handle-flag-)) 56 | (:inherit 1) 57 | (:protect-from-close 2)) 58 | 59 | (define-external-function 60 | ("GetHandleInformation" handle-information) 61 | (:stdcall kernel32) 62 | ((last-error bool) rv flags) 63 | "Retrieves certain properties of an object handle." 64 | (object handle) 65 | (flags (& handle-flags :out) :aux)) 66 | 67 | (define-external-function 68 | ("SetHandleInformation" (setf handle-information)) 69 | (:stdcall kernel32) 70 | ((last-error bool) rv flags) 71 | "Sets certain properties of an object handle." 72 | (object handle :optional) 73 | (mask handle-flags :aux flags) 74 | (flags handle-flags)) 75 | -------------------------------------------------------------------------------- /system/hresult.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (defvar *registered-results* (make-hash-table :test #'eql)) 28 | (defvar *result-descriptions* (make-hash-table :test #'eql)) 29 | 30 | (define-enum facility 31 | :null 32 | :rpc 33 | :dispatch 34 | :storage 35 | :interface 36 | (:win32 7) 37 | :windows 38 | :security 39 | (:sspi 9) 40 | :control 41 | :certification 42 | :internet 43 | :media-server 44 | :msmq 45 | :setup-api 46 | :smart-card 47 | :com+ 48 | :aaf 49 | :urt 50 | :acs 51 | :direct-play 52 | :umi 53 | :sxs 54 | :windows-ce 55 | :http 56 | :usermode-common-logging 57 | :usermode-filter-manager 58 | (:background-copy 32) 59 | :configuration 60 | :state-management 61 | :meta-directory 62 | :windows-update 63 | :directory-service 64 | :graphics 65 | :shell 66 | :tpm-services 67 | :tpm-software 68 | (:pla 48) 69 | :fve 70 | :fwp 71 | :winrm 72 | :ndis 73 | :usermode-virtualization 74 | :usermode-volmgr 75 | :bcd 76 | :usermode-vhd 77 | :sdiag 78 | :web-services 79 | (:windows-defender 80) 80 | :opc 81 | (:d3d #x76) 82 | (:dsound #x78) 83 | (:d3d10 #x79) 84 | (:dxgi #x7a) 85 | (:d3d11 #x7c) 86 | (:dwrite #x98) 87 | (:d2d #x99)) 88 | 89 | (declaim (inline make-hresult)) 90 | (defun make-hresult (errorp facility code) 91 | (logior (if errorp #x80000000 #x00000000) 92 | (ash (logand (convert facility 'facility) #x7FF) 16) 93 | (logand #xFFFF code))) 94 | 95 | (defun hresult-from-win32 (error-code) 96 | (make-hresult (/= 0 error-code) 97 | :win32 error-code)) 98 | 99 | (defun hresult-from-nt (error-code) 100 | (logior (logand #xFFFFFFFF error-code) 101 | #x10000000)) 102 | 103 | (declaim (inline hresult-error-p)) 104 | (defun hresult-error-p (hresult) 105 | (declare (type dword hresult)) 106 | (logbitp 31 hresult)) 107 | 108 | (declaim (inline hresult-facility)) 109 | (defun hresult-facility (hresult) 110 | (declare (type dword hresult)) 111 | (translate (logand #x7FF (ash hresult -16)) 112 | 'facility)) 113 | 114 | (declaim (inline hresult-code)) 115 | (defun hresult-code (hresult) 116 | (declare (type dword hresult)) 117 | (logand #xFFFF hresult)) 118 | 119 | (define-condition windows-condition (condition) 120 | ((code :initarg :code 121 | :accessor windows-condition-code 122 | :initform 0)) 123 | (:report print-windows-condition)) 124 | 125 | (defun print-windows-condition (condition &optional (stream *standard-output*)) 126 | (declare (type windows-condition condition) 127 | (type stream stream)) 128 | (let ((code (windows-condition-code condition))) 129 | (pprint-logical-block (stream nil) 130 | (format stream "Status: ~:[Success~;Failure~]" (hresult-error-p code)) 131 | (pprint-newline :mandatory stream) 132 | (format stream "Facility: ~a" (if (logbitp 30 code) "NT" (hresult-facility code))) 133 | (pprint-newline :mandatory stream) 134 | (format stream "Code: #x~4,'0X" (hresult-code code)) 135 | (let ((message (or (and (= code 1) 136 | "Successful but nonstandard completion of operation.") 137 | (let ((code (if (eq :win32 (hresult-facility code)) 138 | (hresult-code code) 139 | code))) 140 | (with-pointer (pp &0 'pointer) 141 | (when (/= 0 (external-function-call 142 | #+doors.unicode "FormatMessageW" 143 | #-doors.unicode "FormatMessageA" 144 | ((:stdcall kernel32) 145 | (dword) 146 | (dword flags :aux #x1300) 147 | (pointer source :aux) 148 | (dword message-id :aux code) 149 | (dword language-id :aux 150 | #+doors.unicode 0 151 | #-doors.unicode #x00000409) 152 | (pointer buffer :aux pp) 153 | (dword size :aux) 154 | (pointer args :aux)))) 155 | (unwind-protect 156 | (deref pp '(& tstring)) 157 | (external-function-call 158 | "LocalFree" 159 | ((:stdcall kernel32) 160 | (void) 161 | (pointer)) 162 | (deref pp '*)))))) 163 | (gethash code *result-descriptions*)))) 164 | (unless (null message) 165 | (pprint-newline :mandatory stream) 166 | (with-input-from-string (in message) 167 | (loop :for l = (read-line in nil nil) 168 | :while l :do 169 | (write-string l stream) 170 | (pprint-newline :mandatory stream))))))) 171 | condition) 172 | 173 | (defmacro define-results (name (&rest superclasses) 174 | (&rest slots) 175 | (&rest codes) 176 | &rest options) 177 | (let* ((conc-name-spec (assoc :conc-name options)) 178 | (conc-name (if conc-name-spec 179 | (or (second conc-name-spec) "") 180 | (format nil "~a-" name)))) 181 | `(progn 182 | ,@(loop :for code-spec :in codes 183 | :append (destructuring-bind 184 | (code-name code-value &optional (code-description nil desc-p)) 185 | code-spec 186 | (check-type code-name symbol) 187 | (when desc-p 188 | (check-type code-description string)) 189 | (let ((value (when (constantp code-value) 190 | (eval code-value)))) 191 | (unless (integerp value) 192 | (error "Invalid result code value: ~s" code-spec)) 193 | `((defconstant ,(intern (format nil "~a~a" (string conc-name) 194 | code-name)) 195 | ,value) 196 | (eval-when (:compile-toplevel :load-toplevel :execute) 197 | (setf (gethash ,value *registered-results*) 198 | ',name 199 | (gethash ,value *result-descriptions*) 200 | ,code-description)))))) 201 | (define-condition ,name (,@superclasses windows-condition) 202 | ,slots 203 | ,@(remove :conc-name options :key #'car)) 204 | ',name))) 205 | 206 | (deftype hresult () '(or null windows-condition)) 207 | 208 | (define-immediate-type hresult-type () 209 | ((condition-class :initform nil :initarg :condition-class 210 | :reader hresult-type-condition-class)) 211 | (:base-type dword) 212 | (:lisp-type (type) '(or null windows-condition)) 213 | (:prototype (type) nil) 214 | (:prototype-expansion (type) nil) 215 | (:converter (value type) 216 | (if (null value) 217 | 0 218 | (slot-value value 'code))) 219 | (:translator (value type) 220 | (if (zerop value) 221 | nil 222 | (let* ((errorp (logbitp 31 value)) 223 | (condition-name (or (hresult-type-condition-class type) 224 | (gethash value *registered-results*))) 225 | (condition (make-condition 226 | (or condition-name 227 | (if errorp 'windows-error 'windows-status)) 228 | :code value))) 229 | (if errorp 230 | (error condition) 231 | (warn condition))))) 232 | (:converter-expansion (value type) 233 | (once-only (value) 234 | `(if (null ,value) 235 | 0 236 | (slot-value ,value 'code)))) 237 | (:translator-expansion (value type) 238 | (with-gensyms (code errorp condition-name condition) 239 | `(let ((,code ,value)) 240 | (declare (type dword ,code)) 241 | (if (zerop ,code) 242 | nil 243 | (let* ((,errorp (logbitp 31 ,code)) 244 | (,condition-name (or ',(hresult-type-condition-class type) 245 | (gethash ,code *registered-results*))) 246 | (,condition (make-condition 247 | (or ,condition-name 248 | (if ,errorp 'windows-error 'windows-status)) 249 | :code ,code))) 250 | (if ,errorp 251 | (error ,condition) 252 | (warn ,condition))))))) 253 | (:cleaner-expansion (pointer value type) nil) 254 | (:allocator-expansion (value type) `(alloc 'dword)) 255 | (:deallocator-expansion (pointer type) `(free ,pointer 'dword))) 256 | 257 | (define-type-parser hresult (&optional condition-class) 258 | (check-type condition-class symbol) 259 | (make-instance 'hresult-type :condition-class condition-class)) 260 | 261 | (defmethod unparse-type ((type hresult-type)) 262 | (let ((condition-class (hresult-type-condition-class type))) 263 | (if condition-class 264 | `(hresult ,condition-class) 265 | 'hresult))) 266 | -------------------------------------------------------------------------------- /system/libraries.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (define-foreign-library ntdll 28 | (T (:default "ntdll"))) 29 | 30 | (define-foreign-library kernel32 31 | (T (:default "kernel32"))) 32 | 33 | (define-foreign-library user32 34 | (T (:default "user32"))) 35 | 36 | (define-foreign-library comctl32 37 | (T (:default "comctl32"))) 38 | 39 | (define-foreign-library gdi32 40 | (T (:default "gdi32"))) 41 | 42 | (define-foreign-library ws2-32 43 | (T (:default "ws2_32"))) 44 | 45 | (define-foreign-library advapi32 46 | (T (:default "advapi32"))) 47 | 48 | (define-foreign-library psapi 49 | (t (:default "psapi"))) 50 | 51 | (define-foreign-library ole32 52 | (t (:default "ole32"))) 53 | 54 | (define-foreign-library oleaut32 55 | (t (:default "oleaut32"))) 56 | 57 | (define-foreign-library secur32 58 | (t (:default "secur32"))) 59 | 60 | (use-foreign-library ntdll) 61 | (use-foreign-library kernel32) 62 | (use-foreign-library user32) 63 | (use-foreign-library comctl32) 64 | (use-foreign-library gdi32) 65 | (use-foreign-library ws2-32) 66 | (use-foreign-library advapi32) 67 | (use-foreign-library psapi) 68 | (use-foreign-library ole32) 69 | (use-foreign-library oleaut32) 70 | (use-foreign-library secur32) 71 | -------------------------------------------------------------------------------- /system/memory.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (define-enum (memory-protection-flags 28 | (:base-type dword) 29 | (:list t) 30 | (:conc-name page-)) 31 | (:execute #x10) 32 | (:execute-read #x20) 33 | (:execute-read-write #x40) 34 | (:execute-read-write-copy #x80) 35 | (:no-access #x1) 36 | (:read-only #x02) 37 | (:read-write #x04) 38 | (:write-copy #x08) 39 | (:guard #x100) 40 | (:no-cache #x200) 41 | (:write-combine #x400)) 42 | -------------------------------------------------------------------------------- /system/osversion.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (define-enum (version-suite (:conc-name ver-suite-) 28 | (:list t) 29 | (:base-type word)) 30 | (:backoffice #x00000004) 31 | (:blade #x00000400) 32 | (:compute-server #x00004000) 33 | (:datacenter #x00000080) 34 | (:enterprise #x00000002) 35 | (:embedded-nt #x00000040) 36 | (:personal #x00000200) 37 | (:single-user-ts #x00000100) 38 | (:small-business #x00000001) 39 | (:small-business-restricted #x00000020) 40 | (:storage-server #x00002000) 41 | (:terminal #x00000010) 42 | (:communications #x00000008) 43 | (:embedded-restricted #x00000800) 44 | (:security-appliance #x00001000) 45 | (:home-server #x00008000)) 46 | 47 | (defconstant ver-server-nt #x80000000) 48 | (defconstant ver-workstation-nt #x40000000) 49 | 50 | (define-enum (version-product-type 51 | (:conc-name ver-nt-) 52 | (:list t) 53 | (:base-type byte)) 54 | (:domain-controller #x00000002) 55 | (:server #x00000003) 56 | (:workstation #x00000001)) 57 | 58 | (define-struct (os-version-info 59 | (:constructor make-os-version-info 60 | (&key major-version minor-version 61 | build-number platform-id 62 | csd-version 63 | service-pack-major 64 | service-pack-minor 65 | suite-mask 66 | product-type)) 67 | (:conc-name osverinfo-)) 68 | (size dword :initform (sizeof 'os-version-info)) 69 | (major-version dword) 70 | (minor-version dword) 71 | (build-number dword) 72 | (platform-id (enum (:base-type dword) 73 | (:nt 2))) 74 | (csd-version (tstring 128)) 75 | (service-pack-major word) 76 | (service-pack-minor word) 77 | (suite-mask version-suite) 78 | (product-type version-product-type) 79 | (reserved byte)) 80 | 81 | (define-external-function 82 | ("GetVersion" os-version) 83 | (:stdcall kernel32) 84 | (dword rv (if (zerop rv) 85 | (error "Error requesting Windows version") 86 | rv))) 87 | 88 | (define-symbol-macro os-version (os-version)) 89 | 90 | (load-time-value 91 | (defconstant winnt-version (let ((v os-version)) 92 | (logior (high-byte (low-word v)) 93 | (ash (low-byte (low-word v)) 8))))) 94 | 95 | (define-external-function 96 | (#+doors.unicode "GetVersionExW" 97 | #-doors.unicode "GetVersionExA" 98 | os-version*) 99 | (:stdcall kernel32) 100 | (bool rv (if rv 101 | version-info 102 | (error "Error requesting Windows NT version"))) 103 | (version-info (& os-version-info :inout) :aux)) 104 | 105 | (define-symbol-macro os-version* (os-version*)) 106 | 107 | (let ((info os-version*)) 108 | (pushnew (case (osverinfo-major-version info) 109 | (5 (case (osverinfo-minor-version info) 110 | (0 :win2000) 111 | (1 :winxp) 112 | (2 (cond 113 | ((member :workstation (osverinfo-product-type info)) 114 | :winxp64) 115 | ((member :home-server (osverinfo-suite-mask info)) 116 | :winhomeserver) 117 | (T :winserver2003))))) 118 | (6 (case (osverinfo-minor-version info) 119 | (0 (if (member :workstation (osverinfo-product-type info)) 120 | :winvista 121 | :winserver2008)) 122 | (1 (if (member :workstation (osverinfo-product-type info)) 123 | :win7 124 | :winserver2008r2)) 125 | (2 (if (member :workstation (osverinfo-product-type info)) 126 | :win8 127 | :winserver2012)) 128 | (3 (if (member :workstation (osverinfo-product-type info)) 129 | :win8.1 130 | :winserver2012r2)) 131 | (T :windows))) 132 | (10 (case (osverinfo-minor-version info) 133 | (0 (if (member :workstation (osverinfo-product-type info)) 134 | :win10 135 | :winserver2016)))) 136 | (T (error "Unsupported system"))) 137 | *features*)) 138 | -------------------------------------------------------------------------------- /system/registry.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (define-enum (registry-rights 28 | (:base-type dword) 29 | (:conc-name key)) 30 | (:all-access #xF003F) 31 | (:create-link #x0020) 32 | (:create-sub-key #x0004) 33 | (:enumerate-sub-keys #x0008) 34 | (:execute #x20019) 35 | (:notify #x0010) 36 | (:query-value #x0001) 37 | (:read #x20019) 38 | (:set-value #x0002) 39 | (:wow64-32-key #x0200) 40 | (:wow64-64-key #x0100) 41 | (:write #x20006) 42 | (:delete #x10000) 43 | (:read-control #x20000) 44 | (:write-owner #x80000) 45 | (:write-dac #x40000)) 46 | 47 | (define-symbol-macro hkey-classes-root (& #x80000000)) 48 | (define-symbol-macro hkey-current-user (& #x80000001)) 49 | (define-symbol-macro hkey-local-machine (& #x80000002)) 50 | (define-symbol-macro hkey-users (& #x80000003)) 51 | (define-symbol-macro hkey-performance-data (& #x80000004)) 52 | (define-symbol-macro hkey-performance-text (& #x80000050)) 53 | (define-symbol-macro hkey-performance-nls-text (& #x80000060)) 54 | (define-symbol-macro hkey-current-config (& #x80000005)) 55 | (define-symbol-macro hkey-dyn-data (& #x80000006)) 56 | 57 | (define-enum (registry-value-type 58 | (:conc-name reg-) 59 | (:base-type dword)) 60 | :none 61 | :sz 62 | :expand-sz 63 | :binary 64 | :dword 65 | :dword-big-endian 66 | :link 67 | :multi-sz 68 | :resource-list 69 | :full-resource-descriptor 70 | :resource-requirements-list 71 | :qword) 72 | 73 | (define-enum (registry-type-restrictions 74 | (:base-type dword) 75 | (:list t) 76 | (:conc-name reg-rt-)) 77 | (:none #x00000001) 78 | (:any #x0000FFFF) 79 | (:sz #x00000002) 80 | (:expand-sz #x00000004) 81 | (:binary #x00000008) 82 | (:dword #x00000010) 83 | (:multi-sz #x00000020) 84 | (:qword #x00000040) 85 | (:no-expand #x10000000) 86 | (:zero-on-failure #x20000000)) 87 | 88 | (define-external-function 89 | (#+doors.unicode "RegOpenKeyExW" 90 | #-doors.unicode "RegOpenKeyExA" 91 | open-reg-key*) 92 | (:stdcall advapi32) 93 | (long rv (if (zerop rv) 94 | result 95 | (error 'windows-error :code (hresult-from-win32 rv)))) 96 | "Opens the specified registry key. Note that key names are not case sensitive." 97 | (key handle) 98 | (subkey (& tstring :in t) :optional) 99 | (reserved dword :aux 0) 100 | (desired-access registry-rights) 101 | (result (& handle :out) :aux)) 102 | 103 | (define-external-function 104 | (#+doors.unicode "RegQueryValueExW" 105 | #-doors.unicode "RegQueryValueExA" 106 | query-reg-value*) 107 | (:stdcall advapi32) 108 | (long rv (if (zerop rv) 109 | (values buffer-size type) 110 | (error 'windows-error :code (hresult-from-win32 rv)))) 111 | "Retrieves the type and data for the specified value name associated with an open registry key." 112 | (key handle) 113 | (value (& tstring :in t) :key) 114 | (reserved pointer :aux &0) 115 | (type (& registry-value-type :out) :aux) 116 | (data-buffer pointer) 117 | (buffer-size (& dword :inout))) 118 | 119 | #-(or win2000 winxp winserver2003 winhomeserver) 120 | (define-external-function 121 | (#+doors.unicode "RegGetValueW" 122 | #-doors.unicode "RegGetValueA" 123 | reg-value) 124 | (:stdcall advapi32) 125 | (long rv (if (zerop rv) 126 | (values buffer-size type) 127 | (error 'windows-error :code (hresult-from-win32 rv)))) 128 | "Retrieves the type and data for the specified registry value." 129 | (key handle) 130 | (subkey (& tstring :in t) :key) 131 | (value (& tstring :in t) :key) 132 | (flags registry-type-restrictions :key) 133 | (type (& registry-value-type :out) :aux) 134 | (data-buffer pointer) 135 | (buffer-size (& dword :inout))) 136 | -------------------------------------------------------------------------------- /system/threads.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (define-external-function 28 | ("AttachThreadInput" (:camel-case)) 29 | (:stdcall user32) 30 | (bool rv (if rv 31 | attach 32 | #-(or win2000 winxp winxp64 winserver2003 winhomeserver) 33 | (error 'windows-error :code (hresult-from-win32 last-error)) 34 | #+(or win2000 winxp winxp64 winserver2003 winhomeserver) 35 | (error 'windows-error :code error-invalid-arg))) 36 | "Attaches or detaches the input processing mechanism of one thread to that of another thread." 37 | (id-attach dword) 38 | (id-attach-to dword) 39 | (attach boolean)) 40 | 41 | (define-external-function 42 | ("GetCurrentThreadId" current-thread-id) 43 | (:stdcall kernel32) 44 | (dword) 45 | "Retrieves the thread identifier of the calling thread.") 46 | 47 | (define-symbol-macro current-thread-id (current-thread-id)) 48 | -------------------------------------------------------------------------------- /system/wintypes.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors) 26 | 27 | (defalias word () 'uint16) 28 | (deftype word () 'uint16) 29 | 30 | (defalias dword () 'uint32) 31 | (deftype dword () 'uint32) 32 | 33 | (defalias qword () 'uint64) 34 | (deftype qword () 'uint64) 35 | 36 | (defalias wparam () 'uint-ptr) 37 | (deftype wparam () 'uint-ptr) 38 | (defalias lparam () 'int-ptr) 39 | (deftype lparam () 'int-ptr) 40 | (defalias lresult () 'int-ptr) 41 | (deftype lresult () 'int-ptr) 42 | 43 | (defalias long-ptr () 'int-ptr) 44 | (deftype long-ptr () 'int-ptr) 45 | (defalias ulong-ptr () 'uint-ptr) 46 | (deftype ulong-ptr () 'uint-ptr) 47 | 48 | (defalias atom () 'word) 49 | (defconstant invalid-atom 0) 50 | (declaim (inline valid-atom-p)) 51 | (defun valid-atom-p (atom) 52 | (declare (type word atom)) 53 | (not (zerop atom))) 54 | 55 | (deftype handle () '(or null pointer)) 56 | 57 | (define-immediate-type handle-type () 58 | () 59 | (:simple-parser handle) 60 | (:base-type pointer) 61 | (:lisp-type (type) 'handle) 62 | (:prototype (type) nil) 63 | (:prototype-expansion (type) nil) 64 | (:converter (value type) 65 | (or value &0)) 66 | (:translator (value type) 67 | (and (&? value) value)) 68 | (:converter-expansion (value type) 69 | `(or ,value &0)) 70 | (:translator-expansion (value type) 71 | (with-gensyms (handle) 72 | `(let ((,handle ,value)) 73 | (declare (type pointer ,handle)) 74 | (and (&? ,handle) ,handle)))) 75 | (:allocator-expansion (value type) 76 | `(alloc '*)) 77 | (:deallocator-expansion (pointer type) 78 | `(free ,pointer '*)) 79 | (:cleaner-expansion (pointer value type) 80 | nil)) 81 | 82 | (define-symbol-macro invalid-handle-value (& #xFFFFFFFF)) 83 | (declaim (inline valid-handle-p)) 84 | (defun valid-handle-p (handle) 85 | (declare (type handle handle)) 86 | (or (null handle) 87 | (not (&= handle invalid-handle-value)))) 88 | 89 | (defalias astring (&optional length) 90 | `(string :encoding :ascii 91 | :byte-length ,(if length 92 | (* length (sizeof 'char)) 93 | nil))) 94 | (defalias wstring (&optional length) 95 | `(string :encoding :utf-16le 96 | :byte-length ,(if length 97 | (* length (sizeof 'wchar)) 98 | nil))) 99 | 100 | (defalias tstring (&optional length) 101 | #+doors.unicode `(wstring ,length) 102 | #-doors.unicode `(astring ,length)) 103 | 104 | (defalias tchar () 105 | #+doors.unicode 'wchar 106 | #-doors.unicode 'char) 107 | 108 | (declaim (inline make-word)) 109 | (defun make-word (low high) 110 | (declare (type integer low high)) 111 | (logior (logand low #xFF) 112 | (ash (logand high #xFF) 8))) 113 | 114 | (declaim (inline make-short)) 115 | (defun make-short (low high) 116 | (declare (type integer low high)) 117 | (let ((u (make-word low high))) 118 | (declare (type word u)) 119 | (the int16 120 | (if (logbitp 15 u) 121 | (lognot (logand #xFFFF (lognot u))) 122 | u)))) 123 | 124 | (declaim (inline make-dword)) 125 | (defun make-dword (low high) 126 | (declare (type integer low high)) 127 | (logand #xFFFFFFFF 128 | (logior (logand low #xFFFF) 129 | (ash (logand high #xFFFF) 16)))) 130 | 131 | (declaim (inline make-long)) 132 | (defun make-long (low high) 133 | (declare (type integer low high)) 134 | (let ((u (make-dword low high))) 135 | (declare (type dword u)) 136 | (the int32 137 | (if (logbitp 31 u) 138 | (lognot (logand #xFFFFFFFF (lognot u))) 139 | u)))) 140 | 141 | (declaim (inline make-qword)) 142 | (defun make-qword (low high) 143 | (declare (type integer low high)) 144 | (logand #xFFFFFFFFFFFFFFFF 145 | (logior (logand low #xFFFFFFFF) 146 | (ash (logand high #xFFFFFFFF) 32)))) 147 | 148 | (declaim (inline make-long-long)) 149 | (defun make-long-long (low high) 150 | (declare (type integer low high)) 151 | (let ((u (make-qword low high))) 152 | (declare (type qword u)) 153 | (the int64 154 | (if (logbitp 63 u) 155 | (lognot (logand #xFFFFFFFFFFFFFFFF (lognot u))) 156 | u)))) 157 | 158 | (declaim (inline low-dword)) 159 | (defun low-dword (x) 160 | (declare (type integer x)) 161 | (logand x #xFFFFFFFF)) 162 | 163 | (declaim (inline high-dword)) 164 | (defun high-dword (x) 165 | (declare (type integer x)) 166 | (logand (ash x -32) #xFFFFFFFF)) 167 | 168 | (declaim (inline low-word)) 169 | (defun low-word (x) 170 | (declare (type integer x)) 171 | (logand x #xFFFF)) 172 | 173 | (declaim (inline high-word)) 174 | (defun high-word (x) 175 | (declare (type integer x)) 176 | (logand (ash x -16) #xFFFF)) 177 | 178 | (declaim (inline low-byte)) 179 | (defun low-byte (x) 180 | (declare (type integer x)) 181 | (logand x #xFF)) 182 | 183 | (declaim (inline high-byte)) 184 | (defun high-byte (x) 185 | (declare (type integer x)) 186 | (logand (ash x -8) #xFF)) 187 | 188 | (defconstant unicode-string-max-bytes 65534) 189 | (defconstant unicode-string-max-chars 32767) 190 | 191 | (define-translatable-type pascal-string-type () 192 | () 193 | (:simple-parser pascal-string) 194 | (:size (val type) 195 | (1+ (length val))) 196 | (:size-expansion (val type) 197 | `(1+ (length ,val))) 198 | (:align (type) 1) 199 | (:prototype (type) "") 200 | (:prototype-expansion (type) "") 201 | (:reader (ptr out type) 202 | (let ((len (deref ptr 'byte))) 203 | (read-cstring ptr :out out :byte-length len 204 | :encoding :ascii 205 | :offset 1))) 206 | (:reader-expansion (pointer out type) 207 | (once-only ((pointer `(the pointer ,pointer))) 208 | (with-gensyms (length) 209 | `(let ((,length (deref ,pointer 'byte))) 210 | (read-cstring ,pointer :out ,out :byte-length ,length 211 | :encoding :ascii 212 | :offset 1))))) 213 | (:writer (val ptr type) 214 | (let ((len (length val))) 215 | (setf (deref ptr 'byte) len) 216 | (write-cstring val ptr :byte-length len 217 | :encoding :ascii 218 | :offset 1))) 219 | (:writer-expansion (value pointer type) 220 | (once-only ((pointer `(the pointer ,pointer)) 221 | (value `(the string ,value))) 222 | (with-gensyms (length) 223 | `(let ((,length (length ,value))) 224 | (setf (deref ,pointer 'byte) ,length) 225 | (write-cstring ,value ,pointer :byte-length ,length 226 | :encoding :ascii 227 | :offset 1))))) 228 | (:cleaner-expansion (ptr val type) 229 | nil) 230 | (:allocator-expansion (val type) 231 | `(raw-alloc (1+ (length ,val)))) 232 | (:deallocator-expansion (ptr type) 233 | `(raw-free ,ptr))) 234 | -------------------------------------------------------------------------------- /ui/configuration.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.ui) 26 | 27 | (define-enum (system-metrics 28 | (:base-type int) 29 | (:conc-name sm-)) 30 | (:arrange 56) 31 | (:clean-boot 67) 32 | (:monitors 80) 33 | (:mouse-buttons 43) 34 | (:x-border 5) 35 | (:x-cursor 13) 36 | (:x-dlg-frame 7) 37 | (:x-double-clk 36) 38 | (:x-drag 68) 39 | (:x-edge 45) 40 | (:x-fixed-frame 7) 41 | (:x-focus-border 83) 42 | (:x-frame 32) 43 | (:x-fullscreen 16) 44 | (:x-hscroll 21) 45 | (:x-hthumb 10) 46 | (:x-icon 11) 47 | (:x-icon-spacing 38) 48 | (:x-maximized 61) 49 | (:x-max-track 59) 50 | (:x-menu-check 71) 51 | (:x-menu-size 54) 52 | (:x-min 28) 53 | (:x-minimized 57) 54 | (:x-min-spacing 47) 55 | (:x-min-track 34) 56 | (:x-padded-border 92) 57 | (:x-screen 0) 58 | (:x-size 30) 59 | (:x-size-frame 32) 60 | (:x-small-icon 49) 61 | (:x-small-size 52) 62 | (:cx-virtual-screen 78) 63 | (:x-vscroll 2) 64 | (:y-border 6) 65 | (:y-caption 4) 66 | (:y-cursor 14) 67 | (:y-dlg-frame 8) 68 | (:y-double-clk 37) 69 | (:y-drag 69) 70 | (:y-edge 46) 71 | (:y-fixed-frame 8) 72 | (:y-focus-border 84) 73 | (:y-frame 33) 74 | (:y-fullscreen 17) 75 | (:y-hscroll 3) 76 | (:y-icon 12) 77 | (:y-icon-spacing 39) 78 | (:y-kanji-window 18) 79 | (:y-maximized 62) 80 | (:y-max-track 60) 81 | (:y-menu 15) 82 | (:y-menu-check 72) 83 | (:y-menu-size 55) 84 | (:y-min 29) 85 | (:y-minimized 58) 86 | (:y-min-spacing 48) 87 | (:y-min-track 35) 88 | (:y-screen 1) 89 | (:y-size 31) 90 | (:y-size-frame 33) 91 | (:y-small-caption 51) 92 | (:y-small-icon 50) 93 | (:y-small-size 53) 94 | (:cy-virtual-screen 79) 95 | (:y-vscroll 20) 96 | (:y-vthumb 9) 97 | (:dbcs-enabled 42) 98 | (:debug 22) 99 | (:digitizer 94) 100 | (:imm-enabled 82) 101 | (:maximum-touches 95) 102 | (:media-center 87) 103 | (:menu-rop-alignment 40) 104 | (:mid-east-enabled 74) 105 | (:mouse-present 19) 106 | (:mouse-horizontal-wheel-present 91) 107 | (:mouse-wheel-present 75) 108 | (:network 63) 109 | (:pen-windows 41) 110 | (:remote-control #x2001) 111 | (:remote-session #x1000) 112 | (:same-display-format 81) 113 | (:secure 44) 114 | (:server-r2 89) 115 | (:show-sounds 70) 116 | (:shutting-down #x2000) 117 | (:slow-machine 73) 118 | (:starter 88) 119 | (:swap-button 23) 120 | (:tablet-pc 86) 121 | (:x-virtual-screen 76) 122 | (:y-virtual-screen 77)) 123 | 124 | (define-external-function 125 | ("GetSystemMetrics" system-metrics) 126 | (:stdcall user32) 127 | (int) 128 | "Retrieves the specified system metric or system configuration setting." 129 | (index system-metrics)) 130 | 131 | -------------------------------------------------------------------------------- /ui/input.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.ui) 26 | 27 | (define-enum (keystroke-flag 28 | (:base-type dword) 29 | (:conc-name kf-)) 30 | (:extended #x0100) 31 | (:dlg-mode #x0800) 32 | (:menu-mode #x1000) 33 | (:alt-down #x2000) 34 | (:repeat #x4000) 35 | (:up #x8000)) 36 | 37 | (declaim (inline key-repeat-count)) 38 | (defun key-repeat-count (lparam) 39 | (declare (type lparam lparam)) 40 | (ldb (byte 16 0) lparam)) 41 | 42 | (declaim (inline key-scan-code)) 43 | (defun key-scan-code (lparam) 44 | (declare (type lparam lparam)) 45 | (ldb (byte 8 16) lparam)) 46 | 47 | (declaim (inline key-flags)) 48 | (defun key-flags (lparam) 49 | (declare (type lparam lparam)) 50 | (translate (ldb (byte 16 16) lparam) 'keystroke-flag)) 51 | 52 | (define-enum (hit-test-code 53 | (:base-type uint) 54 | (:conc-name ht)) 55 | (:foo 1)) 56 | 57 | -------------------------------------------------------------------------------- /ui/nls.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.nls) 26 | 27 | (define-enum (LANG) 28 | (:NEUTRAL #x00) 29 | (:INVARIANT #x7f) 30 | (:AFRIKAANS #x36) 31 | (:ALBANIAN #x1c) 32 | (:ARABIC #x01) 33 | (:ARMENIAN #x2b) 34 | (:ASSAMESE #x4d) 35 | (:AZERI #x2c) 36 | (:BASQUE #x2d) 37 | (:BELARUSIAN #x23) 38 | (:BENGALI #x45) 39 | (:BULGARIAN #x02) 40 | (:CATALAN #x03) 41 | (:CHINESE #x04) 42 | (:CROATIAN #x1a) 43 | (:CZECH #x05) 44 | (:DANISH #x06) 45 | (:DIVEHI #x65) 46 | (:DUTCH #x13) 47 | (:ENGLISH #x09) 48 | (:ESTONIAN #x25) 49 | (:FAEROESE #x38) 50 | (:FARSI #x29) 51 | (:FINNISH #x0b) 52 | (:FRENCH #x0c) 53 | (:GALICIAN #x56) 54 | (:GEORGIAN #x37) 55 | (:GERMAN #x07) 56 | (:GREEK #x08) 57 | (:GUJARATI #x47) 58 | (:HEBREW #x0d) 59 | (:HINDI #x39) 60 | (:HUNGARIAN #x0e) 61 | (:ICELANDIC #x0f) 62 | (:INDONESIAN #x21) 63 | (:ITALIAN #x10) 64 | (:JAPANESE #x11) 65 | (:KANNADA #x4b) 66 | (:KASHMIRI #x60) 67 | (:KAZAK #x3f) 68 | (:KONKANI #x57) 69 | (:KOREAN #x12) 70 | (:KYRGYZ #x40) 71 | (:LATVIAN #x26) 72 | (:LITHUANIAN #x27) 73 | (:MACEDONIAN #x2f) 74 | (:MALAY #x3e) 75 | (:MALAYALAM #x4c) 76 | (:MANIPURI #x58) 77 | (:MARATHI #x4e) 78 | (:MONGOLIAN #x50) 79 | (:NEPALI #x61) 80 | (:NORWEGIAN #x14) 81 | (:ORIYA #x48) 82 | (:POLISH #x15) 83 | (:PORTUGUESE #x16) 84 | (:PUNJABI #x46) 85 | (:ROMANIAN #x18) 86 | (:RUSSIAN #x19) 87 | (:SANSKRIT #x4f) 88 | (:SERBIAN #x1a) 89 | (:SINDHI #x59) 90 | (:SLOVAK #x1b) 91 | (:SLOVENIAN #x24) 92 | (:SPANISH #x0a) 93 | (:SWAHILI #x41) 94 | (:SWEDISH #x1d) 95 | (:SYRIAC #x5a) 96 | (:TAMIL #x49) 97 | (:TATAR #x44) 98 | (:TELUGU #x4a) 99 | (:THAI #x1e) 100 | (:TURKISH #x1f) 101 | (:UKRAINIAN #x22) 102 | (:URDU #x20) 103 | (:UZBEK #x43) 104 | (:VIETNAMESE #x2a)) 105 | 106 | (define-enum (sublang) 107 | (:NEUTRAL #x00) ;; language neutral 108 | (:DEFAULT #x01) ;; user default 109 | (:SYS-DEFAULT #x02) ;; system default 110 | (:ARABIC-SAUDI-ARABIA #x01) ;; Arabic (Saudi Arabia) 111 | (:ARABIC-IRAQ #x02) ;; Arabic (Iraq) 112 | (:ARABIC-EGYPT #x03) ;; Arabic (Egypt) 113 | (:ARABIC-LIBYA #x04) ;; Arabic (Libya) 114 | (:ARABIC-ALGERIA #x05) ;; Arabic (Algeria) 115 | (:ARABIC-MOROCCO #x06) ;; Arabic (Morocco) 116 | (:ARABIC-TUNISIA #x07) ;; Arabic (Tunisia) 117 | (:ARABIC-OMAN #x08) ;; Arabic (Oman) 118 | (:ARABIC-YEMEN #x09) ;; Arabic (Yemen) 119 | (:ARABIC-SYRIA #x0a) ;; Arabic (Syria) 120 | (:ARABIC-JORDAN #x0b) ;; Arabic (Jordan) 121 | (:ARABIC-LEBANON #x0c) ;; Arabic (Lebanon) 122 | (:ARABIC-KUWAIT #x0d) ;; Arabic (Kuwait) 123 | (:ARABIC-UAE #x0e) ;; Arabic (U.A.E) 124 | (:ARABIC-BAHRAIN #x0f) ;; Arabic (Bahrain) 125 | (:ARABIC-QATAR #x10) ;; Arabic (Qatar) 126 | (:AZERI-LATIN #x01) ;; Azeri (Latin) 127 | (:AZERI-CYRILLIC #x02) ;; Azeri (Cyrillic) 128 | (:CHINESE-TRADITIONAL #x01) ;; Chinese (Taiwan) 129 | (:CHINESE-SIMPLIFIED #x02) ;; Chinese (PR China) 130 | (:CHINESE-HONGKONG #x03) ;; Chinese (Hong Kong S.A.R., P.R.C.) 131 | (:CHINESE-SINGAPORE #x04) ;; Chinese (Singapore) 132 | (:CHINESE-MACAU #x05) ;; Chinese (Macau S.A.R.) 133 | (:DUTCH #x01) ;; Dutch 134 | (:DUTCH-BELGIAN #x02) ;; Dutch (Belgian) 135 | (:ENGLISH-US #x01) ;; English (USA) 136 | (:ENGLISH-UK #x02) ;; English (UK) 137 | (:ENGLISH-AUS #x03) ;; English (Australian) 138 | (:ENGLISH-CAN #x04) ;; English (Canadian) 139 | (:ENGLISH-NZ #x05) ;; English (New Zealand) 140 | (:ENGLISH-EIRE #x06) ;; English (Irish) 141 | (:ENGLISH-SOUTH-AFRICA #x07) ;; English (South Africa) 142 | (:ENGLISH-JAMAICA #x08) ;; English (Jamaica) 143 | (:ENGLISH-CARIBBEAN #x09) ;; English (Caribbean) 144 | (:ENGLISH-BELIZE #x0a) ;; English (Belize) 145 | (:ENGLISH-TRINIDAD #x0b) ;; English (Trinidad) 146 | (:ENGLISH-ZIMBABWE #x0c) ;; English (Zimbabwe) 147 | (:ENGLISH-PHILIPPINES #x0d) ;; English (Philippines) 148 | (:FRENCH #x01) ;; French 149 | (:FRENCH-BELGIAN #x02) ;; French (Belgian) 150 | (:FRENCH-CANADIAN #x03) ;; French (Canadian) 151 | (:FRENCH-SWISS #x04) ;; French (Swiss) 152 | (:FRENCH-LUXEMBOURG #x05) ;; French (Luxembourg) 153 | (:FRENCH-MONACO #x06) ;; French (Monaco) 154 | (:GERMAN #x01) ;; German 155 | (:GERMAN-SWISS #x02) ;; German (Swiss) 156 | (:GERMAN-AUSTRIAN #x03) ;; German (Austrian) 157 | (:GERMAN-LUXEMBOURG #x04) ;; German (Luxembourg) 158 | (:GERMAN-LIECHTENSTEIN #x05) ;; German (Liechtenstein) 159 | (:ITALIAN #x01) ;; Italian 160 | (:ITALIAN-SWISS #x02) ;; Italian (Swiss) 161 | (:KASHMIRI-SASIA #x02) ;; Kashmiri (South Asia) 162 | (:KASHMIRI-INDIA #x02) ;; For app compatibility only 163 | (:KOREAN #x01) ;; Korean (Extended Wansung) 164 | (:LITHUANIAN #x01) ;; Lithuanian 165 | (:MALAY-MALAYSIA #x01) ;; Malay (Malaysia) 166 | (:MALAY-BRUNEI-DARUSSALAM #x02) ;; Malay (Brunei Darussalam) 167 | (:NEPALI-INDIA #x02) ;; Nepali (India) 168 | (:NORWEGIAN-BOKMAL #x01) ;; Norwegian (Bokmal) 169 | (:NORWEGIAN-NYNORSK #x02) ;; Norwegian (Nynorsk) 170 | (:PORTUGUESE #x02) ;; Portuguese 171 | (:PORTUGUESE-BRAZILIAN #x01) ;; Portuguese (Brazilian) 172 | (:SERBIAN-LATIN #x02) ;; Serbian (Latin) 173 | (:SERBIAN-CYRILLIC #x03) ;; Serbian (Cyrillic) 174 | (:SPANISH #x01) ;; Spanish (Castilian) 175 | (:SPANISH-MEXICAN #x02) ;; Spanish (Mexican) 176 | (:SPANISH-MODERN #x03) ;; Spanish (Spain) 177 | (:SPANISH-GUATEMALA #x04) ;; Spanish (Guatemala) 178 | (:SPANISH-COSTA-RICA #x05) ;; Spanish (Costa Rica) 179 | (:SPANISH-PANAMA #x06) ;; Spanish (Panama) 180 | (:SPANISH-DOMINICAN-REPUBLIC #x07) ;; Spanish (Dominican Republic) 181 | (:SPANISH-VENEZUELA #x08) ;; Spanish (Venezuela) 182 | (:SPANISH-COLOMBIA #x09) ;; Spanish (Colombia) 183 | (:SPANISH-PERU #x0a) ;; Spanish (Peru) 184 | (:SPANISH-ARGENTINA #x0b) ;; Spanish (Argentina) 185 | (:SPANISH-ECUADOR #x0c) ;; Spanish (Ecuador) 186 | (:SPANISH-CHILE #x0d) ;; Spanish (Chile) 187 | (:SPANISH-URUGUAY #x0e) ;; Spanish (Uruguay) 188 | (:SPANISH-PARAGUAY #x0f) ;; Spanish (Paraguay) 189 | (:SPANISH-BOLIVIA #x10) ;; Spanish (Bolivia) 190 | (:SPANISH-EL-SALVADOR #x11) ;; Spanish (El Salvador) 191 | (:SPANISH-HONDURAS #x12) ;; Spanish (Honduras) 192 | (:SPANISH-NICARAGUA #x13) ;; Spanish (Nicaragua) 193 | (:SPANISH-PUERTO-RICO #x14) ;; Spanish (Puerto Rico) 194 | (:SWEDISH #x01) ;; Swedish 195 | (:SWEDISH-FINLAND #x02) ;; Swedish (Finland) 196 | (:URDU-PAKISTAN #x01) ;; Urdu (Pakistan) 197 | (:URDU-INDIA #x02) ;; Urdu (India) 198 | (:UZBEK-LATIN #x01) ;; Uzbek (Latin) 199 | (:UZBEK-CYRILLIC #x02)) ;; Uzbek (Cyrillic) 200 | 201 | (define-enum (lang-sort (:conc-name sort-)) 202 | (:default 0) 203 | (:japanese-xjis 0) 204 | (:japanese-unicode 1) 205 | (:chinese-big5 0) 206 | (:chinese-prcp 0) 207 | (:chinese-unicode 1) 208 | (:chinese-prc 2) 209 | (:chinese-bopomofo 3) 210 | (:korean-ksc 0) 211 | (:korean-unicode 1) 212 | (:german-phone-book 1) 213 | (:hungarian-default 0) 214 | (:hungarian-technical 1) 215 | (:georgian-traditional 0) 216 | (:georgian-modern 1)) 217 | -------------------------------------------------------------------------------- /ui/packages.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:cl-user) 26 | 27 | (defpackage #:doors.ui 28 | (:use #:cl #:alexandria #:virgil #:doors #:doors.gdi) 29 | (:export 30 | ;;window classes 31 | #:class-style 32 | #:cs-byte-align-center 33 | #:cs-byte-align-window 34 | #:cs-class-dc 35 | #:cs-dbl-clks 36 | #:cs-drop-shadow 37 | #:cs-global-class 38 | #:cs-hredraw 39 | #:cs-no-close 40 | #:cs-own-dc 41 | #:cs-parent-dc 42 | #:cs-save-bits 43 | #:cs-vredraw 44 | #:wndclass 45 | #:make-wndclass 46 | #:wndclass-style 47 | #:wndclass-wndproc 48 | #:wndclass-cls-extra 49 | #:wndclass-wnd-extra 50 | #:wndclass-instance 51 | #:wndclass-icon 52 | #:wndclass-cursor 53 | #:wndclass-background 54 | #:wndclass-menu-name 55 | #:wndclass-class-name 56 | #:wndclass* 57 | #:make-wndclass* 58 | #:wndclass-style* 59 | #:wndclass-wndproc* 60 | #:wndclass-cls-extra* 61 | #:wndclass-wnd-extra* 62 | #:wndclass-instance* 63 | #:wndclass-icon* 64 | #:wndclass-cursor* 65 | #:wndclass-background* 66 | #:wndclass-menu-name 67 | #:wndclass-class-name* 68 | #:wndclass-small-icon 69 | #:system-color 70 | #:color-3d-dk-shadow 71 | #:color-3d-face 72 | #:color-3d-highlight 73 | #:color-3d-hilight 74 | #:color-3d-light 75 | #:color-3d-shadow 76 | #:color-active-border 77 | #:color-active-caption 78 | #:color-app-workspace 79 | #:color-background 80 | #:color-btn-face 81 | #:color-btn-highlight 82 | #:color-btn-hilight 83 | #:color-btn-shadow 84 | #:color-btn-text 85 | #:color-caption-text 86 | #:color-desktop 87 | #:color-gradient-active-caption 88 | #:color-gradient-inactive-caption 89 | #:color-gray-text 90 | #:color-highlight 91 | #:color-highlight-text 92 | #:color-hotlight 93 | #:color-inactive-border 94 | #:color-inactive-caption 95 | #:color-inactive-caption-text 96 | #:color-info-bk 97 | #:color-info-text 98 | #:color-menu 99 | #:color-menu-hilight 100 | #:color-menu-bar 101 | #:color-menu-text 102 | #:color-scrollbar 103 | #:color-window 104 | #:color-window-frame 105 | #:color-window-text 106 | #:class-info 107 | #:class-info* 108 | #:class-long 109 | #:class-long-ptr 110 | #:window-class-name 111 | #:class-word 112 | #:window-long 113 | #:window-long-ptr 114 | #:register-class 115 | #:register-class* 116 | #:unregister-class 117 | 118 | ;;windows 119 | #:msg 120 | #:make-msg 121 | #:msg-hwnd 122 | #:msg-message 123 | #:msg-wparam 124 | #:msg-lparam 125 | #:msg-time 126 | #:msg-pt 127 | #:dispatch-message 128 | #:translate-message 129 | #:get-message 130 | #:post-quit-message 131 | 132 | 133 | )) 134 | 135 | #| 136 | (defpackage #:doors.nls 137 | (:use #:cl #:alexandria #:virgil #:doors) 138 | (:export 139 | 140 | ;;internationalization features 141 | #:lang 142 | #:LANG-NEUTRAL 143 | #:LANG-INVARIANT 144 | #:LANG-AFRIKAANS 145 | #:LANG-ALBANIAN 146 | #:LANG-ARABIC 147 | #:LANG-ARMENIAN 148 | #:LANG-ASSAMESE 149 | #:LANG-AZERI 150 | #:LANG-BASQUE 151 | #:LANG-BELARUSIAN 152 | #:LANG-BENGALI 153 | #:LANG-BULGARIAN 154 | #:LANG-CATALAN 155 | #:LANG-CHINESE 156 | #:LANG-CROATIAN 157 | #:LANG-CZECH 158 | #:LANG-DANISH 159 | #:LANG-DIVEHI 160 | #:LANG-DUTCH 161 | #:LANG-ENGLISH 162 | #:LANG-ESTONIAN 163 | #:LANG-FAEROESE 164 | #:LANG-FARSI 165 | #:LANG-FINNISH 166 | #:LANG-FRENCH 167 | #:LANG-GALICIAN 168 | #:LANG-GEORGIAN 169 | #:LANG-GERMAN 170 | #:LANG-GREEK 171 | #:LANG-GUJARATI 172 | #:LANG-HEBREW 173 | #:LANG-HINDI 174 | #:LANG-HUNGARIAN 175 | #:LANG-ICELANDIC 176 | #:LANG-INDONESIAN 177 | #:LANG-ITALIAN 178 | #:LANG-JAPANESE 179 | #:LANG-KANNADA 180 | #:LANG-KASHMIRI 181 | #:LANG-KAZAK 182 | #:LANG-KONKANI 183 | #:LANG-KOREAN 184 | #:LANG-KYRGYZ 185 | #:LANG-LATVIAN 186 | #:LANG-LITHUANIAN 187 | #:LANG-MACEDONIAN 188 | #:LANG-MALAY 189 | #:LANG-MALAYALAM 190 | #:LANG-MANIPURI 191 | #:LANG-MARATHI 192 | #:LANG-MONGOLIAN 193 | #:LANG-NEPALI 194 | #:LANG-NORWEGIAN 195 | #:LANG-ORIYA 196 | #:LANG-POLISH 197 | #:LANG-PORTUGUESE 198 | #:LANG-PUNJABI 199 | #:LANG-ROMANIAN 200 | #:LANG-RUSSIAN 201 | #:LANG-SANSKRIT 202 | #:LANG-SERBIAN 203 | #:LANG-SINDHI 204 | #:LANG-SLOVAK 205 | #:LANG-SLOVENIAN 206 | #:LANG-SPANISH 207 | #:LANG-SWAHILI 208 | #:LANG-SWEDISH 209 | #:LANG-SYRIAC 210 | #:LANG-TAMIL 211 | #:LANG-TATAR 212 | #:LANG-TELUGU 213 | #:LANG-THAI 214 | #:LANG-TURKISH 215 | #:LANG-UKRAINIAN 216 | #:LANG-URDU 217 | #:LANG-UZBEK 218 | #:LANG-VIETNAMESE 219 | 220 | #:sublang 221 | #:SUBLANG-NEUTRAL ;; language neutral 222 | #:SUBLANG-DEFAULT ;; user default 223 | #:SUBLANG-SYS-DEFAULT ;; system default 224 | #:SUBLANG-ARABIC-SAUDI-ARABIA ;; Arabic (Saudi Arabia) 225 | #:SUBLANG-ARABIC-IRAQ ;; Arabic (Iraq) 226 | #:SUBLANG-ARABIC-EGYPT ;; Arabic (Egypt) 227 | #:SUBLANG-ARABIC-LIBYA ;; Arabic (Libya) 228 | #:SUBLANG-ARABIC-ALGERIA ;; Arabic (Algeria) 229 | #:SUBLANG-ARABIC-MOROCCO ;; Arabic (Morocco) 230 | #:SUBLANG-ARABIC-TUNISIA ;; Arabic (Tunisia) 231 | #:SUBLANG-ARABIC-OMAN ;; Arabic (Oman) 232 | #:SUBLANG-ARABIC-YEMEN ;; Arabic (Yemen) 233 | #:SUBLANG-ARABIC-SYRIA ;; Arabic (Syria) 234 | #:SUBLANG-ARABIC-JORDAN ;; Arabic (Jordan) 235 | #:SUBLANG-ARABIC-LEBANON ;; Arabic (Lebanon) 236 | #:SUBLANG-ARABIC-KUWAIT ;; Arabic (Kuwait) 237 | #:SUBLANG-ARABIC-UAE ;; Arabic (U.A.E) 238 | #:SUBLANG-ARABIC-BAHRAIN ;; Arabic (Bahrain) 239 | #:SUBLANG-ARABIC-QATAR ;; Arabic (Qatar) 240 | #:SUBLANG-AZERI-LATIN ;; Azeri (Latin) 241 | #:SUBLANG-AZERI-CYRILLIC ;; Azeri (Cyrillic) 242 | #:SUBLANG-CHINESE-TRADITIONAL ;; Chinese (Taiwan) 243 | #:SUBLANG-CHINESE-SIMPLIFIED ;; Chinese (PR China) 244 | #:SUBLANG-CHINESE-HONGKONG ;; Chinese (Hong Kong S.A.R., P.R.C.) 245 | #:SUBLANG-CHINESE-SINGAPORE ;; Chinese (Singapore) 246 | #:SUBLANG-CHINESE-MACAU ;; Chinese (Macau S.A.R.) 247 | #:SUBLANG-DUTCH ;; Dutch 248 | #:SUBLANG-DUTCH-BELGIAN ;; Dutch (Belgian) 249 | #:SUBLANG-ENGLISH-US ;; English (USA) 250 | #:SUBLANG-ENGLISH-UK ;; English (UK) 251 | #:SUBLANG-ENGLISH-AUS ;; English (Australian) 252 | #:SUBLANG-ENGLISH-CAN ;; English (Canadian) 253 | #:SUBLANG-ENGLISH-NZ ;; English (New Zealand) 254 | #:SUBLANG-ENGLISH-EIRE ;; English (Irish) 255 | #:SUBLANG-ENGLISH-SOUTH-AFRICA ;; English (South Africa) 256 | #:SUBLANG-ENGLISH-JAMAICA ;; English (Jamaica) 257 | #:SUBLANG-ENGLISH-CARIBBEAN ;; English (Caribbean) 258 | #:SUBLANG-ENGLISH-BELIZE ;; English (Belize) 259 | #:SUBLANG-ENGLISH-TRINIDAD ;; English (Trinidad) 260 | #:SUBLANG-ENGLISH-ZIMBABWE ;; English (Zimbabwe) 261 | #:SUBLANG-ENGLISH-PHILIPPINES ;; English (Philippines) 262 | #:SUBLANG-FRENCH ;; French 263 | #:SUBLANG-FRENCH-BELGIAN ;; French (Belgian) 264 | #:SUBLANG-FRENCH-CANADIAN ;; French (Canadian) 265 | #:SUBLANG-FRENCH-SWISS ;; French (Swiss) 266 | #:SUBLANG-FRENCH-LUXEMBOURG ;; French (Luxembourg) 267 | #:SUBLANG-FRENCH-MONACO ;; French (Monaco) 268 | #:SUBLANG-GERMAN ;; German 269 | #:SUBLANG-GERMAN-SWISS ;; German (Swiss) 270 | #:SUBLANG-GERMAN-AUSTRIAN ;; German (Austrian) 271 | #:SUBLANG-GERMAN-LUXEMBOURG ;; German (Luxembourg) 272 | #:SUBLANG-GERMAN-LIECHTENSTEIN ;; German (Liechtenstein) 273 | #:SUBLANG-ITALIAN ;; Italian 274 | #:SUBLANG-ITALIAN-SWISS ;; Italian (Swiss) 275 | #:SUBLANG-KASHMIRI-SASIA ;; Kashmiri (South Asia) 276 | #:SUBLANG-KASHMIRI-INDIA ;; For app compatibility only 277 | #:SUBLANG-KOREAN ;; Korean (Extended Wansung) 278 | #:SUBLANG-LITHUANIAN ;; Lithuanian 279 | #:SUBLANG-MALAY-MALAYSIA ;; Malay (Malaysia) 280 | #:SUBLANG-MALAY-BRUNEI-DARUSSALAM ;; Malay (Brunei Darussalam) 281 | #:SUBLANG-NEPALI-INDIA ;; Nepali (India) 282 | #:SUBLANG-NORWEGIAN-BOKMAL ;; Norwegian (Bokmal) 283 | #:SUBLANG-NORWEGIAN-NYNORSK ;; Norwegian (Nynorsk) 284 | #:SUBLANG-PORTUGUESE ;; Portuguese 285 | #:SUBLANG-PORTUGUESE-BRAZILIAN ;; Portuguese (Brazilian) 286 | #:SUBLANG-SERBIAN-LATIN ;; Serbian (Latin) 287 | #:SUBLANG-SERBIAN-CYRILLIC ;; Serbian (Cyrillic) 288 | #:SUBLANG-SPANISH ;; Spanish (Castilian) 289 | #:SUBLANG-SPANISH-MEXICAN ;; Spanish (Mexican) 290 | #:SUBLANG-SPANISH-MODERN ;; Spanish (Spain) 291 | #:SUBLANG-SPANISH-GUATEMALA ;; Spanish (Guatemala) 292 | #:SUBLANG-SPANISH-COSTA-RICA ;; Spanish (Costa Rica) 293 | #:SUBLANG-SPANISH-PANAMA ;; Spanish (Panama) 294 | #:SUBLANG-SPANISH-DOMINICAN-REPUBLIC ;; Spanish (Dominican Republic) 295 | #:SUBLANG-SPANISH-VENEZUELA ;; Spanish (Venezuela) 296 | #:SUBLANG-SPANISH-COLOMBIA ;; Spanish (Colombia) 297 | #:SUBLANG-SPANISH-PERU ;; Spanish (Peru) 298 | #:SUBLANG-SPANISH-ARGENTINA ;; Spanish (Argentina) 299 | #:SUBLANG-SPANISH-ECUADOR ;; Spanish (Ecuador) 300 | #:SUBLANG-SPANISH-CHILE ;; Spanish (Chile) 301 | #:SUBLANG-SPANISH-URUGUAY ;; Spanish (Uruguay) 302 | #:SUBLANG-SPANISH-PARAGUAY ;; Spanish (Paraguay) 303 | #:SUBLANG-SPANISH-BOLIVIA ;; Spanish (Bolivia) 304 | #:SUBLANG-SPANISH-EL-SALVADOR ;; Spanish (El Salvador) 305 | #:SUBLANG-SPANISH-HONDURAS ;; Spanish (Honduras) 306 | #:SUBLANG-SPANISH-NICARAGUA ;; Spanish (Nicaragua) 307 | #:SUBLANG-SPANISH-PUERTO-RICO ;; Spanish (Puerto Rico) 308 | #:SUBLANG-SWEDISH ;; Swedish 309 | #:SUBLANG-SWEDISH-FINLAND ;; Swedish (Finland) 310 | #:SUBLANG-URDU-PAKISTAN ;; Urdu (Pakistan) 311 | #:SUBLANG-URDU-INDIA ;; Urdu (India) 312 | #:SUBLANG-UZBEK-LATIN ;; Uzbek (Latin) 313 | #:SUBLANG-UZBEK-CYRILLIC ;; Uzbek (Cyrillic) 314 | 315 | 316 | #:lang-sort 317 | #:sort-default 318 | #:sort-japanese-xjis 319 | #:sort-japanese-unicode 320 | #:sort-chinese-big5 321 | #:sort-chinese-prcp 322 | #:sort-chinese-unicode 323 | #:sort-chinese-prc 324 | #:sort-chinese-bopomofo 325 | #:sort-korean-ksc 326 | #:sort-korean-unicode 327 | #:sort-german-phone-book 328 | #:sort-hungarian-default 329 | #:sort-hungarian-technical 330 | #:sort-georgian-traditional 331 | #:sort-georgean-modern 332 | 333 | #:make-lang-id 334 | #:primary-lang-id 335 | #:sublang-id 336 | #:nls-valid-locale-mask 337 | #:make-locale-id 338 | #:make-sort-locale-id 339 | #:lang-id-from-locale-id 340 | #:sort-id-from-locale-id 341 | #:sort-version-from-locale-id 342 | #:lang-system-default 343 | #:lang-user-default 344 | #:locale-system-default 345 | #:locale-user-default 346 | #:locale-neutral 347 | #:locale-invariant 348 | )) 349 | |# 350 | -------------------------------------------------------------------------------- /ui/window-classes.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.ui) 26 | 27 | (define-enum (class-style 28 | (:base-type dword) 29 | (:conc-name cs-) 30 | (:list t)) 31 | (:byte-align-center #x1000) 32 | (:byte-align-window #x2000) 33 | (:class-dc #x0040) 34 | (:dbl-clks #x0008) 35 | (:drop-shadow #x00020000) 36 | (:global-class #x4000) 37 | (:hredraw #x0002) 38 | (:no-close #x0200) 39 | (:own-dc #x0020) 40 | (:parent-dc #x0080) 41 | (:save-bits #x0800) 42 | (:vredraw #x0001)) 43 | 44 | (define-struct (wndclass 45 | (:conc-name wndclass-) 46 | (:constructor make-wndclass 47 | (&key style wndproc cls-extra 48 | wnd-extra instance icon cursor 49 | background menu-name class-name 50 | small-icon))) 51 | "Contains the window class attributes that are registered by the register-class and class-info functions." 52 | (cb-size dword :initform (sizeof 'wndclass)) 53 | (style class-style) 54 | (wndproc pointer) 55 | (cls-extra int) 56 | (wnd-extra int) 57 | (instance handle) 58 | (icon handle) 59 | (cursor handle) 60 | (background (union () 61 | (handle handle) 62 | (uint uint-ptr)) 63 | :initform &0) 64 | (menu-name (union () 65 | (string (& (const tstring))) 66 | (uint uint-ptr)) 67 | :initform 0) 68 | (class-name (union () 69 | (string (& (const tstring))) 70 | (uint uint-ptr)) 71 | :initform 0) 72 | (small-icon handle)) 73 | 74 | (define-external-function 75 | (#+doors.unicode "GetClassInfoExW" 76 | #-doors.unicode "GetClassInfoExA" 77 | class-info) 78 | (:stdcall user32) 79 | ((last-error bool) rv info) 80 | "Retrieves information about a window class, including a handle to the small icon associated with the window class." 81 | (instance handle :optional) 82 | (class-name (union () 83 | (string (& (const tstring))) 84 | (uint uint-ptr))) 85 | (info (& wndclass :inout) :aux)) 86 | 87 | (define-external-function 88 | (#+doors.unicode "GetClassLongW" 89 | #-doors.unicode "GetClassLongA" 90 | class-long) 91 | (:stdcall user32) 92 | ((last-error dword doors::not-zero)) 93 | "Retrieves the specified 32-bit (DWORD) value from the WNDCLASS structure associated with the specified window." 94 | (hwnd handle) 95 | (index (enum (:base-type int) 96 | (:atom -32) 97 | (:cb-cls-extra -20) 98 | (:cb-wnd-extra -18) 99 | (:background -10) 100 | (:cursor -12) 101 | (:icon -14) 102 | (:small-icon -34) 103 | (:module -16) 104 | (:menu-name -8) 105 | (:style -26) 106 | (:wndproc -24)))) 107 | 108 | (define-external-function 109 | (#+doors.unicode #+x86-64 "GetClassLongPtrW" #-x86-64 "GetClassLongW" 110 | #-doors.unicode #+x86-64 "GetClassLongPtrA" #-x86-64 "GetClassLongA" 111 | class-long-ptr) 112 | (:stdcall user32) 113 | ((last-error dword doors::not-zero)) 114 | "Retrieves the specified value from the WNDCLASS structure associated with the specified window." 115 | (hwnd handle) 116 | (index (enum (:base-type int) 117 | (:atom -32) 118 | (:cb-cls-extra -20) 119 | (:cb-wnd-extra -18) 120 | (:background -10) 121 | (:cursor -12) 122 | (:icon -14) 123 | (:small-icon -34) 124 | (:module -16) 125 | (:menu-name -8) 126 | (:style -26) 127 | (:wndproc -24)))) 128 | 129 | (define-external-function 130 | (#+doors.unicode "GetClassNameW" 131 | #-doors.unicode "GetClassNameA" 132 | window-class-name) 133 | (:stdcall user32) 134 | ((last-error int doors::not-zero) rv 135 | (subseq buffer 0 rv)) 136 | "Retrieves the name of the class to which the specified window belongs." 137 | (hwnd handle) 138 | (buffer (& tstring :out) :aux (make-string count)) 139 | (count int :optional 256)) 140 | 141 | (define-external-function 142 | ("GetClassWord" class-word) 143 | (:stdcall user32) 144 | ((last-error word doors::not-zero)) 145 | "Retrieves the 16-bit (WORD) value at the specified offset into the extra class memory for the window class to which the specified window belongs." 146 | (hwnd handle) 147 | (index (enum (:base-type int) 148 | (:atom -32)))) 149 | 150 | (define-external-function 151 | (#+doors.unicode "GetWindowLongW" 152 | #-doors.unicode "GetWindowLongA" 153 | window-long) 154 | (:stdcall user32) 155 | ((last-error long doors::not-zero)) 156 | "Retrieves information about the specified window. The function also retrieves the 32-bit (DWORD) value at the specified offset into the extra window memory." 157 | (hwnd handle) 158 | (index (enum (:base-type int) 159 | (:style* -20) 160 | (:instance -6) 161 | (:parent -8) 162 | (:id -12) 163 | (:style -16) 164 | (:user-data -21) 165 | (:wndproc -4)))) 166 | 167 | (define-external-function 168 | (#+doors.unicode #+x86-64 "GetWindowLongPtrW" #-x86-64 "GetWindowLongW" 169 | #-doors.unicode #+x86-64 "GetWindowLongPtrA" #-x86-64 "GetWindowLongA" 170 | window-long-ptr) 171 | (:stdcall user32) 172 | ((last-error long-ptr doors::not-zero)) 173 | "Retrieves information about the specified window. The function also retrieves the value at a specified offset into the extra window memory." 174 | (hwnd handle) 175 | (index (enum (:base-type int) 176 | (:style* -20) 177 | (:instance -6) 178 | (:parent -8) 179 | (:id -12) 180 | (:style -16) 181 | (:user-data -21) 182 | (:wndproc -4)))) 183 | 184 | (define-external-function 185 | (#+doors.unicode "RegisterClassExW" 186 | #-doors.unicode "RegisterClassExA" 187 | register-class) 188 | (:stdcall user32) 189 | ((last-error atom doors::not-zero)) 190 | "Registers a window class for subsequent use in calls to the create-window or create-window* function." 191 | (window-class (& wndclass))) 192 | 193 | (define-external-function 194 | (#+doors.unicode "SetClassLongW" 195 | #-doors.unicode "SetClassLongA" 196 | (setf class-long)) 197 | (:stdcall user32) 198 | ((last-error dword doors::not-zero)) 199 | "Replaces the specified 32-bit (long) value at the specified offset into the extra class memory or the WNDCLASS structure for the class to which the specified window belongs." 200 | (hwnd handle :optional) 201 | (index (enum (:base-type int) 202 | (:cb-cls-extra -20) 203 | (:cb-wnd-extra -18) 204 | (:background -10) 205 | (:cursor -12) 206 | (:icon -14) 207 | (:small-icon -34) 208 | (:module -16) 209 | (:menu-name -8) 210 | (:style -26) 211 | (:wndproc -24)) 212 | :optional) 213 | (new-long long)) 214 | 215 | (define-external-function 216 | (#+doors.unicode #+x86-64 "SetClassLongPtrW" #-x86-64 "SetClassLongW" 217 | #-doors.unicode #+x86-64 "SetClassLongPtrA" #-x86-64 "SetClassLongA" 218 | (setf class-long-ptr)) 219 | (:stdcall user32) 220 | ((last-error long-ptr doors::not-zero)) 221 | "Replaces the specified value at the specified offset into the extra class memory or the WNDCLASS structure for the class to which the specified window belongs." 222 | (hwnd handle :optional) 223 | (index (enum (:base-type int) 224 | (:cb-cls-extra -20) 225 | (:cb-wnd-extra -18) 226 | (:background -10) 227 | (:cursor -12) 228 | (:icon -14) 229 | (:small-icon -34) 230 | (:module -16) 231 | (:menu-name -8) 232 | (:style -26) 233 | (:wndproc -24)) 234 | :optional) 235 | (new-long-ptr long-ptr)) 236 | 237 | (define-external-function 238 | ("SetClassWord" (setf class-word)) 239 | (:stdcall user32) 240 | ((last-error word doors::not-zero)) 241 | "Replaces the 16-bit (WORD) value at the specified offset into the extra class memory for the window class to which the specified window belongs." 242 | (hwnd handle :optional) 243 | (index int :optional) 244 | (new-word word)) 245 | 246 | (define-external-function 247 | (#+doors.unicode "SetWindowLongW" 248 | #-doors.unicode "SetWindowLongA" 249 | (setf window-long)) 250 | (:stdcall user32) 251 | ((last-error long doors::not-zero)) 252 | "Changes an attribute of the specified window. The function also sets the 32-bit (long) value at the specified offset into the extra window memory." 253 | (hwnd handle :optional) 254 | (index (enum (:base-type int) 255 | (:style* -20) 256 | (:instance -6) 257 | (:id -12) 258 | (:style -16) 259 | (:user-data -21) 260 | (:wndproc -4)) 261 | :optional) 262 | (new-long long)) 263 | 264 | (define-external-function 265 | (#+doors.unicode #+x86-64 "SetWindowLongPtrW" #-x86-64 "SetWindowLongW" 266 | #-doors.unicode #+x86-64 "SetWindowLongPtrA" #-x86-64 "SetWindowLongA" 267 | (setf window-long-ptr)) 268 | (:stdcall user32) 269 | ((last-error long-ptr doors::not-zero)) 270 | "Changes an attribute of the specified window. The function also sets a value at the specified offset in the extra window memory." 271 | (hwnd handle :optional) 272 | (index (enum (:base-type int) 273 | (:style* -20) 274 | (:instance -6) 275 | (:id -12) 276 | (:style -16) 277 | (:user-data -21) 278 | (:wndproc -4)) 279 | :optional) 280 | (new-long-ptr long-ptr)) 281 | 282 | (define-external-function 283 | (#+doors.unicode "UnregisterClassW" 284 | #-doors.unicode "UnregisterClassA" 285 | unregister-class) 286 | (:stdcall user32) 287 | ((last-error bool)) 288 | "Unregisters a window class, freeing the memory required for the class." 289 | (class-name (union () 290 | (string (& (const tstring))) 291 | (uint uint-ptr))) 292 | (instance handle :optional)) 293 | 294 | (define-enum (system-color 295 | (:base-type dword) 296 | (:conc-name color-)) 297 | (:3d-dk-shadow 21) 298 | (:3d-face 15) 299 | (:3d-highlight 20) 300 | (:3d-hilight 20) 301 | (:3d-light 22) 302 | (:3d-shadow 16) 303 | (:active-border 10) 304 | (:active-caption 2) 305 | (:app-workspace 12) 306 | (:background 1) 307 | (:btn-face 15) 308 | (:btn-highlight 20) 309 | (:btn-hilight 20) 310 | (:btn-shadow 16) 311 | (:btn-text 18) 312 | (:caption-text 9) 313 | (:desktop 1) 314 | (:gradient-active-caption 27) 315 | (:gradient-inactive-caption 28) 316 | (:gray-text 17) 317 | (:highlight 13) 318 | (:highlight-text 14) 319 | (:hotlight 26) 320 | (:inactive-border 11) 321 | (:inactive-caption 3) 322 | (:inactive-caption-text 19) 323 | (:info-bk 24) 324 | (:info-text 23) 325 | (:menu 4) 326 | (:menu-hilight 29) 327 | (:menu-bar 30) 328 | (:menu-text 7) 329 | (:scrollbar 0) 330 | (:window 5) 331 | (:window-frame 6) 332 | (:window-text 8)) 333 | -------------------------------------------------------------------------------- /ui/windows-aux.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE 24 | 25 | (in-package #:doors.ui) 26 | 27 | (define-external-function 28 | ("KillTimer" (:camel-case)) 29 | (:stdcall user32) 30 | ((last-error bool)) 31 | "Destroys the specified timer." 32 | (hwnd handle) 33 | (id uint-ptr)) 34 | 35 | (define-external-function 36 | ("SetTimer" (:camel-case)) 37 | (:stdcall user32) 38 | (uint-ptr) 39 | "Creates a timer with the specified time-out value." 40 | (hwnd handle :optional) 41 | (id uint-ptr :optional) 42 | (elapse uint) 43 | (callback pointer :optional)) 44 | 45 | (define-external-function 46 | (#+doors.unicode "EnumPropsW" 47 | #-doors.unicode "EnumPropsA" 48 | enum-props) 49 | (:stdcall user32) 50 | (int rv (if (= -1 rv) nil rv)) 51 | "Enumerates all entries in the property list of a window by passing them, one by one, to the specified callback function." 52 | (hwnd handle) 53 | (func pointer)) 54 | 55 | (define-external-function 56 | (#+doors.unicode "EnumPropsExW" 57 | #-doors.unicode "EnumPropsExA" 58 | enum-props*) 59 | (:stdcall user32) 60 | (int rv (if (= -1 rv) nil rv)) 61 | "Enumerates all entries in the property list of a window by passing them, one by one, to the specified callback function." 62 | (hwnd handle) 63 | (func pointer) 64 | (lparam lparam)) 65 | 66 | (define-external-function 67 | (#+doors.unicode "GetPropW" 68 | #-doors.unicode "GetPropA" 69 | window-prop) 70 | (:stdcall user32) 71 | (handle) 72 | "Retrieves a data handle from the property list of the specified window." 73 | (hwnd handle) 74 | (id (union () 75 | (string (& tstring)) 76 | (atom uint-ptr)))) 77 | 78 | (define-external-function 79 | (#+doors.unicode "RemovePropW" 80 | #-doors.unicode "RemovePropA" 81 | remove-prop) 82 | (:stdcall user32) 83 | (handle) 84 | "Removes an entry from the property list of the specified window." 85 | (hwnd handle) 86 | (id (union () 87 | (string (& tstring)) 88 | (atom uint-ptr)))) 89 | 90 | (define-external-function 91 | (#+doors.unicode "SetPropW" 92 | #-doors.unicode "SetPropA" 93 | (setf window-prop)) 94 | (:stdcall user32) 95 | ((last-error bool) rv data) 96 | "Adds a new entry or changes an existing entry in the property list of the specified window." 97 | (hwnd handle :optional) 98 | (id (union () 99 | (string (& tstring)) 100 | (atom uint-ptr)) 101 | :optional 0) 102 | (data handle)) 103 | 104 | (define-struct (cbt-create-wnd) 105 | "Contains information passed to a WH-CBT hook procedure, before a window is created." 106 | (cs (& create-struct)) 107 | (insert-after handle)) 108 | 109 | (define-struct (cbt-activate-struct) 110 | "Contains information passed to a WH-CBT hook procedure, before a window is activated." 111 | (mouse boolean) 112 | (active-hwnd handle)) 113 | 114 | (define-struct (cwp-ret-struct) 115 | "Defines the message parameters passed to a WH-CALL-WNDPROC-RET hook procedur" 116 | (lresult lresult) 117 | (lparam lparam) 118 | (wparam wparam) 119 | (message uint) 120 | (hwnd handle)) 121 | 122 | (define-struct (cwp-struct) 123 | "Defines the message parameters passed to a WH-CALL-WNDPROC hook procedure" 124 | (lparam lparam) 125 | (wparam wparam) 126 | (message uint) 127 | (hwnd handle)) 128 | 129 | (define-struct (debug-hook-info 130 | (:constructor make-dh-info) 131 | (:conc-name dh-info-)) 132 | "Contains debugging information passed to a WH-DEBUG hook procedure" 133 | (thread-id dword) 134 | (installer-thread-id dword) 135 | (lparam lparam) 136 | (wparam wparam) 137 | (code int)) 138 | 139 | (define-struct (event-msg) 140 | "Contains information about a hardware message sent to the system message queue." 141 | (message uint) 142 | (param-l uint) 143 | (param-h uint) 144 | (time dword) 145 | (hwnd handle)) 146 | 147 | (define-struct (kdb-ll-hook-struct 148 | (:constructor make-kdb-ll-hs) 149 | (:conc-name kdb-ll-hs-)) 150 | "Contains information about a low-level keyboard input event." 151 | (code dword) 152 | (scan-code dword) 153 | (flags (enum (:base-type dword :list t) 154 | (:extended #b1) 155 | (:injected #b10000) 156 | (:alt-down #b100000) 157 | (:up #b10000000))) 158 | (time dword) 159 | (extra-info ulong-ptr)) 160 | 161 | (define-struct (mouse-hook-struct 162 | (:conc-name mhs-) 163 | (:constructor make-mhs)) 164 | "Contains information about a mouse event passed to a WH-MOUSE hook procedure" 165 | (pt point) 166 | (hwnd handle) 167 | (hit-test-code hit-test-code) 168 | (extra-info ulong-ptr)) 169 | 170 | (define-struct (mouse-hook-struct* 171 | (:include mouse-hook-struct) 172 | (:conc-name mhs-) 173 | (:constructor make-mhs*)) 174 | "Contains information about a mouse event passed to a WH-MOUSE hook procedure" 175 | (mouse-data dword)) 176 | 177 | (define-struct (ms-ll-hook-struct 178 | (:conc-name ms-ll-hs-) 179 | (:constructor make-ms-ll-hs)) 180 | "Contains information about a low-level mouse input event." 181 | (pt point) 182 | (mouse-data dword) 183 | (flags (enum (:base-type uint) 184 | (:injected 1))) 185 | (time dword) 186 | (extra-info ulong-ptr)) 187 | 188 | (define-external-function 189 | (#+doors.unicode "CallMsgFilterW" 190 | #-doors.unicode "CallMsgFilterA" 191 | call-msg-filter) 192 | (:stdcall user32) 193 | (bool) 194 | "Passes the specified message and hook code to the hook procedures associated with the WH-SYS-MSG-FILTER and WH-MSG-FILTER hooks." 195 | (msg (& msg)) 196 | (code int)) 197 | 198 | (define-enum (hook-type 199 | (:base-type int) 200 | (:conc-name wh-)) 201 | (:call-wndproc 4) 202 | (:call-wndproc-ret 12) 203 | (:cbt 5) 204 | (:debug 9) 205 | (:foreground-idle 11) 206 | (:get-message 3) 207 | (:journal-playback 1) 208 | (:journal-record 0) 209 | (:keyboard 2) 210 | (:keyboard-ll 13) 211 | (:mouse 7) 212 | (:mouse-ll 14) 213 | (:msg-filter -1) 214 | (:shell 10) 215 | (:sys-msg-filter 6)) 216 | 217 | (define-external-function 218 | ("CallNextHookEx" call-next-hook) 219 | (:stdcall user32) 220 | (lresult) 221 | "Passes the hook information to the next hook procedure in the current hook chain." 222 | (hhk handle :aux) 223 | (type hook-type) 224 | (wparam wparam) 225 | (lparam lparam)) 226 | 227 | (define-external-function 228 | (#+doors.unicode "SetWindowsHookExW" 229 | #-doors.unicode "SetWindowsHookExA" 230 | set-windows-hook) 231 | (:stdcall user32) 232 | ((last-error handle)) 233 | "Installs an application-defined hook procedure into a hook chain." 234 | (type hook-type) 235 | (callback pointer) 236 | (module handle :optional) 237 | (thread-id dword :optional)) 238 | 239 | (define-external-function 240 | ("UnhookWindowsHookEx" unhook-windows-hook) 241 | (:stdcall user32) 242 | ((last-error bool)) 243 | "Removes a hook procedure installed in a hook chain by the set-windows-hook function." 244 | (hook handle)) 245 | 246 | (define-struct (mdi-create-struct 247 | (:conc-name mdi-cs-) 248 | (:constructor make-mdi-cs)) 249 | "Contains information about the class, title, owner, location, and size of a multiple-document interface (MDI) child window." 250 | (class (union () 251 | (string (& (const tstring))) 252 | (atom uint-ptr))) 253 | (title (& (const tstring))) 254 | (owner handle) 255 | (x (enum (:base-type int) 256 | (:use-default #.(make-long 0 #x8000)))) 257 | (y (enum (:base-type int) 258 | (:use-default #.(make-long 0 #x8000)))) 259 | (cx (enum (:base-type int) 260 | (:use-default #.(make-long 0 #x8000)))) 261 | (cy (enum (:base-type int) 262 | (:use-default #.(make-long 0 #x8000)))) 263 | (style window-style) 264 | (lparam lparam)) 265 | 266 | (define-external-function 267 | (#+doors.unicode "CreateMDIWindowW" 268 | #-doors.unicode "CreateMDIWindowA" 269 | create-mdi-window) 270 | (:stdcall user32) 271 | ((last-error handle)) 272 | "Creates a multiple-document interface (MDI) child window." 273 | (class-name (union () 274 | (string (& (const tstring))) 275 | (atom uint-ptr)) 276 | :key 0) 277 | (window-name (& tstring) :key) 278 | (style window-style :key) 279 | (x (enum (:base-type int) 280 | (:use-default #.(make-long 0 #x8000))) :key :use-default) 281 | (y (enum (:base-type int) 282 | (:use-default #.(make-long 0 #x8000))) :key :use-default) 283 | (width (enum (:base-type int) 284 | (:use-default #.(make-long 0 #x8000))) :key :use-default) 285 | (height (enum (:base-type int) 286 | (:use-default #.(make-long 0 #x8000))) :key :use-default) 287 | (parent handle :key) 288 | (instance handle :key) 289 | (param pointer :key)) 290 | 291 | (define-external-function 292 | (#+doors.unicode "DefFrameProcW" 293 | #-doors.unicode "DefFrameProcA" 294 | def-frame-proc) 295 | (:stdcall user32) 296 | (lresult) 297 | "Provides default processing for any window messages that the window procedure of a multiple-document interface (MDI) frame window does not process." 298 | (frame handle) 299 | (mdi-client handle) 300 | (msg uint) 301 | (wparam wparam) 302 | (lparam lparam)) 303 | 304 | (define-external-function 305 | (#+doors.unicode "DefMDIChildProcW" 306 | #-doors.unicode "DefMDIChildProcA" 307 | def-mdi-child-proc) 308 | (:stdcall user32) 309 | (lresult) 310 | "Provides default processing for any window message that the window procedure of a multiple-document interface (MDI) child window does not process." 311 | (hwnd handle) 312 | (msg uint) 313 | (wparam wparam) 314 | (lparam lparam)) 315 | 316 | (define-external-function 317 | ("TranslateMDISysAccel" translate-mdi-sys-accel) 318 | (:stdcall user32) 319 | (bool) 320 | "Processes accelerator keystrokes for window menu commands of the multiple-document interface (MDI) child windows associated with the specified MDI client window." 321 | (client handle) 322 | (msg (& msg))) 323 | 324 | --------------------------------------------------------------------------------