arm.64.factor: extra semicolon removed

[factor.git] / basis / windows / registry / registry.factor

diff --git a/basis/windows/registry/registry.factor b/basis/windows/registry/registry.factor
index 968b52fbe49730285c7962f7f994edbe6de6d389..b700c9e78dad7717131c92a7248188c5d0c4e1b0 100644 (file)
--- a/basis/windows/registry/registry.factor
+++ b/basis/windows/registry/registry.factor
@@ -1,9 +1,11 @@
 ! 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
-windows.types classes.struct continuations ;
+! Copyright (C) 2018 Alexander Ilin.
+! See https://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data byte-arrays
+classes.struct continuations io.encodings.string
+io.encodings.utf16 kernel literals locals math sequences sets
+splitting windows windows.advapi32 windows.errors
+windows.kernel32 windows.time windows.types ;
 IN: windows.registry
 
 ERROR: open-key-failed key subkey mode error-string ;
@@ -43,45 +45,50 @@ CONSTANT: registry-value-max-length 16384
     f 0 KEY_ALL_ACCESS f create-key* drop ;
 
 : close-key ( hkey -- )
-    RegCloseKey dup ERROR_SUCCESS = [
-        drop
-    ] [
-        n>win32-error-string throw
-    ] if ;
+    RegCloseKey n>win32-error-check ;
 
 :: with-open-registry-key ( key subkey mode quot -- )
     key subkey mode open-key :> hkey
     [ hkey quot call ]
     [ hkey close-key ]
-    [ ] cleanup ; inline
+    finally ; inline
 
 :: with-create-registry-key ( key subkey quot -- )
     key subkey create-key :> hkey
     [ hkey quot call ]
     [ hkey close-key ]
-    [ ] cleanup ; inline
+    finally ; inline
 
 <PRIVATE
 
 : grow-buffer ( byte-array -- byte-array' )
     length 2 * <byte-array> ;
 
-:: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer )
+PRIVATE>
+
+:: reg-query-value-ex ( key value-name ptr1 lpType buffer -- buffer )
     buffer length uint <ref> :> pdword
-    key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep
+    key value-name ptr1 lpType buffer pdword [ RegQueryValueEx ] 2keep
     rot :> ret
     ret ERROR_SUCCESS = [
         uint deref head
     ] [
         ret ERROR_MORE_DATA = [
             2drop
-            key subkey ptr1 ptr2 buffer
+            key value-name ptr1 lpType buffer
             grow-buffer reg-query-value-ex
         ] [
-            ret n>win32-error-string throw
+            ret throw-windows-error
         ] if
     ] if ;
 
+: delete-value ( key value-name -- )
+    RegDeleteValue dup ERROR_SUCCESS = [
+        drop
+    ] [
+        n>win32-error-string throw
+    ] if ;
+
 TUPLE: registry-info
 key
 class-name
@@ -98,7 +105,7 @@ TUPLE: registry-enum-key ;
 
 
 :: reg-enum-keys ( registry-info -- seq )
-    registry-info sub-keys>> iota [
+    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
@@ -125,7 +132,7 @@ TUPLE: registry-enum-key ;
     0 DWORD <ref> dup :> max-value
     0 DWORD <ref> dup :> max-value-data
     0 DWORD <ref> dup :> security-descriptor
-    FILETIME <struct> dup :> last-write-time
+    FILETIME new dup :> last-write-time
     RegQueryInfoKey :> ret
     ret ERROR_SUCCESS = [
         key
@@ -184,11 +191,37 @@ TUPLE: registry-enum-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 ;
+
+:: change-registry-value ( key subkey value-name quot: ( value -- value' ) -- )
+    0 DWORD <ref> :> type
+    key subkey flags{ KEY_QUERY_VALUE KEY_SET_VALUE } [
+        dup :> hkey value-name f type MAX_PATH <byte-array>
+        reg-query-value-ex
+        type DWORD deref ${ REG_SZ REG_EXPAND_SZ REG_MULTI_SZ } in?
+        dup :> string-type? [
+            utf16n decode type DWORD deref REG_MULTI_SZ = [
+                "\0" split 2
+            ] [ 1 ] if head*
+        ] when
+        quot call( x -- x' )
+        string-type? [
+            type DWORD deref REG_MULTI_SZ = [
+                "\0" join 2
+            ] [ 1 ] if [ CHAR: \0 suffix ] times utf16n encode
+        ] when
+        [ hkey value-name type DWORD deref ] dip dup length
+        set-reg-key
+    ] with-open-registry-key ;
+
+:: query-registry ( key subkey value-name -- value )
+    key subkey KEY_READ [
+        value-name f 0 DWORD <ref> dup :> ptype MAX_PATH <byte-array> reg-query-value-ex
+        ptype DWORD deref dup :> type ${ REG_SZ REG_EXPAND_SZ REG_MULTI_SZ } in?
+        [ utf16n decode type REG_MULTI_SZ = [ "\0" split 2 ] [ 1 ] if head* ] when
+    ] with-open-registry-key ;