Add a basic windows registry vocabulary

basis/windows/registry/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/windows/registry/platforms.txt

@@ -0,0 +1 @@
+windows

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

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 <c-object>
+    [
+        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 <c-object>
+    DWORD <c-object>
+    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
+
+<PRIVATE
+
+: grow-buffer ( byte-array -- byte-array' )
+    length 2 * <byte-array> ;
+
+:: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer )
+    buffer length <uint> :> 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 <c-array> dup :> registry-value
+        registry-value length dup :> registry-value-length
+        f
+        DWORD <c-object> dup :> type
+        f ! BYTE <c-object> dup :> data
+        f ! BYTE <c-object> dup :> buffer
+        RegEnumKeyEx dup ERROR_SUCCESS = [
+            
+        ] [
+        ] if
+    ] map ;
+
+:: reg-query-info-key ( key -- n )
+    key
+    MAX_PATH
+    dup TCHAR <c-array> dup :> class-buffer
+    swap <int> dup :> class-buffer-length
+    f
+    DWORD <c-object> dup :> sub-keys
+    DWORD <c-object> dup :> longest-subkey
+    DWORD <c-object> dup :> longest-class-string
+    DWORD <c-object> dup :> #values
+    DWORD <c-object> dup :> max-value
+    DWORD <c-object> dup :> max-value-data
+    DWORD <c-object> dup :> security-descriptor
+    FILETIME <struct> 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^ <byte-array> reg-query-value-ex ;
+    
+: read-registry ( key subkey -- registry-info )
+    KEY_READ [ reg-query-info-key ] with-open-registry-key ;