Get COM wrappers working. dragdrop-listener example vocab to enable drag-and-drop on listener windows

db4
Joe Groff 2008-03-31 12:31:46 -07:00
parent ca5e517934
commit f2718f3a71
12 changed files with 386 additions and 31 deletions

View File

@ -12,7 +12,7 @@ ARTICLE: "accessors" "Slot accessors"
}
"In addition, two utility words are defined for each distinct slot name used in the system:"
{ $list
{ "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
{ "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
{ "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." }
}
"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names."

View File

@ -4,7 +4,7 @@ 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." } ;
{ $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 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" } } }

View File

@ -1,6 +1,7 @@
USING: kernel windows.com windows.com.syntax windows.ole32
alien alien.syntax tools.test libc alien.c-types arrays.lib
namespaces arrays continuations accessors ;
namespaces arrays continuations accessors math windows.com.wrapper
windows.com.wrapper.private ;
IN: windows.com.tests
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
@ -18,12 +19,16 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
"{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
"{b06ac3f4-30e4-406b-a7cd-c29cead4552c}" string>guid 1array [ IUnrelated-iid ] unit-test
SYMBOL: +test-vtbl+
SYMBOL: +test-wrapper+
SYMBOL: +guinea-pig-implementation+
SYMBOL: +orig-wrapped-objects+
+wrapped-objects+ get-global clone +orig-wrapped-objects+ set-global
TUPLE: test-implementation x ;
C: test-implementation <test-implementation>
C: <test-implementation> test-implementation
{
{ "IInherited" {
@ -36,17 +41,25 @@ C: test-implementation <test-implementation>
[ swap x>> + ] ! IUnrelated::xPlus
[ spin x>> * + ] ! IUnrealted::xMulAdd
} }
} <com-vtbl>
dup +test-vtbl+ set [
} <com-wrapper>
dup +test-wrapper+ set [
0 <test-implementation> +test-vtbl+ get com-wrap
dup +guinea-pig-implementation+ set [
0 <test-implementation> swap com-wrap
dup +guinea-pig-implementation+ set [ drop
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test
420 1array [ +guinea-pig-implementation+ get 20 20 IUnrelated::xMulAdd ] unit-test
40 1array [ +guinea-pig-implementation+ get 20 IUnrelated::xPlus ] unit-test
420 1array [
+guinea-pig-implementation+ get
IUnrelated-iid com-query-interface
[ 20 20 IUnrelated::xMulAdd ] with-com-interface
] unit-test
40 1array [
+guinea-pig-implementation+ get
IUnrelated-iid com-query-interface
[ 20 IUnrelated::xPlus ] with-com-interface
] unit-test
+guinea-pig-implementation+ get 1array [
+guinea-pig-implementation+ get com-add-ref
@ -56,14 +69,23 @@ dup +test-vtbl+ set [
+guinea-pig-implementation+ get 1array [
+guinea-pig-implementation+ get IUnknown-iid com-query-interface
dup com-release
] unit-test
+guinea-pig-implementation+ get 1array [
+guinea-pig-implementation+ get ISimple-iid com-query-interface
dup com-release
] unit-test
"void*" heap-size +guinea-pig-implementation+ get <displaced-alien> 1array [
"void*" heap-size +guinea-pig-implementation+ get <displaced-alien>
+guinea-pig-implementation+ get
2array [
+guinea-pig-implementation+ get IUnrelated-iid com-query-interface
dup ISimple-iid com-query-interface
over com-release dup com-release
] unit-test
] with-com-interface
] [ free-com-vtbl ] [ ] cleanup
] with-disposal
! Ensure that we freed +guinea-pig-implementation
+orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test

View File

@ -1,12 +1,31 @@
USING: alien alien.c-types windows.com.syntax windows.ole32
windows.types continuations kernel ;
windows.types continuations kernel alien.syntax ;
IN: windows.com
LIBRARY: ole32
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
ULONG AddRef ( )
ULONG Release ( ) ;
COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}
HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
HRESULT QueryGetData ( FORMATETC* pFormatetc )
HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut )
HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease )
HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc )
HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection )
HRESULT DUnadvise ( DWORD pdwConnection )
HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ;
COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
HRESULT DragLeave ( )
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
: com-query-interface ( interface iid -- interface' )
f <void*>
[ IUnknown::QueryInterface ole32-error ] keep
@ -19,4 +38,4 @@ COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
IUnknown::Release drop ; inline
: with-com-interface ( interface quot -- )
[ keep ] [ com-release ] [ ] cleanup ; inline
over [ slip ] [ com-release ] [ ] cleanup ; inline

View File

@ -57,8 +57,12 @@ unless
: (function-word) ( function interface -- word )
name>> "::" rot name>> 3append create-in ;
: all-functions ( definition -- functions )
dup parent>> [ all-functions ] [ { } ] if*
: family-tree ( definition -- definitions )
dup parent>> [ family-tree ] [ { } ] if*
swap add ;
: family-tree-functions ( definition -- functions )
dup parent>> [ family-tree-functions ] [ { } ] if*
swap functions>> append ;
: (define-word-for-function) ( function interface n -- )
@ -71,7 +75,7 @@ unless
[ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
[ name>> "com-interface" swap typedef ]
[
dup all-functions
dup family-tree-functions
[ (define-word-for-function) ] with each-index
]
tri ;

View File

@ -0,0 +1,40 @@
USING: help.markup help.syntax io kernel math quotations
multiline alien windows.com windows.com.syntax continuations ;
IN: windows.com.wrapper
HELP: <com-wrapper>
{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } }
{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "<com-wrapper>" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper objects and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" }
{ $code <"
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 ) ;
COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
int xPlus ( int y )
int xMulAdd ( int mul, int add ) ;
{
{ "IInherited" {
[ drop S_OK ] ! ISimple::returnOK
[ drop E_FAIL ] ! ISimple::returnError
[ x>> ] ! IInherited::getX
[ >>x drop ] ! IInherited::setX
} }
{ "IUnrelated" {
[ swap x>> + ] ! IUnrelated::xPlus
[ spin x>> * + ] ! IUnrealted::xMulAdd
} }
} <com-wrapper>
"> } ;
HELP: com-wrap
{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } }
{ $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ;
HELP: com-wrapper
{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link <com-wrapper> } " constructor and applied to a Factor object using " { $link com-wrap } "." } ;

View File

@ -0,0 +1,111 @@
USING: alien alien.c-types windows.com.syntax
windows.com.syntax.private windows.com continuations kernel
sequences.lib namespaces windows.ole32 libc
assocs accessors arrays sequences quotations combinators
math combinators.cleave combinators.lib words compiler.units ;
IN: windows.com.wrapper
TUPLE: com-wrapper vtbls freed? ;
<PRIVATE
SYMBOL: +wrapped-objects+
+wrapped-objects+ get-global
[ H{ } +wrapped-objects+ set-global ]
unless
: com-unwrap ( wrapped -- object )
+wrapped-objects+ get-global at*
[ "invalid COM wrapping pointer" throw ] unless ;
: (free-wrapped-object) ( wrapped -- )
[ +wrapped-objects+ get-global delete-at ] keep
free ;
: (make-query-interface) ( interfaces -- quot )
[
[ swap 16 memory>byte-array ] %
[
>r find-com-interface-definition family-tree
r> 1quotation [ >r iid>> r> 2array ] curry map
] map-index concat
[ f ] add ,
\ case ,
"void*" heap-size
[ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
curry ,
[ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
\ if* ,
] [ ] make ;
: (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * [ swap <displaced-alien>
0 over ulong-nth
1+ [ 0 rot set-ulong-nth ] keep
] curry ;
: (make-release) ( interfaces -- quot )
length "void*" heap-size * [ over <displaced-alien>
0 over ulong-nth
1- [ 0 rot set-ulong-nth ] keep
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
] curry ;
: (make-iunknown-methods) ( interfaces -- quots )
[ (make-query-interface) ]
[ (make-add-ref) ]
[ (make-release) ] tri
3array ;
: (thunk) ( n -- quot )
dup 0 =
[ drop [ ] ]
[ "void*" heap-size neg * [ swap <displaced-alien> ] curry ]
if ;
: (thunked-quots) ( quots iunknown-methods thunk -- quots' )
[ [ swap 2array ] curry map swap ] keep
[ com-unwrap ] compose [ swap 2array ] curry map append ;
: compile-alien-callback ( return parameters abi quot -- alien )
[ alien-callback ] 4 ncurry
[ gensym [ swap define ] keep ] with-compilation-unit
execute ;
: (make-vtbl) ( interface-name quots iunknown-methods n -- )
(thunk) (thunked-quots)
swap find-com-interface-definition family-tree-functions [
{ return>> parameters>> } get-slots
dup length 1- roll [
first dup empty?
[ 2drop [ ] ]
[ swap [ ndip ] 2curry ]
if
] [ second ] bi compose
"stdcall" swap compile-alien-callback
] 2map >c-void*-array [ byte-length malloc ] keep
over byte-array>memory ;
: (make-vtbls) ( implementations -- vtbls )
dup [ first ] map (make-iunknown-methods)
[ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ;
: (malloc-wrapped-object) ( wrapper -- wrapped-object )
vtbls>> length "void*" heap-size *
[ "ulong" heap-size + malloc ] keep
over <displaced-alien>
1 0 rot set-ulong-nth ;
PRIVATE>
: <com-wrapper> ( implementations -- wrapper )
(make-vtbls) f com-wrapper construct-boa ;
M: com-wrapper dispose
t >>freed?
vtbls>> [ free ] each ;
: com-wrap ( object wrapper -- wrapped-object )
dup (malloc-wrapped-object) >r vtbls>> r>
[ [ set-void*-nth ] curry each-index ] keep
[ +wrapped-objects+ get-global set-at ] keep ;

View File

@ -0,0 +1,70 @@
USING: windows.com windows.com.wrapper combinators.cleave
windows.kernel32 windows.ole32 windows.shell32 kernel accessors
prettyprint namespaces ui.tools.listener ui.tools.workspace
alien.c-types alien sequences math ;
IN: windows.dragdrop
: filenames-from-hdrop ( hdrop -- filenames )
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files
[
2dup f 0 DragQueryFile 1+ ! get size of filename buffer
dup "WCHAR" <c-array>
[ swap DragQueryFile drop ] keep
alien>u16-string
] with map ;
: filenames-from-data-object ( data-object -- filenames )
"FORMATETC" <c-object>
CF_HDROP over set-FORMATETC-cfFormat
f over set-FORMATETC-ptd
DVASPECT_CONTENT over set-FORMATETC-dwAspect
-1 over set-FORMATETC-lindex
TYMED_HGLOBAL over set-FORMATETC-tymed
"STGMEDIUM" <c-object>
[ IDataObject::GetData ] keep swap succeeded? [
dup STGMEDIUM-data
[ filenames-from-hdrop ] with-global-lock
swap ReleaseStgMedium
] [ drop f ] if ;
TUPLE: listener-dragdrop hWnd last-drop-effect ;
: <listener-dragdrop> ( hWnd -- object )
DROPEFFECT_NONE listener-dragdrop construct-boa ;
SYMBOL: +listener-dragdrop-wrapper+
{
{ "IDropTarget" {
[ ! DragEnter
>r 2drop
filenames-from-data-object
length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if
dup 0 r> set-ulong-nth
>>last-drop-effect drop
S_OK
] [ ! DragOver
>r 2drop last-drop-effect>> 0 r> set-ulong-nth
S_OK
] [ ! DragLeave
drop S_OK
] [ ! Drop
>r 2drop nip
filenames-from-data-object
dup length 1 = [
first unparse [ "USE: parser " % % " run-file" % ] "" make
eval-listener
DROPEFFECT_COPY
] [
2drop DROPEFFECT_NONE
] if
0 r> set-ulong-nth
S_OK
]
} }
} <com-wrapper> +listener-dragdrop-wrapper+ set-global
: dragdrop-listener-window ( -- )
get-workspace parent>> handle>> hWnd>>
dup <listener-dragdrop>
+listener-dragdrop-wrapper+ get-global com-wrap
[ RegisterDragDrop ole32-error ] with-com-interface ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax windows.types ;
USING: alien alien.syntax kernel windows.types ;
IN: windows.kernel32
: MAX_PATH 260 ; inline
@ -1564,3 +1564,6 @@ FUNCTION: BOOL WriteProcessMemory ( HANDLE hProcess, void* lpBaseAddress, void*
! FUNCTION: WriteTapemark
! FUNCTION: WTSGetActiveConsoleSessionId
! FUNCTION: ZombifyActCtx
: with-global-lock ( HGLOBAL quot -- )
swap [ GlobalLock swap call ] keep GlobalUnlock drop ; inline

View File

@ -1,16 +1,10 @@
USING: alien alien.syntax alien.c-types math kernel sequences
windows windows.types combinators.lib ;
windows windows.kernel32 windows.types combinators.lib ;
IN: windows.ole32
LIBRARY: ole32
C-STRUCT: GUID
{ "DWORD" "part1" }
{ "DWORD" "part2" }
{ "DWORD" "part3" }
{ "DWORD" "part4" } ;
TYPEDEF: void* REFGUID
TYPEDEF: GUID* REFGUID
TYPEDEF: void* LPUNKNOWN
TYPEDEF: ushort* LPOLESTR
TYPEDEF: ushort* LPCOLESTR
@ -25,6 +19,7 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
: S_OK 0 ; inline
: S_FALSE 1 ; inline
: E_NOINTERFACE HEX: 80004002 ; inline
: E_FAIL HEX: 80004005 ; inline
: E_INVALIDARG HEX: 80070057 ; inline
@ -40,11 +35,92 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
: DD_DEFDRAGDELAY 200 ; inline
: DD_DEFDRAGMINDIST 2 ; inline
: ole32-error ( n -- )
dup S_OK = [
: CF_TEXT 1 ; inline
: CF_BITMAP 2 ; inline
: CF_METAFILEPICT 3 ; inline
: CF_SYLK 4 ; inline
: CF_DIF 5 ; inline
: CF_TIFF 6 ; inline
: CF_OEMTEXT 7 ; inline
: CF_DIB 8 ; inline
: CF_PALETTE 9 ; inline
: CF_PENDATA 10 ; inline
: CF_RIFF 11 ; inline
: CF_WAVE 12 ; inline
: CF_UNICODETEXT 13 ; inline
: CF_ENHMETAFILE 14 ; inline
: CF_HDROP 15 ; inline
: CF_LOCALE 16 ; inline
: CF_MAX 17 ; inline
: CF_OWNERDISPLAY HEX: 0080 ; inline
: CF_DSPTEXT HEX: 0081 ; inline
: CF_DSPBITMAP HEX: 0082 ; inline
: CF_DSPMETAFILEPICT HEX: 0083 ; inline
: CF_DSPENHMETAFILE HEX: 008E ; inline
: DVASPECT_CONTENT 1 ; inline
: DVASPECT_THUMBNAIL 2 ; inline
: DVASPECT_ICON 4 ; inline
: DVASPECT_DOCPRINT 8 ; inline
: TYMED_HGLOBAL 1 ; inline
: TYMED_FILE 2 ; inline
: TYMED_ISTREAM 4 ; inline
: TYMED_ISTORAGE 8 ; inline
: TYMED_GDI 16 ; inline
: TYMED_MFPICT 32 ; inline
: TYMED_ENHMF 64 ; inline
: TYMED_NULL 0 ; inline
C-STRUCT: DVTARGETDEVICE
{ "DWORD" "tdSize" }
{ "WORD" "tdDriverNameOffset" }
{ "WORD" "tdDeviceNameOffset" }
{ "WORD" "tdPortNameOffset" }
{ "WORD" "tdExtDevmodeOffset" }
{ "BYTE[1]" "tdData" } ;
TYPEDEF: WORD CLIPFORMAT
TYPEDEF: POINT POINTL
C-STRUCT: FORMATETC
{ "CLIPFORMAT" "cfFormat" }
{ "DVTARGETDEVICE*" "ptd" }
{ "DWORD" "dwAspect" }
{ "LONG" "lindex" }
{ "DWORD" "tymed" } ;
TYPEDEF: FORMATETC* LPFORMATETC
C-STRUCT: STGMEDIUM
{ "DWORD" "tymed" }
{ "void*" "data" }
{ "LPUNKNOWN" "punkForRelease" } ;
TYPEDEF: STGMEDIUM* LPSTGMEDIUM
: COINIT_MULTITHREADED 0 ; inline
: COINIT_APARTMENTTHREADED 2 ; inline
: COINIT_DISABLE_OLE1DDE 4 ; inline
: COINIT_SPEED_OVER_MEMORY 8 ; inline
FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ;
: ole32-error ( hresult -- )
dup succeeded? [
drop
] [ (win32-error-string) throw ] if ;
: ole-initialize ( -- )
f OleInitialize ole32-error ;
: guid= ( a b -- ? )
IsEqualGUID c-bool> ;

View File

@ -167,6 +167,15 @@ TYPEDEF: DWORD SHGDNF
TYPEDEF: ULONG SFGAOF
C-STRUCT: DROPFILES
{ "DWORD" "pFiles" }
{ "POINT" "pt" }
{ "BOOL" "fNC" }
{ "BOOL" "fWide" } ;
TYPEDEF: DROPFILES* LPDROPFILES
TYPEDEF: DROPFILES* LPCDROPFILES
TYPEDEF: HANDLE HDROP
C-STRUCT: SHITEMID
{ "USHORT" "cb" }
{ "BYTE[1]" "abID" } ;
@ -210,5 +219,6 @@ COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046}
FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ;
FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ;
: StrRetToBuf StrRetToBufW ; inline
FUNCTION: UINT DragQueryFileW ( HDROP hDrop, UINT iFile, LPWSTR lpszFile, UINT cch ) ;
: DragQueryFile DragQueryFileW ; inline

0
extra/windows/time/time.factor Executable file → Normal file
View File