Rewrite string>guid and guid>string in windows.ole32 so it can load on any platform. Add an init hook to game-input to put it back in the "off" state on image load.
							parent
							
								
									3a7dd35e39
								
							
						
					
					
						commit
						0ed6fb0555
					
				| 
						 | 
				
			
			@ -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 -- )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			@ -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 ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue