204 lines
8.1 KiB
ObjectPascal
204 lines
8.1 KiB
ObjectPascal
unit TB2OleMarshal;
|
|
|
|
{
|
|
Toolbar2000
|
|
Copyright (C) 1998-2008 by Jordan Russell
|
|
All rights reserved.
|
|
|
|
The contents of this file are subject to the "Toolbar2000 License"; you may
|
|
not use or distribute this file except in compliance with the
|
|
"Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in
|
|
TB2k-LICENSE.txt or at:
|
|
http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt
|
|
|
|
Alternatively, the contents of this file may be used under the terms of the
|
|
GNU General Public License (the "GPL"), in which case the provisions of the
|
|
GPL are applicable instead of those in the "Toolbar2000 License". A copy of
|
|
the GPL may be found in GPL-LICENSE.txt or at:
|
|
http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt
|
|
If you wish to allow use of your version of this file only under the terms of
|
|
the GPL and not to allow others to use your version of this file under the
|
|
"Toolbar2000 License", indicate your decision by deleting the provisions
|
|
above and replace them with the notice and other provisions required by the
|
|
GPL. If you do not delete the provisions above, a recipient may use your
|
|
version of this file under either the "Toolbar2000 License" or the GPL.
|
|
|
|
$jrsoftware: tb2k/Source/TB2OleMarshal.pas,v 1.4 2008/09/17 18:04:09 jr Exp $
|
|
|
|
This unit implements the TTBStandardOleMarshalObject class, an exact clone of
|
|
.NET Framework 2.0's StandardOleMarshalObject class, which isn't available
|
|
on the .NET Framework 1.1-based Delphi 2006.
|
|
On Delphi 2007, I had planned to switch to StandardOleMarshalObject, but it
|
|
turns out there's a bug that causes it raise AV's on x64 & IA-64 (seen as
|
|
E_POINTER on the client side). Coincidentally, TTBStandardOleMarshalObject
|
|
does not suffer from this bug (even though it was intended to be an exact
|
|
clone!).
|
|
|
|
The class "replaces the standard common language runtime (CLR) free-threaded
|
|
marshaler with the standard OLE STA marshaler." It "prevents calls made into
|
|
a hosting object by OLE from entering threads other than the UI thread."
|
|
For more information, see:
|
|
http://msdn2.microsoft.com/system.runtime.interopservices.standardolemarshalobject.aspx
|
|
}
|
|
|
|
interface
|
|
|
|
{$I TB2Ver.inc}
|
|
|
|
uses
|
|
System.Runtime.InteropServices, Windows;
|
|
|
|
type
|
|
{ Our declaration for IMarshal }
|
|
[ComImport,
|
|
GuidAttribute('00000003-0000-0000-C000-000000000046'),
|
|
InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown)]
|
|
ITBMarshal = interface
|
|
[PreserveSig]
|
|
function GetUnmarshalClass([MarshalAs(UnmanagedType.LPStruct)] riid: Guid;
|
|
pv: IntPtr; dwDestContext: Longint; pvDestContext: IntPtr;
|
|
mshlflags: Longint; out pCid: Guid): HRESULT;
|
|
[PreserveSig]
|
|
function GetMarshalSizeMax([MarshalAs(UnmanagedType.LPStruct)] riid: Guid;
|
|
pv: IntPtr; dwDestContext: Longint; pvDestContext: IntPtr;
|
|
mshlflags: Longint; out pSize: Longint): HRESULT;
|
|
[PreserveSig]
|
|
function MarshalInterface([in, MarshalAs(UnmanagedType.Interface)] pStm: TObject;
|
|
[MarshalAs(UnmanagedType.LPStruct)] riid: Guid; pv: IntPtr;
|
|
dwDestContext: Longint; pvDestContext: IntPtr; mshlflags: Longint): HRESULT;
|
|
[PreserveSig]
|
|
function UnmarshalInterface([in, MarshalAs(UnmanagedType.Interface)] pStm: TObject;
|
|
[MarshalAs(UnmanagedType.LPStruct)] riid: Guid; out ppv: IntPtr): HRESULT;
|
|
[PreserveSig]
|
|
function ReleaseMarshalData([in, MarshalAs(UnmanagedType.Interface)] pStm: TObject): HRESULT;
|
|
[PreserveSig]
|
|
function DisconnectObject(dwReserved: Longint): HRESULT;
|
|
end;
|
|
|
|
TTBStandardOleMarshalObject = class(System.MarshalByRefObject, ITBMarshal)
|
|
private
|
|
function GetStdMarshaller(const riid: Guid; const dwDestContext: Longint;
|
|
const mshlflags: Longint): IntPtr;
|
|
{ IMarshal }
|
|
function GetUnmarshalClass(riid: Guid; pv: IntPtr; dwDestContext: Longint;
|
|
pvDestContext: IntPtr; mshlflags: Longint; out pCid: Guid): HRESULT;
|
|
function GetMarshalSizeMax(riid: Guid; pv: IntPtr; dwDestContext: Longint;
|
|
pvDestContext: IntPtr; mshlflags: Longint; out pSize: Longint): HRESULT;
|
|
function MarshalInterface(pStm: TObject; riid: Guid; pv: IntPtr;
|
|
dwDestContext: Longint; pvDestContext: IntPtr; mshlflags: Longint): HRESULT;
|
|
function UnmarshalInterface(pStm: TObject; riid: Guid; out ppv: IntPtr): HRESULT;
|
|
function ReleaseMarshalData(pStm: TObject): HRESULT;
|
|
function DisconnectObject(dwReserved: Longint): HRESULT;
|
|
end;
|
|
|
|
implementation
|
|
|
|
{ Note: According to http://blogs.msdn.com/cbrumme/archive/2003/04/15/51335.aspx
|
|
the Marshal.ReleaseComObject(pStm) calls are needed to work around a "quirk
|
|
of OLE32 on some versions of the operating system". }
|
|
|
|
uses
|
|
System.Security;
|
|
|
|
const
|
|
ole32 = 'ole32.dll';
|
|
|
|
[SuppressUnmanagedCodeSecurity, DllImport(ole32, CharSet = CharSet.Unicode, EntryPoint = 'CoGetMarshalSizeMax')]
|
|
function _CoGetMarshalSizeMax(out pulSize: Longint;
|
|
[in, MarshalAs(UnmanagedType.LPStruct)] riid: Guid; pUnk: IntPtr;
|
|
dwDestContext: Longint; pvDestContext: IntPtr;
|
|
mshlflags: Longint): HRESULT; external;
|
|
[SuppressUnmanagedCodeSecurity, DllImport(ole32, CharSet = CharSet.Unicode, EntryPoint = 'CoGetStandardMarshal')]
|
|
function _CoGetStandardMarshal([in, MarshalAs(UnmanagedType.LPStruct)] iid: Guid;
|
|
pUnk: IntPtr; dwDestContext: Longint; pvDestContext: IntPtr;
|
|
mshlflags: Longint; out ppMarshal: IntPtr): HRESULT; external;
|
|
[SuppressUnmanagedCodeSecurity, DllImport(ole32, CharSet = CharSet.Unicode, EntryPoint = 'CoMarshalInterface')]
|
|
function _CoMarshalInterface([in, MarshalAs(UnmanagedType.Interface)] pStm: TObject;
|
|
[in, MarshalAs(UnmanagedType.LPStruct)] riid: Guid; pUnk: IntPtr;
|
|
dwDestContext: Longint; pvDestContext: IntPtr;
|
|
mshlflags: Longint): HRESULT; external;
|
|
|
|
function TTBStandardOleMarshalObject.GetStdMarshaller(const riid: Guid;
|
|
const dwDestContext: Longint; const mshlflags: Longint): IntPtr;
|
|
var
|
|
V_1: IntPtr;
|
|
begin
|
|
Result := nil;
|
|
V_1 := Marshal.GetIUnknownForObject(Self);
|
|
if V_1 <> nil then begin
|
|
try
|
|
if _CoGetStandardMarshal(riid, V_1, dwDestContext, nil, mshlflags, Result) = S_OK then
|
|
Exit;
|
|
finally
|
|
Marshal.Release(V_1);
|
|
end;
|
|
end;
|
|
{ Note: Localizing this message isn't necessary because a user will never
|
|
see it; the .NET runtime will catch it and translate it into a
|
|
COR_E_EXCEPTION HRESULT. }
|
|
raise InvalidOperationException.Create('TTBStandardOleMarshalObject.GetStdMarshaller failed');
|
|
end;
|
|
|
|
function TTBStandardOleMarshalObject.GetUnmarshalClass(riid: Guid; pv: IntPtr;
|
|
dwDestContext: Longint; pvDestContext: IntPtr; mshlflags: Longint;
|
|
out pCid: Guid): HRESULT;
|
|
begin
|
|
{ StandardOleMarshalObject does "pCid := TypeOf(IStdMarshal).GUID" here, but
|
|
we haven't declared IStdMarshal anywhere, so create a fresh Guid }
|
|
pCid := Guid.Create('00000017-0000-0000-C000-000000000046'); { CLSID_StdMarshal }
|
|
Result := S_OK;
|
|
end;
|
|
|
|
function TTBStandardOleMarshalObject.GetMarshalSizeMax(riid: Guid; pv: IntPtr;
|
|
dwDestContext: Longint; pvDestContext: IntPtr; mshlflags: Longint;
|
|
out pSize: Longint): HRESULT;
|
|
var
|
|
V_0: IntPtr;
|
|
begin
|
|
V_0 := GetStdMarshaller(riid, dwDestContext, mshlflags);
|
|
try
|
|
Result := _CoGetMarshalSizeMax(pSize, riid, V_0, dwDestContext, pvDestContext, mshlflags);
|
|
finally
|
|
Marshal.Release(V_0);
|
|
end;
|
|
end;
|
|
|
|
function TTBStandardOleMarshalObject.MarshalInterface(pStm: TObject; riid: Guid;
|
|
pv: IntPtr; dwDestContext: Longint; pvDestContext: IntPtr;
|
|
mshlflags: Longint): HRESULT;
|
|
var
|
|
V_0: IntPtr;
|
|
begin
|
|
V_0 := GetStdMarshaller(riid, dwDestContext, mshlflags);
|
|
try
|
|
Result := _CoMarshalInterface(pStm, riid, V_0, dwDestContext, pvDestContext, mshlflags);
|
|
finally
|
|
Marshal.Release(V_0);
|
|
if pStm <> nil then
|
|
Marshal.ReleaseComObject(pStm);
|
|
end;
|
|
end;
|
|
|
|
function TTBStandardOleMarshalObject.UnmarshalInterface(pStm: TObject;
|
|
riid: Guid; out ppv: IntPtr): HRESULT;
|
|
begin
|
|
ppv := nil;
|
|
if pStm <> nil then
|
|
Marshal.ReleaseComObject(pStm);
|
|
Result := E_NOTIMPL;
|
|
end;
|
|
|
|
function TTBStandardOleMarshalObject.ReleaseMarshalData(pStm: TObject): HRESULT;
|
|
begin
|
|
if pStm <> nil then
|
|
Marshal.ReleaseComObject(pStm);
|
|
Result := E_NOTIMPL;
|
|
end;
|
|
|
|
function TTBStandardOleMarshalObject.DisconnectObject(dwReserved: Longint): HRESULT;
|
|
begin
|
|
Result := E_NOTIMPL;
|
|
end;
|
|
|
|
end.
|