Get COM interface working. Add IShellFolder interface to shell32.dll to play around with

extra/windows/com/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/windows/com/com-docs.factor

@@ -0,0 +1,15 @@
+USING: help.markup help.syntax io kernel math quotations
+multiline ;
+IN: windows.com
+
+HELP: com-query-interface
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } }
+{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be immediately retained using " { $link com-add-ref } ". The pointer must then be released using " { $link com-release } " when it is no longer needed." } ;
+
+HELP: com-add-ref
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
+{ $description "A small wrapper around " { $link IUnknown::AddRef } ". Increments the reference count on " { $snippet "interface" } ", keeping it on the stack. The reference count must be decremented with " { $link com-release } " when the reference is no longer held." } ;
+
+HELP: com-release
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
+{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ;

extra/windows/com/com-tests.factor

@@ -1,5 +1,6 @@
 USING: kernel windows.com windows.com.syntax windows.ole32
-alien alien.syntax tools.test libc ;
+alien alien.syntax tools.test libc alien.c-types arrays.lib 
+namespaces arrays continuations ;
 IN: windows.com.tests
 
 ! Create some test COM interfaces
@@ -9,13 +10,17 @@ COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
     HRESULT returnError ( ) ;
 
 COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
-    int getX ( ) ;
+    int getX ( )
     void setX ( int newX ) ;
 
 ! Implement the IInherited interface in factor using alien-callbacks
 
+C-STRUCT: test-implementation
+    { "void*" "vtbl" }
+    { "int" "x" } ;
+
 : QueryInterface-callback
-    "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 -rot set-void*-nth ]
+    "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ]
     alien-callback ;
 : AddRef-callback
     "ULONG" { "void*" } "stdcall" [ drop 2 ]
@@ -24,33 +29,20 @@ COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
     "ULONG" { "void*" } "stdcall" [ drop 1 ]
     alien-callback ;
 : returnOK-callback
-    "HRESULT"{ "void*" } "stdcall" [ drop S_OK ]
+    "HRESULT" { "void*" } "stdcall" [ drop S_OK ]
     alien-callback ;
 : returnError-callback
-    "HRESULT"{ "void*" } "stdcall" [ drop E_FAIL ]
+    "HRESULT" { "void*" } "stdcall" [ drop E_FAIL ]
     alien-callback ;
 : getX-callback
-    "int" { "void*" } "stdcall" [ test-interface-x ]
+    "int" { "void*" } "stdcall" [ test-implementation-x ]
     alien-callback ;
 : setX-callback
-    "void" { "void*" "int" } "stdcall" [ swap set-test-interface-x ]
+    "void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ]
     alien-callback ;
 
 SYMBOL: +test-implementation-vtbl+
-{
+SYMBOL: +guinea-pig-implementation+
-    QueryInterface-callback
-    AddRef-callback
-    Release-callback
-    returnOK-callback
-    returnError-callback
-    getX-callback
-    setX-callback
-} [ execute ] map >c-void*-array
-+test-implementation-vtbl+ set
-
-C-STRUCT: test-implementation
-    { "void*" "vtbl" }
-    { "int" "x" } ;
 
 : (make-test-implementation) ( x imp -- imp )
     [ set-test-implementation-x ] keep
@@ -59,29 +51,43 @@ C-STRUCT: test-implementation
 : <test-implementation> ( x -- imp )
     "test-implementation" <c-object> (make-test-implementation) ;
 
-! Test that the words defined by COM-INTERFACE: do their magic
-
-"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
-"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
-"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
-S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test
-E_FAIL 1array [ 0 <test-implementation> ISimple::returnError ] unit-test
-1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test
-
-! Test that the helper functions for QueryInterface, AddRef, Release work
-
 : <malloced-test-implementation> ( x -- imp )
     "test-implementation" heap-size malloc (make-test-implementation) ;
 
-SYMBOL: +guinea-pig-implementation+
+QueryInterface-callback
+AddRef-callback
+Release-callback
+returnOK-callback
+returnError-callback
+getX-callback
+setX-callback
+7 narray >c-void*-array
+dup byte-length [
+    [ byte-array>memory ] keep
+    +test-implementation-vtbl+ set
 
-0 <malloced-test-implementation> +guinea-pig-implementation+ set
+    ! Test that the words defined by COM-INTERFACE: do their magic
-[
-    +guinea-pig-implementation+ get 1array [
-        +guinea-pig-implementation+ get IUnknown-iid com-query-interface
-    ] unit-test
 
-    { } [ +guinea-pig-implementation+ get com-add-ref ] unit-test
+    "{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
-    { } [ +guinea-pig-implementation+ get com-release ] unit-test
+    "{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
-] [ +guinea-pig-implementation+ get free ] [ ] cleanup
+    "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
+    S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test
+    E_FAIL <long> *long 1array [ 0 <test-implementation> ISimple::returnError ] unit-test
+    1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test
 
+    ! Test that the helper functions for QueryInterface, AddRef, Release work
+
+    0 <malloced-test-implementation> +guinea-pig-implementation+ set
+    [
+        +guinea-pig-implementation+ get 1array [
+            +guinea-pig-implementation+ get com-add-ref
+        ] unit-test
+
+        { } [ +guinea-pig-implementation+ get com-release ] unit-test
+
+        +guinea-pig-implementation+ get 1array [
+            +guinea-pig-implementation+ get IUnknown-iid com-query-interface
+        ] unit-test
+
+    ] [ +guinea-pig-implementation+ get free ] [ ] cleanup
+] with-malloc

extra/windows/com/com.factor

@@ -1,5 +1,5 @@
 USING: alien alien.c-types windows.com.syntax windows.ole32
-windows.types continuations ;
+windows.types continuations kernel ;
 IN: windows.com
 
 COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
@@ -8,10 +8,15 @@ COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
     ULONG Release ( ) ;
 
 : com-query-interface ( interface iid -- interface' )
-    f <void*> [ IUnknown::QueryInterface ] keep *void* ;
+    f <void*>
+    [ IUnknown::QueryInterface ole32-error ] keep
+    *void* ;
 
-: com-add-ref ( interface -- )
+: com-add-ref ( interface -- interface )
-    IUnknown::AddRef drop ; inline
+     [ IUnknown::AddRef drop ] keep ; inline
 
 : com-release ( interface -- )
     IUnknown::Release drop ; inline
+
+: with-com-interface ( interface quot -- )
+    [ keep ] [ com-release ] [ ] cleanup ; inline

extra/windows/com/summary.txt

@@ -0,0 +1 @@
+COM interface

extra/windows/com/syntax/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/windows/com/syntax/summary.txt

@@ -0,0 +1 @@
+Parsing words for defining COM interfaces

extra/windows/com/syntax/syntax-docs.factor

@@ -0,0 +1,26 @@
+USING: help.markup help.syntax io kernel math quotations
+multiline ;
+IN: windows.com.syntax
+
+HELP: COM-INTERFACE:
+{ $syntax <"
+COM-INTERFACE: <interface> <parent> <iid>
+    <function-1> ( <params1> )
+    <function-2> ( <params2> )
+    ... ;
+"> }
+{ $description "\nFor the interface " { $snippet "<interface>" } ", a word " { $snippet "<interface>-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "<interface>::<function>" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "<parent>" } ". A " { $snippet "<parent>" } " of " { $snippet "f" } " indicates that the interface is a root interface. (Note that COM conventions demand that all interfaces at least inherit from " { $snippet "IUnknown" } ".)\n\nExample:" }
+{ $code <"
+COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
+    HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
+    ULONG AddRef ( )
+    ULONG Release ( ) ;
+
+COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
+    HRESULT returnOK ( )
+    HRESULT returnError ( ) ;
+
+COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
+    int getX ( )
+    void setX ( int newX ) ;
+"> } ;

extra/windows/com/syntax/syntax.factor

@@ -1,15 +1,21 @@
 USING: alien alien.c-types kernel windows.ole32
 combinators.lib parser splitting sequences.lib
 sequences namespaces new-slots combinators.cleave
-assocs quotations shuffle ;
+assocs quotations shuffle accessors words macros
+alien.syntax fry ;
 IN: windows.com.syntax
 
 <PRIVATE
 
-: com-invoke ( ... interface-ptr n return parameters -- )
+C-STRUCT: com-interface
-    "stdcall" [
+    { "void*" "vtbl" } ;
-        [ *void* ] dip void*-nth
+
-    ] 3 ndip alien-indirect ; inline
+MACRO: com-invoke ( n return parameters -- )
+    dup length -roll
+    '[
+        , npick com-interface-vtbl , swap void*-nth , ,
+        "stdcall" alien-indirect
+    ] ;
 
 TUPLE: com-interface-definition name parent iid functions ;
 C: <com-interface-definition> com-interface-definition
@@ -18,7 +24,9 @@ TUPLE: com-function-definition name return parameters ;
 C: <com-function-definition> com-function-definition
 
 SYMBOL: +com-interface-definitions+
-H{ } +com-interface-definitions+ set-global
++com-interface-definitions+ get-global
+[ H{ } +com-interface-definitions+ set-global ]
+unless
 
 : find-com-interface-definition ( name -- definition )
     dup "f" = [ drop f ] [
@@ -40,6 +48,7 @@ H{ } +com-interface-definitions+ set-global
 
 : parse-com-functions ( -- functions )
     ";" parse-tokens { ")" } split
+    [ empty? not ] subset
     [ (parse-com-function) ] map ;
 
 : (iid-word) ( definition -- word )
@@ -55,17 +64,17 @@ H{ } +com-interface-definitions+ set-global
 : (define-word-for-function) ( function interface n -- )
     -rot [ (function-word) swap ] 2keep drop
     { return>> parameters>> } get-slots
-    [ [ com-invoke ] 3curry ] keep
+    [ com-invoke ] 3curry
-    length [ npick ] curry swap compose
     define ;
 
 : define-words-for-com-interface ( definition -- )
     [ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
+    [ name>> "com-interface" swap typedef ]
     [
         dup all-functions
         [ (define-word-for-function) ] with each-index
     ]
-    bi ;
+    tri ;
 
 PRIVATE>
 

extra/windows/com/syntax/tags.txt

@@ -0,0 +1,3 @@
+windows
+com
+bindings

extra/windows/com/tags.txt

@@ -0,0 +1,3 @@
+windows
+com
+bindings

extra/windows/ole32/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/windows/ole32/ole32.factor

@@ -13,6 +13,10 @@ C-STRUCT: GUID
 TYPEDEF: void* REFGUID
 TYPEDEF: void* LPUNKNOWN
 TYPEDEF: ushort* LPOLESTR
+TYPEDEF: ushort* LPCOLESTR
+
+TYPEDEF: REFGUID REFIID
+TYPEDEF: REFGUID REFCLSID
 
 FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
 FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
@@ -24,6 +28,18 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
 : E_FAIL HEX: 80004005 ; inline
 : E_INVALIDARG HEX: 80070057 ; inline
 
+: MK_ALT HEX: 20 ; inline
+: DROPEFFECT_NONE 0 ; inline
+: DROPEFFECT_COPY 1 ; inline
+: DROPEFFECT_MOVE 2 ; inline
+: DROPEFFECT_LINK 4 ; inline
+: DROPEFFECT_SCROLL HEX: 80000000 ; inline
+: DD_DEFSCROLLINSET 11 ; inline
+: DD_DEFSCROLLDELAY 50 ; inline
+: DD_DEFSCROLLINTERVAL 50 ; inline
+: DD_DEFDRAGDELAY 200 ; inline
+: DD_DEFDRAGMINDIST 2 ; inline
+
 : ole32-error ( n -- )
     dup S_OK = [
         drop

extra/windows/shell32/shell32.factor

@@ -1,5 +1,6 @@
 USING: alien alien.c-types alien.syntax combinators
-kernel windows windows.user32 windows.ole32 ;
+kernel windows windows.user32 windows.ole32
+windows.com windows.com.syntax ;
 IN: windows.shell32
 
 : CSIDL_DESKTOP HEX: 00 ; inline
@@ -118,3 +119,97 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
 
 : program-files-common-x86 ( -- str )
     CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ;
+
+: SHCONTF_FOLDERS 32 ; inline
+: SHCONTF_NONFOLDERS 64 ; inline
+: SHCONTF_INCLUDEHIDDEN 128 ; inline
+: SHCONTF_INIT_ON_FIRST_NEXT 256 ; inline
+: SHCONTF_NETPRINTERSRCH 512 ; inline
+: SHCONTF_SHAREABLE 1024 ; inline
+: SHCONTF_STORAGE 2048 ; inline
+
+TYPEDEF: DWORD SHCONTF
+
+: SHGDN_NORMAL 0 ; inline
+: SHGDN_INFOLDER 1 ; inline
+: SHGDN_FOREDITING HEX: 1000 ; inline
+: SHGDN_INCLUDE_NONFILESYS HEX: 2000 ; inline
+: SHGDN_FORADDRESSBAR HEX: 4000 ; inline
+: SHGDN_FORPARSING HEX: 8000 ; inline
+
+TYPEDEF: DWORD SHGDNF
+
+: SFGAO_CANCOPY           DROPEFFECT_COPY ; inline
+: SFGAO_CANMOVE           DROPEFFECT_MOVE ; inline
+: SFGAO_CANLINK           DROPEFFECT_LINK ; inline
+: SFGAO_CANRENAME         HEX: 00000010 ; inline
+: SFGAO_CANDELETE         HEX: 00000020 ; inline
+: SFGAO_HASPROPSHEET      HEX: 00000040 ; inline
+: SFGAO_DROPTARGET        HEX: 00000100 ; inline
+: SFGAO_CAPABILITYMASK    HEX: 00000177 ; inline
+: SFGAO_LINK              HEX: 00010000 ; inline
+: SFGAO_SHARE             HEX: 00020000 ; inline
+: SFGAO_READONLY          HEX: 00040000 ; inline
+: SFGAO_GHOSTED           HEX: 00080000 ; inline
+: SFGAO_HIDDEN            HEX: 00080000 ; inline
+: SFGAO_DISPLAYATTRMASK   HEX: 000F0000 ; inline
+: SFGAO_FILESYSANCESTOR   HEX: 10000000 ; inline
+: SFGAO_FOLDER            HEX: 20000000 ; inline
+: SFGAO_FILESYSTEM        HEX: 40000000 ; inline
+: SFGAO_HASSUBFOLDER      HEX: 80000000 ; inline
+: SFGAO_CONTENTSMASK      HEX: 80000000 ; inline
+: SFGAO_VALIDATE          HEX: 01000000 ; inline
+: SFGAO_REMOVABLE         HEX: 02000000 ; inline
+: SFGAO_COMPRESSED        HEX: 04000000 ; inline
+: SFGAO_BROWSABLE         HEX: 08000000 ; inline
+: SFGAO_NONENUMERATED     HEX: 00100000 ; inline
+: SFGAO_NEWCONTENT        HEX: 00200000 ; inline
+
+TYPEDEF: ULONG SFGAOF
+
+C-STRUCT: SHITEMID
+    { "USHORT" "cb" }
+    { "BYTE[1]" "abID" } ;
+TYPEDEF: SHITEMID* LPSHITEMID
+TYPEDEF: SHITEMID* LPCSHITEMID
+
+C-STRUCT: ITEMIDLIST
+    { "SHITEMID" "mkid" } ;
+TYPEDEF: ITEMIDLIST* LPITEMIDLIST
+TYPEDEF: ITEMIDLIST* LPCITEMIDLIST
+TYPEDEF: ITEMIDLIST ITEMID_CHILD
+TYPEDEF: ITEMID_CHILD* PITEMID_CHILD
+TYPEDEF: ITEMID_CHILD* PCUITEMID_CHILD
+
+: STRRET_WSTR 0 ; inline
+: STRRET_OFFSET 1 ; inline
+: STRRET_CSTR 2 ; inline
+
+C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
+C-STRUCT: STRRET
+    { "int" "uType" }
+    { "STRRET-union" "union" } ;
+
+COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
+    HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )
+    HRESULT Skip ( ULONG celt )
+    HRESULT Reset ( )
+    HRESULT Clone ( IEnumIDList** ppenum ) ;
+
+COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046}
+    HRESULT ParseDisplayName ( HWND hwndOwner, void* pbcReserved, LPOLESTR lpszDisplayName, ULONG* pchEaten, LPITEMIDLIST* ppidl, ULONG* pdwAttributes )
+    HRESULT EnumObjects ( HWND hwndOwner, SHCONTF grfFlags, IEnumIDList** ppenumIDList )
+    HRESULT BindToObject ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvOut )
+    HRESULT BindToStorage ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvObj )
+    HRESULT CompareIDs ( LPARAM lParam, LPCITEMIDLIST pidl1, LPCITEMIDLIST pidl2 )
+    HRESULT CreateViewObject ( HWND hwndOwner, REFGUID riid, void** ppvOut )
+    HRESULT GetAttributesOf ( UINT cidl, LPCITEMIDLIST* apidl, SFGAOF* rgfInOut
+ )
+    HRESULT GetUIObjectOf ( HWND hwndOwner, UINT cidl, LPCITEMIDLIST* apidl, REFGUID riid, UINT* prgfInOut, void** ppvOut )
+    HRESULT GetDisplayNameOf ( LPCITEMIDLIST pidl, SHGDNF uFlags, STRRET* lpName )
+    HRESULT SetNameOf ( HWND hwnd, LPCITEMIDLIST pidl, LPCOLESTR lpszName, SHGDNF uFlags, LPITEMIDLIST* ppidlOut ) ;
+
+FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ;
+
+FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ;
+: StrRetToBuf StrRetToBufW ; inline