diff --git a/extra/windows/com/authors.txt b/extra/windows/com/authors.txt new file mode 100755 index 0000000000..6a1b3e726a --- /dev/null +++ b/extra/windows/com/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/windows/com/com-docs.factor b/extra/windows/com/com-docs.factor new file mode 100755 index 0000000000..901a88675f --- /dev/null +++ b/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." } ; diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor index 2e6e8a9c22..4a2f465fef 100755 --- a/extra/windows/com/com-tests.factor +++ b/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+ -{ - 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" } ; +SYMBOL: +guinea-pig-implementation+ : (make-test-implementation) ( x imp -- imp ) [ set-test-implementation-x ] keep @@ -59,29 +51,43 @@ C-STRUCT: test-implementation : ( x -- imp ) "test-implementation" (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 ISimple::returnOK ] unit-test -E_FAIL 1array [ 0 ISimple::returnError ] unit-test -1984 1array [ 0 dup 1984 IInherited::setX IInherited::getX ] unit-test - -! Test that the helper functions for QueryInterface, AddRef, Release work - : ( 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 +guinea-pig-implementation+ set -[ - +guinea-pig-implementation+ get 1array [ - +guinea-pig-implementation+ get IUnknown-iid com-query-interface - ] unit-test + ! Test that the words defined by COM-INTERFACE: do their magic - { } [ +guinea-pig-implementation+ get com-add-ref ] unit-test - { } [ +guinea-pig-implementation+ get com-release ] unit-test -] [ +guinea-pig-implementation+ get free ] [ ] cleanup + "{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 ISimple::returnOK ] unit-test + E_FAIL *long 1array [ 0 ISimple::returnError ] unit-test + 1984 1array [ 0 dup 1984 IInherited::setX IInherited::getX ] unit-test + ! Test that the helper functions for QueryInterface, AddRef, Release work + + 0 +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 diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor index 477eaad038..b78d9b5b91 100755 --- a/extra/windows/com/com.factor +++ b/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 [ IUnknown::QueryInterface ] keep *void* ; + f + [ IUnknown::QueryInterface ole32-error ] keep + *void* ; -: com-add-ref ( interface -- ) - IUnknown::AddRef drop ; inline +: com-add-ref ( interface -- interface ) + [ IUnknown::AddRef drop ] keep ; inline : com-release ( interface -- ) IUnknown::Release drop ; inline + +: with-com-interface ( interface quot -- ) + [ keep ] [ com-release ] [ ] cleanup ; inline diff --git a/extra/windows/com/summary.txt b/extra/windows/com/summary.txt new file mode 100755 index 0000000000..779367e673 --- /dev/null +++ b/extra/windows/com/summary.txt @@ -0,0 +1 @@ +COM interface diff --git a/extra/windows/com/syntax/authors.txt b/extra/windows/com/syntax/authors.txt new file mode 100755 index 0000000000..6a1b3e726a --- /dev/null +++ b/extra/windows/com/syntax/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/windows/com/syntax/summary.txt b/extra/windows/com/syntax/summary.txt new file mode 100755 index 0000000000..6c2977a108 --- /dev/null +++ b/extra/windows/com/syntax/summary.txt @@ -0,0 +1 @@ +Parsing words for defining COM interfaces diff --git a/extra/windows/com/syntax/syntax-docs.factor b/extra/windows/com/syntax/syntax-docs.factor new file mode 100755 index 0000000000..fa06d5e4e7 --- /dev/null +++ b/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: + ( ) + ( ) + ... ; +"> } +{ $description "\nFor the interface " { $snippet "" } ", a word " { $snippet "-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "::" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "" } ". A " { $snippet "" } " 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 ) ; +"> } ; diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index 9068d75d16..32e7433d88 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/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 com-interface-definition @@ -18,7 +24,9 @@ TUPLE: com-function-definition name return parameters ; C: 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 - length [ npick ] curry swap compose + [ com-invoke ] 3curry 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> diff --git a/extra/windows/com/syntax/tags.txt b/extra/windows/com/syntax/tags.txt new file mode 100755 index 0000000000..49139bab66 --- /dev/null +++ b/extra/windows/com/syntax/tags.txt @@ -0,0 +1,3 @@ +windows +com +bindings diff --git a/extra/windows/com/tags.txt b/extra/windows/com/tags.txt new file mode 100755 index 0000000000..49139bab66 --- /dev/null +++ b/extra/windows/com/tags.txt @@ -0,0 +1,3 @@ +windows +com +bindings diff --git a/extra/windows/ole32/authors.txt b/extra/windows/ole32/authors.txt new file mode 100755 index 0000000000..6a1b3e726a --- /dev/null +++ b/extra/windows/ole32/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor index ec0b02bc3f..44ea853af0 100755 --- a/extra/windows/ole32/ole32.factor +++ b/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 diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor index 1d8d67dad7..e32b2dc058 100755 --- a/extra/windows/shell32/shell32.factor +++ b/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