From f2718f3a71fdb89d49e7a6aa46041ddecc5ff3d7 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 31 Mar 2008 12:31:46 -0700
Subject: [PATCH] Get COM wrappers working. dragdrop-listener example vocab to
enable drag-and-drop on listener windows
---
core/slots/slots-docs.factor | 2 +-
extra/windows/com/com-docs.factor | 2 +-
extra/windows/com/com-tests.factor | 44 +++++--
extra/windows/com/com.factor | 23 +++-
extra/windows/com/syntax/syntax.factor | 10 +-
extra/windows/com/wrapper/wrapper-docs.factor | 40 +++++++
extra/windows/com/wrapper/wrapper.factor | 111 ++++++++++++++++++
.../dragdrop-listener.factor | 70 +++++++++++
extra/windows/kernel32/kernel32.factor | 5 +-
extra/windows/ole32/ole32.factor | 96 +++++++++++++--
extra/windows/shell32/shell32.factor | 14 ++-
extra/windows/time/time.factor | 0
12 files changed, 386 insertions(+), 31 deletions(-)
create mode 100755 extra/windows/com/wrapper/wrapper-docs.factor
create mode 100755 extra/windows/com/wrapper/wrapper.factor
create mode 100644 extra/windows/dragdrop-listener/dragdrop-listener.factor
mode change 100755 => 100644 extra/windows/time/time.factor
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index e4bb307829..5de765313b 100755
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -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."
diff --git a/extra/windows/com/com-docs.factor b/extra/windows/com/com-docs.factor
index 901a88675f..68663b4cdb 100644
--- a/extra/windows/com/com-docs.factor
+++ b/extra/windows/com/com-docs.factor
@@ -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" } } }
diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor
index 4c62e7adfd..e2685db1d0 100644
--- a/extra/windows/com/com-tests.factor
+++ b/extra/windows/com/com-tests.factor
@@ -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
diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor
index b78d9b5b91..4833a7412a 100644
--- a/extra/windows/com/com.factor
+++ b/extra/windows/com/com.factor
@@ -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
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
index 5884c18aee..216ca8707d 100755
--- a/extra/windows/com/syntax/syntax.factor
+++ b/extra/windows/com/syntax/syntax.factor
@@ -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 ;
diff --git a/extra/windows/com/wrapper/wrapper-docs.factor b/extra/windows/com/wrapper/wrapper-docs.factor
new file mode 100755
index 0000000000..51a3549047
--- /dev/null
+++ b/extra/windows/com/wrapper/wrapper-docs.factor
@@ -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 } "." } ;
diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor
new file mode 100755
index 0000000000..890674ed6d
--- /dev/null
+++ b/extra/windows/com/wrapper/wrapper.factor
@@ -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 ;
diff --git a/extra/windows/dragdrop-listener/dragdrop-listener.factor b/extra/windows/dragdrop-listener/dragdrop-listener.factor
new file mode 100644
index 0000000000..a7851621ff
--- /dev/null
+++ b/extra/windows/dragdrop-listener/dragdrop-listener.factor
@@ -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 ;
diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor
index 37b833cae1..5530c0871f 100644
--- a/extra/windows/kernel32/kernel32.factor
+++ b/extra/windows/kernel32/kernel32.factor
@@ -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
diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor
index 44ea853af0..3be442514c 100644
--- a/extra/windows/ole32/ole32.factor
+++ b/extra/windows/ole32/ole32.factor
@@ -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> ;
diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor
index d64fb68cb3..a5bed9daed 100644
--- a/extra/windows/shell32/shell32.factor
+++ b/extra/windows/shell32/shell32.factor
@@ -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
+
diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor
old mode 100755
new mode 100644