1 ! Copyright (C) 2010 Doug Coleman.
2 ! Copyright (C) 2018 Alexander Ilin.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors alien.c-types alien.data byte-arrays
5 classes.struct continuations io.encodings.string
6 io.encodings.utf16 kernel literals locals math sequences sets
7 splitting windows windows.advapi32 windows.errors
8 windows.kernel32 windows.time windows.types ;
11 ERROR: open-key-failed key subkey mode error-string ;
12 ERROR: create-key-failed hKey lpSubKey lpClass dwOptions
13 samDesired lpSecurityAttributes phkResult lpdwDisposition ;
15 CONSTANT: registry-value-max-length 16384
17 :: open-key ( key subkey mode -- hkey )
18 key subkey 0 mode 0 HKEY <ref>
20 RegOpenKeyEx dup ERROR_SUCCESS = [
23 [ key subkey mode ] dip n>win32-error-string
28 :: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? )
30 hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
33 [ RegCreateKeyEx ret! ] 2keep
35 [ DWORD deref REG_CREATED_NEW_KEY = ] bi*
38 hKey lpSubKey 0 lpClass dwOptions samDesired
40 ] dip n>win32-error-string
44 : create-key ( hkey lsubkey -- hkey )
45 f 0 KEY_ALL_ACCESS f create-key* drop ;
47 : close-key ( hkey -- )
48 RegCloseKey n>win32-error-check ;
50 :: with-open-registry-key ( key subkey mode quot -- )
51 key subkey mode open-key :> hkey
56 :: with-create-registry-key ( key subkey quot -- )
57 key subkey create-key :> hkey
64 : grow-buffer ( byte-array -- byte-array' )
65 length 2 * <byte-array> ;
69 :: reg-query-value-ex ( key value-name ptr1 lpType buffer -- buffer )
70 buffer length uint <ref> :> pdword
71 key value-name ptr1 lpType buffer pdword [ RegQueryValueEx ] 2keep
76 ret ERROR_MORE_DATA = [
78 key value-name ptr1 lpType buffer
79 grow-buffer reg-query-value-ex
81 ret throw-windows-error
85 : delete-value ( key value-name -- )
86 RegDeleteValue dup ERROR_SUCCESS = [
89 n>win32-error-string throw
104 TUPLE: registry-enum-key ;
107 :: reg-enum-keys ( registry-info -- seq )
108 registry-info sub-keys>> <iota> [
109 [ registry-info key>> ] dip
110 registry-value-max-length TCHAR <c-array> dup :> registry-value
111 registry-value length dup :> registry-value-length
113 0 DWORD <ref> dup :> type
114 f ! 0 BYTE <ref> dup :> data
115 f ! 0 BYTE <ref> dup :> buffer
116 RegEnumKeyEx dup ERROR_SUCCESS = [
122 :: reg-query-info-key ( key -- n )
125 dup TCHAR <c-array> dup :> class-buffer
126 swap int <ref> dup :> class-buffer-length
128 0 DWORD <ref> dup :> sub-keys
129 0 DWORD <ref> dup :> longest-subkey
130 0 DWORD <ref> dup :> longest-class-string
131 0 DWORD <ref> dup :> #values
132 0 DWORD <ref> dup :> max-value
133 0 DWORD <ref> dup :> max-value-data
134 0 DWORD <ref> dup :> security-descriptor
135 FILETIME new dup :> last-write-time
136 RegQueryInfoKey :> ret
137 ret ERROR_SUCCESS = [
141 longest-subkey uint deref
142 longest-class-string uint deref
145 max-value-data uint deref
146 security-descriptor uint deref
147 last-write-time FILETIME>timestamp
150 ret n>win32-error-string
153 : set-reg-key ( hkey value type lpdata cbdata -- )
155 RegSetValueEx dup ERROR_SUCCESS = [
161 : set-reg-binary ( hkey value lpdata cbdata -- )
162 [ REG_BINARY ] 2dip set-reg-key ;
164 : set-reg-dword ( hkey value lpdata cbdata -- )
165 [ REG_DWORD ] 2dip set-reg-key ;
167 : set-reg-dword-le ( hkey value lpdata cbdata -- )
168 [ REG_DWORD_LITTLE_ENDIAN ] 2dip set-reg-key ;
170 : set-reg-dword-be ( hkey value lpdata cbdata -- )
171 [ REG_DWORD_BIG_ENDIAN ] 2dip set-reg-key ;
173 : set-reg-expand-sz ( hkey value lpdata cbdata -- )
174 [ REG_EXPAND_SZ ] 2dip set-reg-key ;
176 : set-reg-link ( hkey value lpdata cbdata -- )
177 [ REG_LINK ] 2dip set-reg-key ;
179 : set-reg-multi-sz ( hkey value lpdata cbdata -- )
180 [ REG_MULTI_SZ ] 2dip set-reg-key ;
182 : set-reg-none ( hkey value lpdata cbdata -- )
183 [ REG_NONE ] 2dip set-reg-key ;
185 : set-reg-qword ( hkey value lpdata cbdata -- )
186 [ REG_QWORD ] 2dip set-reg-key ;
188 : set-reg-qword-le ( hkey value lpdata cbdata -- )
189 [ REG_QWORD_LITTLE_ENDIAN ] 2dip set-reg-key ;
191 : set-reg-sz ( hkey value lpdata cbdata -- )
192 [ REG_SZ ] 2dip set-reg-key ;
194 : windows-performance-data ( -- byte-array )
195 HKEY_PERFORMANCE_DATA "Global" f f
196 21 2^ <byte-array> reg-query-value-ex ;
198 : read-registry ( key subkey -- registry-info )
199 KEY_READ [ reg-query-info-key ] with-open-registry-key ;
201 :: change-registry-value ( key subkey value-name quot: ( value -- value' ) -- )
202 0 DWORD <ref> :> type
203 key subkey flags{ KEY_QUERY_VALUE KEY_SET_VALUE } [
204 dup :> hkey value-name f type MAX_PATH <byte-array>
206 type DWORD deref ${ REG_SZ REG_EXPAND_SZ REG_MULTI_SZ } in?
207 dup :> string-type? [
208 utf16n decode type DWORD deref REG_MULTI_SZ = [
214 type DWORD deref REG_MULTI_SZ = [
216 ] [ 1 ] if [ CHAR: \0 suffix ] times utf16n encode
218 [ hkey value-name type DWORD deref ] dip dup length
220 ] with-open-registry-key ;