Merge branch 'master' of git://repo.or.cz/factor/jcg

basis/windows/ole32/ole32.factor

@@ -1,6 +1,6 @@
 USING: alien alien.syntax alien.c-types alien.strings math
 kernel sequences windows windows.types debugger io accessors
-math.order ;
+math.order namespaces math.parser windows.kernel32 combinators ;
 IN: windows.ole32
 
 LIBRARY: ole32
@@ -128,14 +128,54 @@ M: ole32-error error.
     f OleInitialize ole32-error ;
 
 : guid= ( a b -- ? )
-    IsEqualGUID c-bool> ;
+    [ 16 memory>byte-array ] bi@ = ;
 
 : GUID-STRING-LENGTH
     "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
 
-: string>guid ( string -- guid )
-    utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
-: guid>string ( guid -- string )
-    GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
-    [ StringFromGUID2 drop ] 2keep drop utf16n alien>string ;
+: (guid-section>guid) ( guid string start end quot -- )
+    [ roll subseq hex> swap ] dip call ; inline
+: (guid-byte>guid) ( guid string start end byte -- )
+    [ roll subseq hex> ] dip
+    rot GUID-Data4 set-uchar-nth ; inline
+
+: string>guid ( string -- guid )
+    "GUID" <c-object> [ {
+        [  1  9 [ set-GUID-Data1 ] (guid-section>guid) ]
+
+        [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
+
+        [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
+
+        [ 20 22 0 (guid-byte>guid) ]
+        [ 22 24 1 (guid-byte>guid) ]
+
+        [ 25 27 2 (guid-byte>guid) ]
+        [ 27 29 3 (guid-byte>guid) ]
+        [ 29 31 4 (guid-byte>guid) ]
+        [ 31 33 5 (guid-byte>guid) ]
+        [ 33 35 6 (guid-byte>guid) ]
+        [ 35 37 7 (guid-byte>guid) ]
+    } 2cleave ] keep ;
+
+: (guid-section%) ( guid quot len -- )
+    [ call >hex ] dip CHAR: 0 pad-left % ; inline
+: (guid-byte%) ( guid byte -- )
+    swap GUID-Data4 uchar-nth >hex 2
+    CHAR: 0 pad-left % ; inline
+
+: guid>string ( guid -- string )
+    [ "{" % {
+        [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
+        [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
+        [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
+        [ 0 (guid-byte%) ]
+        [ 1 (guid-byte%) "-" % ]
+        [ 2 (guid-byte%) ]
+        [ 3 (guid-byte%) ]
+        [ 4 (guid-byte%) ]
+        [ 5 (guid-byte%) ]
+        [ 6 (guid-byte%) ]
+        [ 7 (guid-byte%) "}" % ]
+    } cleave ] "" make ;
 

extra/game-input/game-input.factor

@@ -1,5 +1,5 @@
 USING: arrays accessors continuations kernel symbols
-combinators.lib sequences namespaces ;
+combinators.lib sequences namespaces init ;
 IN: game-input
 
 SYMBOLS: game-input-backend game-input-opened ;
@@ -10,6 +10,16 @@ HOOK: (close-game-input) game-input-backend ( -- )
 : game-input-opened? ( -- ? )
     game-input-opened get ;
 
+<PRIVATE
+
+: reset-game-input ( -- )
+    game-input-opened off ;
+
+[ reset-game-input ] "game-input" add-init-hook
+
+PRIVATE>
+
+
 : open-game-input ( -- )
     game-input-opened? [
         (open-game-input) 
@@ -18,7 +28,7 @@ HOOK: (close-game-input) game-input-backend ( -- )
 : close-game-input ( -- )
     game-input-opened? [
         (close-game-input) 
-        game-input-opened off
+        reset-game-input
     ] when ;
 
 : with-game-input ( quot -- )

extra/windows/ole32/ole32-tests.factor

@@ -0,0 +1,36 @@
+USING: kernel tools.test windows.ole32 alien.c-types ;
+IN: windows.ole32.tests
+
+[ t ] [
+    "{01234567-89ab-cdef-0123-456789abcdef}" string>guid
+    "{01234567-89ab-cdef-0123-456789abcdef}" string>guid
+    guid=
+] unit-test
+        
+[ f ] [
+    "{76543210-89ab-cdef-0123-456789abcdef}" string>guid
+    "{01234567-89ab-cdef-0123-456789abcdef}" string>guid
+    guid=
+] unit-test
+        
+[ f ] [
+    "{01234567-89ab-cdef-0123-fedcba987654}" string>guid
+    "{01234567-89ab-cdef-0123-456789abcdef}" string>guid
+    guid=
+] unit-test
+        
+little-endian?
+[ B{
+    HEX: 67 HEX: 45 HEX: 23 HEX: 01 HEX: ab HEX: 89 HEX: ef HEX: cd
+    HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
+} ]
+[ B{
+    HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
+    HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
+} ] ?
+[ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid ]
+unit-test
+
+[ "{01234567-89ab-cdef-0123-456789abcdef}" ]
+[ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid guid>string ]
+unit-test