basis/windows/registry/registry.factor

   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 ;
   9 IN: windows.registry
  10
  11 ERROR: open-key-failed key subkey mode error-string ;
  12 ERROR: create-key-failed hKey lpSubKey lpClass dwOptions
  13 samDesired lpSecurityAttributes phkResult lpdwDisposition ;
  14
  15 CONSTANT: registry-value-max-length 16384
  16
  17 :: open-key ( key subkey mode -- hkey )
  18     key subkey 0 mode 0 HKEY <ref>
  19     [
  20         RegOpenKeyEx dup ERROR_SUCCESS = [
  21             drop
  22         ] [
  23             [ key subkey mode ] dip n>win32-error-string
  24             open-key-failed
  25         ] if
  26     ] keep HKEY deref ;
  27
  28 :: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? )
  29     f :> ret!
  30     hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
  31     0 HKEY <ref>
  32     0 DWORD <ref>
  33     [ RegCreateKeyEx ret! ] 2keep
  34     [ HKEY deref ]
  35     [ DWORD deref REG_CREATED_NEW_KEY = ] bi*
  36     ret ERROR_SUCCESS = [
  37         [
  38             hKey lpSubKey 0 lpClass dwOptions samDesired
  39             lpSecurityAttributes
  40         ] dip n>win32-error-string
  41         create-key-failed
  42     ] unless ;
  43
  44 : create-key ( hkey lsubkey -- hkey )
  45     f 0 KEY_ALL_ACCESS f create-key* drop ;
  46
  47 : close-key ( hkey -- )
  48     RegCloseKey n>win32-error-check ;
  49
  50 :: with-open-registry-key ( key subkey mode quot -- )
  51     key subkey mode open-key :> hkey
  52     [ hkey quot call ]
  53     [ hkey close-key ]
  54     finally ; inline
  55
  56 :: with-create-registry-key ( key subkey quot -- )
  57     key subkey create-key :> hkey
  58     [ hkey quot call ]
  59     [ hkey close-key ]
  60     finally ; inline
  61
  62 <PRIVATE
  63
  64 : grow-buffer ( byte-array -- byte-array' )
  65     length 2 * <byte-array> ;
  66
  67 PRIVATE>
  68
  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
  72     rot :> ret
  73     ret ERROR_SUCCESS = [
  74         uint deref head
  75     ] [
  76         ret ERROR_MORE_DATA = [
  77             2drop
  78             key value-name ptr1 lpType buffer
  79             grow-buffer reg-query-value-ex
  80         ] [
  81             ret throw-windows-error
  82         ] if
  83     ] if ;
  84
  85 : delete-value ( key value-name -- )
  86     RegDeleteValue dup ERROR_SUCCESS = [
  87         drop
  88     ] [
  89         n>win32-error-string throw
  90     ] if ;
  91
  92 TUPLE: registry-info
  93 key
  94 class-name
  95 sub-keys
  96 longest-subkey
  97 longest-class-string
  98 #values
  99 max-value
 100 max-value-data
 101 security-descriptor
 102 last-write-time ;
 103
 104 TUPLE: registry-enum-key ;
 105
 106
 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
 112         f
 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 = [
 117
 118         ] [
 119         ] if
 120     ] map ;
 121
 122 :: reg-query-info-key ( key -- n )
 123     key
 124     MAX_PATH
 125     dup TCHAR <c-array> dup :> class-buffer
 126     swap int <ref> dup :> class-buffer-length
 127     f
 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 = [
 138         key
 139         class-buffer
 140         sub-keys uint deref
 141         longest-subkey uint deref
 142         longest-class-string uint deref
 143         #values uint deref
 144         max-value uint deref
 145         max-value-data uint deref
 146         security-descriptor uint deref
 147         last-write-time FILETIME>timestamp
 148         registry-info boa
 149     ] [
 150         ret n>win32-error-string
 151     ] if ;
 152
 153 : set-reg-key ( hkey value type lpdata cbdata -- )
 154     [ 0 ] 3dip
 155     RegSetValueEx dup ERROR_SUCCESS = [
 156         drop
 157     ] [
 158         "omg" throw
 159     ] if ;
 160
 161 : set-reg-binary ( hkey value lpdata cbdata -- )
 162     [ REG_BINARY ] 2dip set-reg-key ;
 163
 164 : set-reg-dword ( hkey value lpdata cbdata -- )
 165     [ REG_DWORD ] 2dip set-reg-key ;
 166
 167 : set-reg-dword-le ( hkey value lpdata cbdata -- )
 168     [ REG_DWORD_LITTLE_ENDIAN ] 2dip set-reg-key ;
 169
 170 : set-reg-dword-be ( hkey value lpdata cbdata -- )
 171     [ REG_DWORD_BIG_ENDIAN ] 2dip set-reg-key ;
 172
 173 : set-reg-expand-sz ( hkey value lpdata cbdata -- )
 174     [ REG_EXPAND_SZ ] 2dip set-reg-key ;
 175
 176 : set-reg-link ( hkey value lpdata cbdata -- )
 177     [ REG_LINK ] 2dip set-reg-key ;
 178
 179 : set-reg-multi-sz ( hkey value lpdata cbdata -- )
 180     [ REG_MULTI_SZ ] 2dip set-reg-key ;
 181
 182 : set-reg-none ( hkey value lpdata cbdata -- )
 183     [ REG_NONE ] 2dip set-reg-key ;
 184
 185 : set-reg-qword ( hkey value lpdata cbdata -- )
 186     [ REG_QWORD ] 2dip set-reg-key ;
 187
 188 : set-reg-qword-le ( hkey value lpdata cbdata -- )
 189     [ REG_QWORD_LITTLE_ENDIAN ] 2dip set-reg-key ;
 190
 191 : set-reg-sz ( hkey value lpdata cbdata -- )
 192     [ REG_SZ ] 2dip set-reg-key ;
 193
 194 : windows-performance-data ( -- byte-array )
 195     HKEY_PERFORMANCE_DATA "Global" f f
 196     21 2^ <byte-array> reg-query-value-ex ;
 197
 198 : read-registry ( key subkey -- registry-info )
 199     KEY_READ [ reg-query-info-key ] with-open-registry-key ;
 200
 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>
 205         reg-query-value-ex
 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 = [
 209                 "\0" split 2
 210             ] [ 1 ] if head*
 211         ] when
 212         quot call( x -- x' )
 213         string-type? [
 214             type DWORD deref REG_MULTI_SZ = [
 215                 "\0" join 2
 216             ] [ 1 ] if [ CHAR: \0 suffix ] times utf16n encode
 217         ] when
 218         [ hkey value-name type DWORD deref ] dip dup length
 219         set-reg-key
 220     ] with-open-registry-key ;