basis/windows/registry/registry.factor

   1 ! Copyright (C) 2010 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien.c-types byte-arrays kernel locals sequences
   4 windows.advapi32 windows.errors math windows
   5 windows.kernel32 windows.time accessors alien.data
   6 windows.types classes.struct continuations ;
   7 IN: windows.registry
   8
   9 ERROR: open-key-failed key subkey mode error-string ;
  10 ERROR: create-key-failed hKey lpSubKey lpClass dwOptions
  11 samDesired lpSecurityAttributes phkResult lpdwDisposition ;
  12
  13 CONSTANT: registry-value-max-length 16384
  14
  15 :: open-key ( key subkey mode -- hkey )
  16     key subkey 0 mode 0 HKEY <ref>
  17     [
  18         RegOpenKeyEx dup ERROR_SUCCESS = [
  19             drop
  20         ] [
  21             [ key subkey mode ] dip n>win32-error-string
  22             throw-open-key-failed
  23         ] if
  24     ] keep HKEY deref ;
  25
  26 :: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? )
  27     f :> ret!
  28     hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
  29     0 HKEY <ref>
  30     0 DWORD <ref>
  31     [ RegCreateKeyEx ret! ] 2keep
  32     [ HKEY deref ]
  33     [ DWORD deref REG_CREATED_NEW_KEY = ] bi*
  34     ret ERROR_SUCCESS = [
  35         [
  36             hKey lpSubKey 0 lpClass dwOptions samDesired
  37             lpSecurityAttributes
  38         ] dip n>win32-error-string
  39         throw-create-key-failed
  40     ] unless ;
  41
  42 : create-key ( hkey lsubkey -- hkey )
  43     f 0 KEY_ALL_ACCESS f create-key* drop ;
  44
  45 : close-key ( hkey -- )
  46     RegCloseKey dup ERROR_SUCCESS = [
  47         drop
  48     ] [
  49         n>win32-error-string throw
  50     ] if ;
  51
  52 :: with-open-registry-key ( key subkey mode quot -- )
  53     key subkey mode open-key :> hkey
  54     [ hkey quot call ]
  55     [ hkey close-key ]
  56     [ ] cleanup ; inline
  57
  58 :: with-create-registry-key ( key subkey quot -- )
  59     key subkey create-key :> hkey
  60     [ hkey quot call ]
  61     [ hkey close-key ]
  62     [ ] cleanup ; inline
  63
  64 <PRIVATE
  65
  66 : grow-buffer ( byte-array -- byte-array' )
  67     length 2 * <byte-array> ;
  68
  69 :: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer )
  70     buffer length uint <ref> :> pdword
  71     key subkey ptr1 ptr2 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 subkey ptr1 ptr2 buffer
  79             grow-buffer reg-query-value-ex
  80         ] [
  81             ret n>win32-error-string throw
  82         ] if
  83     ] if ;
  84
  85 TUPLE: registry-info
  86 key
  87 class-name
  88 sub-keys
  89 longest-subkey
  90 longest-class-string
  91 #values
  92 max-value
  93 max-value-data
  94 security-descriptor
  95 last-write-time ;
  96
  97 TUPLE: registry-enum-key ;
  98
  99
 100 :: reg-enum-keys ( registry-info -- seq )
 101     registry-info sub-keys>> iota [
 102         [ registry-info key>> ] dip
 103         registry-value-max-length TCHAR <c-array> dup :> registry-value
 104         registry-value length dup :> registry-value-length
 105         f
 106         0 DWORD <ref> dup :> type
 107         f ! 0 BYTE <ref> dup :> data
 108         f ! 0 BYTE <ref> dup :> buffer
 109         RegEnumKeyEx dup ERROR_SUCCESS = [
 110
 111         ] [
 112         ] if
 113     ] map ;
 114
 115 :: reg-query-info-key ( key -- n )
 116     key
 117     MAX_PATH
 118     dup TCHAR <c-array> dup :> class-buffer
 119     swap int <ref> dup :> class-buffer-length
 120     f
 121     0 DWORD <ref> dup :> sub-keys
 122     0 DWORD <ref> dup :> longest-subkey
 123     0 DWORD <ref> dup :> longest-class-string
 124     0 DWORD <ref> dup :> #values
 125     0 DWORD <ref> dup :> max-value
 126     0 DWORD <ref> dup :> max-value-data
 127     0 DWORD <ref> dup :> security-descriptor
 128     FILETIME <struct> dup :> last-write-time
 129     RegQueryInfoKey :> ret
 130     ret ERROR_SUCCESS = [
 131         key
 132         class-buffer
 133         sub-keys uint deref
 134         longest-subkey uint deref
 135         longest-class-string uint deref
 136         #values uint deref
 137         max-value uint deref
 138         max-value-data uint deref
 139         security-descriptor uint deref
 140         last-write-time FILETIME>timestamp
 141         registry-info boa
 142     ] [
 143         ret n>win32-error-string
 144     ] if ;
 145
 146 : set-reg-key ( hkey value type lpdata cbdata -- )
 147     [ 0 ] 3dip
 148     RegSetValueEx dup ERROR_SUCCESS = [
 149         drop
 150     ] [
 151         "omg" throw
 152     ] if ;
 153
 154 : set-reg-binary ( hkey value lpdata cbdata -- )
 155     [ REG_BINARY ] 2dip set-reg-key ;
 156
 157 : set-reg-dword ( hkey value lpdata cbdata -- )
 158     [ REG_DWORD ] 2dip set-reg-key ;
 159
 160 : set-reg-dword-le ( hkey value lpdata cbdata -- )
 161     [ REG_DWORD_LITTLE_ENDIAN ] 2dip set-reg-key ;
 162
 163 : set-reg-dword-be ( hkey value lpdata cbdata -- )
 164     [ REG_DWORD_BIG_ENDIAN ] 2dip set-reg-key ;
 165
 166 : set-reg-expand-sz ( hkey value lpdata cbdata -- )
 167     [ REG_EXPAND_SZ ] 2dip set-reg-key ;
 168
 169 : set-reg-link ( hkey value lpdata cbdata -- )
 170     [ REG_LINK ] 2dip set-reg-key ;
 171
 172 : set-reg-multi-sz ( hkey value lpdata cbdata -- )
 173     [ REG_MULTI_SZ ] 2dip set-reg-key ;
 174
 175 : set-reg-none ( hkey value lpdata cbdata -- )
 176     [ REG_NONE ] 2dip set-reg-key ;
 177
 178 : set-reg-qword ( hkey value lpdata cbdata -- )
 179     [ REG_QWORD ] 2dip set-reg-key ;
 180
 181 : set-reg-qword-le ( hkey value lpdata cbdata -- )
 182     [ REG_QWORD_LITTLE_ENDIAN ] 2dip set-reg-key ;
 183
 184 : set-reg-sz ( hkey value lpdata cbdata -- )
 185     [ REG_SZ ] 2dip set-reg-key ;
 186
 187 PRIVATE>
 188
 189 : windows-performance-data ( -- byte-array )
 190     HKEY_PERFORMANCE_DATA "Global" f f
 191     21 2^ <byte-array> reg-query-value-ex ;
 192
 193 : read-registry ( key subkey -- registry-info )
 194     KEY_READ [ reg-query-info-key ] with-open-registry-key ;