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 dup ERROR_SUCCESS = [
  49         drop
  50     ] [
  51         n>win32-error-string throw
  52     ] if ;
  53
  54 :: with-open-registry-key ( key subkey mode quot -- )
  55     key subkey mode open-key :> hkey
  56     [ hkey quot call ]
  57     [ hkey close-key ]
  58     finally ; inline
  59
  60 :: with-create-registry-key ( key subkey quot -- )
  61     key subkey create-key :> hkey
  62     [ hkey quot call ]
  63     [ hkey close-key ]
  64     finally ; inline
  65
  66 <PRIVATE
  67
  68 : grow-buffer ( byte-array -- byte-array' )
  69     length 2 * <byte-array> ;
  70
  71 PRIVATE>
  72
  73 :: reg-query-value-ex ( key value-name ptr1 lpType buffer -- buffer )
  74     buffer length uint <ref> :> pdword
  75     key value-name ptr1 lpType buffer pdword [ RegQueryValueEx ] 2keep
  76     rot :> ret
  77     ret ERROR_SUCCESS = [
  78         uint deref head
  79     ] [
  80         ret ERROR_MORE_DATA = [
  81             2drop
  82             key value-name ptr1 lpType buffer
  83             grow-buffer reg-query-value-ex
  84         ] [
  85             ret n>win32-error-string throw
  86         ] if
  87     ] if ;
  88
  89 : delete-value ( key value-name -- )
  90     RegDeleteValue dup ERROR_SUCCESS = [
  91         drop
  92     ] [
  93         n>win32-error-string throw
  94     ] if ;
  95
  96 TUPLE: registry-info
  97 key
  98 class-name
  99 sub-keys
 100 longest-subkey
 101 longest-class-string
 102 #values
 103 max-value
 104 max-value-data
 105 security-descriptor
 106 last-write-time ;
 107
 108 TUPLE: registry-enum-key ;
 109
 110
 111 :: reg-enum-keys ( registry-info -- seq )
 112     registry-info sub-keys>> <iota> [
 113         [ registry-info key>> ] dip
 114         registry-value-max-length TCHAR <c-array> dup :> registry-value
 115         registry-value length dup :> registry-value-length
 116         f
 117         0 DWORD <ref> dup :> type
 118         f ! 0 BYTE <ref> dup :> data
 119         f ! 0 BYTE <ref> dup :> buffer
 120         RegEnumKeyEx dup ERROR_SUCCESS = [
 121
 122         ] [
 123         ] if
 124     ] map ;
 125
 126 :: reg-query-info-key ( key -- n )
 127     key
 128     MAX_PATH
 129     dup TCHAR <c-array> dup :> class-buffer
 130     swap int <ref> dup :> class-buffer-length
 131     f
 132     0 DWORD <ref> dup :> sub-keys
 133     0 DWORD <ref> dup :> longest-subkey
 134     0 DWORD <ref> dup :> longest-class-string
 135     0 DWORD <ref> dup :> #values
 136     0 DWORD <ref> dup :> max-value
 137     0 DWORD <ref> dup :> max-value-data
 138     0 DWORD <ref> dup :> security-descriptor
 139     FILETIME <struct> dup :> last-write-time
 140     RegQueryInfoKey :> ret
 141     ret ERROR_SUCCESS = [
 142         key
 143         class-buffer
 144         sub-keys uint deref
 145         longest-subkey uint deref
 146         longest-class-string uint deref
 147         #values uint deref
 148         max-value uint deref
 149         max-value-data uint deref
 150         security-descriptor uint deref
 151         last-write-time FILETIME>timestamp
 152         registry-info boa
 153     ] [
 154         ret n>win32-error-string
 155     ] if ;
 156
 157 : set-reg-key ( hkey value type lpdata cbdata -- )
 158     [ 0 ] 3dip
 159     RegSetValueEx dup ERROR_SUCCESS = [
 160         drop
 161     ] [
 162         "omg" throw
 163     ] if ;
 164
 165 : set-reg-binary ( hkey value lpdata cbdata -- )
 166     [ REG_BINARY ] 2dip set-reg-key ;
 167
 168 : set-reg-dword ( hkey value lpdata cbdata -- )
 169     [ REG_DWORD ] 2dip set-reg-key ;
 170
 171 : set-reg-dword-le ( hkey value lpdata cbdata -- )
 172     [ REG_DWORD_LITTLE_ENDIAN ] 2dip set-reg-key ;
 173
 174 : set-reg-dword-be ( hkey value lpdata cbdata -- )
 175     [ REG_DWORD_BIG_ENDIAN ] 2dip set-reg-key ;
 176
 177 : set-reg-expand-sz ( hkey value lpdata cbdata -- )
 178     [ REG_EXPAND_SZ ] 2dip set-reg-key ;
 179
 180 : set-reg-link ( hkey value lpdata cbdata -- )
 181     [ REG_LINK ] 2dip set-reg-key ;
 182
 183 : set-reg-multi-sz ( hkey value lpdata cbdata -- )
 184     [ REG_MULTI_SZ ] 2dip set-reg-key ;
 185
 186 : set-reg-none ( hkey value lpdata cbdata -- )
 187     [ REG_NONE ] 2dip set-reg-key ;
 188
 189 : set-reg-qword ( hkey value lpdata cbdata -- )
 190     [ REG_QWORD ] 2dip set-reg-key ;
 191
 192 : set-reg-qword-le ( hkey value lpdata cbdata -- )
 193     [ REG_QWORD_LITTLE_ENDIAN ] 2dip set-reg-key ;
 194
 195 : set-reg-sz ( hkey value lpdata cbdata -- )
 196     [ REG_SZ ] 2dip set-reg-key ;
 197
 198 : windows-performance-data ( -- byte-array )
 199     HKEY_PERFORMANCE_DATA "Global" f f
 200     21 2^ <byte-array> reg-query-value-ex ;
 201
 202 : read-registry ( key subkey -- registry-info )
 203     KEY_READ [ reg-query-info-key ] with-open-registry-key ;
 204
 205 :: change-registry-value ( key subkey value-name quot: ( value -- value' ) -- )
 206     0 DWORD <ref> :> type
 207     key subkey KEY_QUERY_VALUE KEY_SET_VALUE bitor [
 208         dup :> hkey value-name f type MAX_PATH <byte-array>
 209         reg-query-value-ex
 210         type DWORD deref ${ REG_SZ REG_EXPAND_SZ REG_MULTI_SZ } in?
 211         dup :> string-type? [
 212             utf16n decode type DWORD deref REG_MULTI_SZ = [
 213                 "\0" split 2
 214             ] [ 1 ] if head*
 215         ] when
 216         quot call( x -- x' )
 217         string-type? [
 218             type DWORD deref REG_MULTI_SZ = [
 219                 "\0" join 2
 220             ] [ 1 ] if [ CHAR: \0 suffix ] times utf16n encode
 221         ] when
 222         [ hkey value-name type DWORD deref ] dip dup length
 223         set-reg-key
 224     ] with-open-registry-key ;