From: Doug Coleman Date: Wed, 29 Sep 2010 16:19:30 +0000 (-0500) Subject: Add a basic windows registry vocabulary X-Git-Tag: 0.97~4257^2~42 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=67fa5080f4d116ff02f8d0c60deeca8756a189bf Add a basic windows registry vocabulary --- diff --git a/basis/windows/registry/authors.txt b/basis/windows/registry/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/windows/registry/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/windows/registry/platforms.txt b/basis/windows/registry/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/basis/windows/registry/platforms.txt @@ -0,0 +1 @@ +windows diff --git a/basis/windows/registry/registry-tests.factor b/basis/windows/registry/registry-tests.factor new file mode 100644 index 0000000000..8a8c55780f --- /dev/null +++ b/basis/windows/registry/registry-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel tools.test windows.advapi32 windows.registry ; +IN: windows.registry.tests + +[ ] +[ HKEY_CURRENT_USER "SOFTWARE\\\\Microsoft" read-registry drop ] unit-test \ No newline at end of file diff --git a/basis/windows/registry/registry.factor b/basis/windows/registry/registry.factor new file mode 100644 index 0000000000..25c80061b2 --- /dev/null +++ b/basis/windows/registry/registry.factor @@ -0,0 +1,194 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types byte-arrays kernel locals sequences +windows.advapi32 windows.errors math windows +windows.kernel32 windows.time accessors alien.data +nested-comments windows.types classes.struct continuations ; +IN: windows.registry + +ERROR: open-key-failed key subkey mode error-string ; +ERROR: create-key-failed hKey lpSubKey lpClass dwOptions +samDesired lpSecurityAttributes phkResult lpdwDisposition ; + +CONSTANT: registry-value-max-length 16384 + +:: open-key ( key subkey mode -- hkey ) + key subkey 0 mode HKEY + [ + RegOpenKeyEx dup ERROR_SUCCESS = [ + drop + ] [ + [ key subkey mode ] dip n>win32-error-string + open-key-failed + ] if + ] keep *uint ; + +:: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? ) + hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes + HKEY + DWORD + f :> ret! + [ RegCreateKeyEx ret! ] 2keep + [ *uint ] + [ *uint REG_CREATED_NEW_KEY = ] bi* + ret ERROR_SUCCESS = [ + [ + hKey lpSubKey 0 lpClass dwOptions samDesired + lpSecurityAttributes + ] dip n>win32-error-string + create-key-failed + ] unless ; + +: create-key ( hkey lsubkey -- hkey ) + f 0 KEY_ALL_ACCESS f create-key* drop ; + +: close-key ( hkey -- ) + RegCloseKey dup ERROR_SUCCESS = [ + drop + ] [ + n>win32-error-string throw + ] if ; + +:: with-open-registry-key ( key subkey mode quot -- ) + key subkey mode open-key :> hkey + [ hkey quot call ] + [ hkey close-key ] + [ ] cleanup ; inline + +:: with-create-registry-key ( key subkey quot -- ) + key subkey create-key :> hkey + [ hkey quot call ] + [ hkey close-key ] + [ ] cleanup ; inline + + ; + +:: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer ) + buffer length :> pdword + key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep + rot :> ret + ret ERROR_SUCCESS = [ + *uint head + ] [ + ret ERROR_MORE_DATA = [ + 2drop + key subkey ptr1 ptr2 buffer + grow-buffer reg-query-value-ex + ] [ + ret n>win32-error-string throw + ] if + ] if ; + +TUPLE: registry-info +key +class-name +sub-keys +longest-subkey +longest-class-string +#values +max-value +max-value-data +security-descriptor +last-write-time ; + +TUPLE: registry-enum-key ; + + +:: reg-enum-keys ( registry-info -- seq ) + registry-info sub-keys>> iota [ + [ registry-info key>> ] dip + registry-value-max-length TCHAR dup :> registry-value + registry-value length dup :> registry-value-length + f + DWORD dup :> type + f ! BYTE dup :> data + f ! BYTE dup :> buffer + RegEnumKeyEx dup ERROR_SUCCESS = [ + + ] [ + ] if + ] map ; + +:: reg-query-info-key ( key -- n ) + key + MAX_PATH + dup TCHAR dup :> class-buffer + swap dup :> class-buffer-length + f + DWORD dup :> sub-keys + DWORD dup :> longest-subkey + DWORD dup :> longest-class-string + DWORD dup :> #values + DWORD dup :> max-value + DWORD dup :> max-value-data + DWORD dup :> security-descriptor + FILETIME dup :> last-write-time + RegQueryInfoKey :> ret + ret ERROR_SUCCESS = [ + key + class-buffer + sub-keys *uint + longest-subkey *uint + longest-class-string *uint + #values *uint + max-value *uint + max-value-data *uint + security-descriptor *uint + last-write-time FILETIME>timestamp + registry-info boa + ] [ + ret n>win32-error-string + ] if ; + +: set-reg-key ( hkey value type lpdata cbdata -- ) + [ 0 ] 3dip + RegSetValueEx dup ERROR_SUCCESS = [ + drop + ] [ + "omg" throw + ] if ; + +: set-reg-binary ( hkey value lpdata cbdata -- ) + [ REG_BINARY ] 2dip set-reg-key ; + +: set-reg-dword ( hkey value lpdata cbdata -- ) + [ REG_DWORD ] 2dip set-reg-key ; + +: set-reg-dword-le ( hkey value lpdata cbdata -- ) + [ REG_DWORD_LITTLE_ENDIAN ] 2dip set-reg-key ; + +: set-reg-dword-be ( hkey value lpdata cbdata -- ) + [ REG_DWORD_BIG_ENDIAN ] 2dip set-reg-key ; + +: set-reg-expand-sz ( hkey value lpdata cbdata -- ) + [ REG_EXPAND_SZ ] 2dip set-reg-key ; + +: set-reg-link ( hkey value lpdata cbdata -- ) + [ REG_LINK ] 2dip set-reg-key ; + +: set-reg-multi-sz ( hkey value lpdata cbdata -- ) + [ REG_MULTI_SZ ] 2dip set-reg-key ; + +: set-reg-none ( hkey value lpdata cbdata -- ) + [ REG_NONE ] 2dip set-reg-key ; + +: set-reg-qword ( hkey value lpdata cbdata -- ) + [ REG_QWORD ] 2dip set-reg-key ; + +: set-reg-qword-le ( hkey value lpdata cbdata -- ) + [ REG_QWORD_LITTLE_ENDIAN ] 2dip set-reg-key ; + +: set-reg-sz ( hkey value lpdata cbdata -- ) + [ REG_SZ ] 2dip set-reg-key ; + +PRIVATE> + +: windows-performance-data ( -- byte-array ) + HKEY_PERFORMANCE_DATA "Global" f f + 21 2^ reg-query-value-ex ; + +: read-registry ( key subkey -- registry-info ) + KEY_READ [ reg-query-info-key ] with-open-registry-key ; \ No newline at end of file