1261 lines
41 KiB
ObjectPascal
1261 lines
41 KiB
ObjectPascal
{**************************************************************************************************}
|
|
{ }
|
|
{ Project JEDI Code Library (JCL) }
|
|
{ }
|
|
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
|
|
{ you may not use this file except in compliance with the License. You may obtain a copy of the }
|
|
{ License at http://www.mozilla.org/MPL/ }
|
|
{ }
|
|
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
|
|
{ ANY KIND, either express or implied. See the License for the specific language governing rights }
|
|
{ and limitations under the License. }
|
|
{ }
|
|
{ The Original Code is JclDotNet.pas. }
|
|
{ }
|
|
{ The Initial Developer of the Original Code is Flier Lu (<flier_lu att yahoo dott com dott cn>). }
|
|
{ Portions created by Flier Lu are Copyright (C) Flier Lu. All Rights Reserved. }
|
|
{ }
|
|
{ Contributors: }
|
|
{ Flier Lu (flier) }
|
|
{ Robert Marquardt (marquardt) }
|
|
{ Olivier Sannier (obones) }
|
|
{ Florent Ouchet (outchy) }
|
|
{ }
|
|
{**************************************************************************************************}
|
|
{ }
|
|
{ Microsoft .Net framework support routines and classes. }
|
|
{ }
|
|
{ Unit owner: Flier Lu }
|
|
{ }
|
|
{**************************************************************************************************}
|
|
|
|
// Last modified: $Date: 2006-09-03 16:30:32 +0200 (dim., 03 sept. 2006) $
|
|
|
|
unit JclDotNet;
|
|
|
|
{**************************************************************************************************}
|
|
{ Read this before compile! }
|
|
{**************************************************************************************************}
|
|
{ 1. This unit is developed in Delphi6 with MS.Net v1.0.3705, }
|
|
{ you maybe need to modify it for your environment. }
|
|
{ 2. Delphi's TLibImp.exe would generate error *_TLB.pas files }
|
|
{ when you import mscorlib.tlb, you should modify it by hand }
|
|
{ for example, change Pointer to _Pointer... }
|
|
{ or use my modified edition of mscorlib_TLB.pas (mscor.zip) }
|
|
{**************************************************************************************************}
|
|
|
|
interface
|
|
|
|
{$I jcl.inc}
|
|
|
|
uses
|
|
{$IFDEF UNITVERSIONING}
|
|
JclUnitVersioning,
|
|
{$ENDIF UNITVERSIONING}
|
|
{$IFDEF MSWINDOWS}
|
|
Windows, ActiveX,
|
|
{$ENDIF MSWINDOWS}
|
|
Classes, SysUtils,
|
|
{$IFDEF RTL130_UP}
|
|
Contnrs,
|
|
{$ENDIF RTL130_UP}
|
|
JclBase, JclWideStrings,
|
|
mscoree_TLB, mscorlib_TLB;
|
|
|
|
//{$HPPEMIT '#include<Mscoree.h>'}
|
|
|
|
{ TODO -cDOC : Original code: "Flier Lu" <flier_lu att yahoo dott com dott cn> }
|
|
|
|
type
|
|
TJclClrBase = TInterfacedObject;
|
|
|
|
type
|
|
IJclClrAppDomain = mscorlib_TLB._AppDomain;
|
|
IJclClrEvidence = mscorlib_TLB._Evidence;
|
|
IJclClrAssembly = mscorlib_TLB._Assembly;
|
|
IJclClrMethod = mscorlib_TLB._MethodInfo;
|
|
|
|
type
|
|
TJclClrHostFlavor = (hfServer, hfWorkStation);
|
|
|
|
TJclClrHostLoaderFlag =
|
|
(hlOptSingleDomain,
|
|
hlOptMultiDomain,
|
|
hlOptMultiDomainHost,
|
|
hlSafeMode,
|
|
hlSetPreference);
|
|
TJclClrHostLoaderFlags = set of TJclClrHostLoaderFlag;
|
|
|
|
type
|
|
EJclClrException = class(SysUtils.Exception);
|
|
|
|
TJclClrAppDomain = class;
|
|
TJclClrAppDomainSetup = class;
|
|
TJclClrAssembly = class;
|
|
|
|
TJclClrHost = class(TJclClrBase, ICorRuntimeHost)
|
|
private
|
|
FDefaultInterface: ICorRuntimeHost;
|
|
FAppDomains: TObjectList;
|
|
procedure EnumAppDomains;
|
|
function GetAppDomain(const Idx: Integer): TJclClrAppDomain;
|
|
function GetAppDomainCount: Integer;
|
|
function GetDefaultAppDomain: IJclClrAppDomain;
|
|
function GetCurrentAppDomain: IJclClrAppDomain;
|
|
protected
|
|
function AddAppDomain(const AppDomain: TJclClrAppDomain): Integer;
|
|
function RemoveAppDomain(const AppDomain: TJclClrAppDomain): Integer;
|
|
public
|
|
constructor Create(const ClrVer: WideString = '';
|
|
const Flavor: TJclClrHostFlavor = hfWorkStation;
|
|
const ConcurrentGC: Boolean = True;
|
|
const LoaderFlags: TJclClrHostLoaderFlags = [hlOptSingleDomain]);
|
|
destructor Destroy; override;
|
|
procedure Start;
|
|
procedure Stop;
|
|
procedure Refresh;
|
|
function CreateDomainSetup: TJclClrAppDomainSetup;
|
|
function CreateAppDomain(const Name: WideString;
|
|
const Setup: TJclClrAppDomainSetup = nil;
|
|
const Evidence: IJclClrEvidence = nil): TJclClrAppDomain;
|
|
function FindAppDomain(const Intf: IJclClrAppDomain; var Ret: TJclClrAppDomain): Boolean; overload;
|
|
function FindAppDomain(const Name: WideString; var Ret: TJclClrAppDomain): Boolean; overload;
|
|
class function CorSystemDirectory: WideString;
|
|
class function CorVersion: WideString;
|
|
class function CorRequiredVersion: WideString;
|
|
class procedure GetClrVersions(VersionNames: TWideStrings); overload;
|
|
class procedure GetClrVersions(VersionNames: TStrings); overload;
|
|
property DefaultInterface: ICorRuntimeHost read FDefaultInterface implements ICorRuntimeHost;
|
|
property AppDomains[const Idx: Integer]: TJclClrAppDomain read GetAppDomain; default;
|
|
property AppDomainCount: Integer read GetAppDomainCount;
|
|
property DefaultAppDomain: IJclClrAppDomain read GetDefaultAppDomain;
|
|
property CurrentAppDomain: IJclClrAppDomain read GetCurrentAppDomain;
|
|
end;
|
|
|
|
TJclClrAssemblyArguments = array of WideString;
|
|
|
|
TJclClrAppDomain = class(TJclClrBase, IJclClrAppDomain)
|
|
private
|
|
FHost: TJclClrHost;
|
|
FDefaultInterface: IJclClrAppDomain;
|
|
protected
|
|
constructor Create(const AHost: TJclClrHost; const AAppDomain: IJclClrAppDomain);
|
|
public
|
|
function Load(const AssemblyString: WideString;
|
|
const AssemblySecurity: IJclClrEvidence = nil): TJclClrAssembly; overload;
|
|
function Load(const RawAssemblyStream: TStream;
|
|
const RawSymbolStoreStream: TStream = nil;
|
|
const AssemblySecurity: IJclClrEvidence = nil): TJclClrAssembly; overload;
|
|
function Execute(const AssemblyFile: TFileName;
|
|
const AssemblySecurity: IJclClrEvidence = nil): Integer; overload;
|
|
function Execute(const AssemblyFile: TFileName;
|
|
const Arguments: TJclClrAssemblyArguments;
|
|
const AssemblySecurity: IJclClrEvidence = nil): Integer; overload;
|
|
function Execute(const AssemblyFile: TFileName;
|
|
const Arguments: TStrings;
|
|
const AssemblySecurity: IJclClrEvidence = nil): Integer; overload;
|
|
procedure Unload;
|
|
property Host: TJclClrHost read FHost;
|
|
property DefaultInterface: IJclClrAppDomain read FDefaultInterface implements IJclClrAppDomain;
|
|
end;
|
|
|
|
TJclClrAppDomainSetup = class(TJclClrBase, IAppDomainSetup)
|
|
private
|
|
FDefaultInterface: IAppDomainSetup;
|
|
function GetApplicationBase: WideString;
|
|
function GetApplicationName: WideString;
|
|
function GetCachePath: WideString;
|
|
function GetConfigurationFile: WideString;
|
|
function GetDynamicBase: WideString;
|
|
function GetLicenseFile: WideString;
|
|
function GetPrivateBinPath: WideString;
|
|
function GetPrivateBinPathProbe: WideString;
|
|
function GetShadowCopyDirectories: WideString;
|
|
function GetShadowCopyFiles: WideString;
|
|
procedure SetApplicationBase(const Value: WideString);
|
|
procedure SetApplicationName(const Value: WideString);
|
|
procedure SetCachePath(const Value: WideString);
|
|
procedure SetConfigurationFile(const Value: WideString);
|
|
procedure SetDynamicBase(const Value: WideString);
|
|
procedure SetLicenseFile(const Value: WideString);
|
|
procedure SetPrivateBinPath(const Value: WideString);
|
|
procedure SetPrivateBinPathProbe(const Value: WideString);
|
|
procedure SetShadowCopyDirectories(const Value: WideString);
|
|
procedure SetShadowCopyFiles(const Value: WideString);
|
|
protected
|
|
constructor Create(Intf: IAppDomainSetup);
|
|
public
|
|
property DefaultInterface: IAppDomainSetup read FDefaultInterface implements IAppDomainSetup;
|
|
property ApplicationBase: WideString read GetApplicationBase write SetApplicationBase;
|
|
property ApplicationName: WideString read GetApplicationName write SetApplicationName;
|
|
property CachePath: WideString read GetCachePath write SetCachePath;
|
|
property ConfigurationFile: WideString read GetConfigurationFile write SetConfigurationFile;
|
|
property DynamicBase: WideString read GetDynamicBase write SetDynamicBase;
|
|
property LicenseFile: WideString read GetLicenseFile write SetLicenseFile;
|
|
property PrivateBinPath: WideString read GetPrivateBinPath write SetPrivateBinPath;
|
|
property PrivateBinPathProbe: WideString read GetPrivateBinPathProbe write SetPrivateBinPathProbe;
|
|
property ShadowCopyDirectories: WideString read GetShadowCopyDirectories write SetShadowCopyDirectories;
|
|
property ShadowCopyFiles: WideString read GetShadowCopyFiles write SetShadowCopyFiles;
|
|
end;
|
|
|
|
TJclClrAssembly = class(TJclClrBase, IJclClrAssembly)
|
|
private
|
|
FDefaultInterface: IJclClrAssembly;
|
|
protected
|
|
constructor Create(Intf: IJclClrAssembly);
|
|
public
|
|
property DefaultInterface: IJclClrAssembly read FDefaultInterface implements IJclClrAssembly;
|
|
end;
|
|
|
|
type
|
|
TJclClrField = class(TObject)
|
|
end;
|
|
|
|
TJclClrProperty = class(TObject)
|
|
end;
|
|
|
|
TJclClrMethod = class(TJclClrBase, IJclClrMethod)
|
|
private
|
|
FDefaultInterface: IJclClrMethod;
|
|
public
|
|
property DefaultInterface: IJclClrMethod read FDefaultInterface implements IJclClrMethod;
|
|
end;
|
|
|
|
TJclClrObject = class(TObject)
|
|
private
|
|
function GetMethod(const Name: WideString): TJclClrMethod;
|
|
function GetField(const Name: WideString): TJclClrField;
|
|
function GetProperty(const Name: WideString): TJclClrProperty;
|
|
protected
|
|
constructor Create(const AssemblyName, NamespaceName, ClassName: WideString;
|
|
const Parameters: array of const); overload;
|
|
constructor Create(const AssemblyName, NamespaceName, ClassName: WideString;
|
|
const NewInstance: Boolean = False); overload;
|
|
public
|
|
property Fields[const Name: WideString]: TJclClrField read GetField;
|
|
property Properties[const Name: WideString]: TJclClrProperty read GetProperty;
|
|
property Methods[const Name: WideString]: TJclClrMethod read GetMethod;
|
|
end;
|
|
|
|
function CompareCLRVersions(const LeftVersion, RightVersion: string): Integer;
|
|
|
|
type
|
|
HDOMAINENUM = Pointer;
|
|
{$EXTERNALSYM HDOMAINENUM}
|
|
|
|
const
|
|
STARTUP_CONCURRENT_GC = $1;
|
|
STARTUP_LOADER_OPTIMIZATION_MASK = $3 shl 1;
|
|
STARTUP_LOADER_OPTIMIZATION_SINGLE_DOMAIN = $1 shl 1;
|
|
STARTUP_LOADER_OPTIMIZATION_MULTI_DOMAIN = $2 shl 1;
|
|
STARTUP_LOADER_OPTIMIZATION_MULTI_DOMAIN_HOST = $3 shl 1;
|
|
STARTUP_LOADER_SAFEMODE = $10;
|
|
STARTUP_LOADER_SETPREFERENCE = $100;
|
|
|
|
RUNTIME_INFO_UPGRADE_VERSION = $01;
|
|
RUNTIME_INFO_REQUEST_IA64 = $02;
|
|
RUNTIME_INFO_REQUEST_AMD64 = $04;
|
|
RUNTIME_INFO_REQUEST_X86 = $08;
|
|
RUNTIME_INFO_DONT_RETURN_DIRECTORY = $10;
|
|
RUNTIME_INFO_DONT_RETURN_VERSION = $20;
|
|
RUNTIME_INFO_DONT_SHOW_ERROR_DIALOG = $40;
|
|
|
|
function GetCORSystemDirectory(pbuffer: PWideChar; const cchBuffer: DWORD;
|
|
var dwLength: DWORD): HRESULT; stdcall;
|
|
{$EXTERNALSYM GetCORSystemDirectory}
|
|
function GetCORVersion(pbuffer: PWideChar; const cchBuffer: DWORD;
|
|
var dwLength: DWORD): HRESULT; stdcall;
|
|
{$EXTERNALSYM GetCORVersion}
|
|
function GetFileVersion(szFileName, szBuffer: PWideChar; const cchBuffer: DWORD;
|
|
var dwLength: DWORD): HRESULT; stdcall;
|
|
{$EXTERNALSYM GetFileVersion}
|
|
function GetCORRequiredVersion(pbuffer: PWideChar; const cchBuffer: DWORD;
|
|
var dwLength: DWORD): HRESULT; stdcall;
|
|
{$EXTERNALSYM GetCORRequiredVersion}
|
|
function GetRequestedRuntimeInfo(pExe, pwszVersion, pConfigurationFile: PWideChar;
|
|
const startupFlags, reserved: DWORD; pDirectory: PWideChar; const dwDirectory: DWORD;
|
|
var dwDirectoryLength: DWORD; pVersion: PWideChar; const cchBuffer: DWORD;
|
|
var dwLength: DWORD): HRESULT; stdcall;
|
|
{$EXTERNALSYM GetRequestedRuntimeInfo}
|
|
function GetRequestedRuntimeVersion(pExe, pVersion: PWideChar;
|
|
const cchBuffer: DWORD; var dwLength: DWORD): HRESULT; stdcall;
|
|
{$EXTERNALSYM GetRequestedRuntimeVersion}
|
|
function CorBindToRuntimeHost(pwszVersion, pwszBuildFlavor,
|
|
pwszHostConfigFile: PWideChar; const pReserved: Pointer;
|
|
const startupFlags: DWORD; const rclsid: TCLSID; const riid: TIID;
|
|
out pv): HRESULT; stdcall;
|
|
{$EXTERNALSYM CorBindToRuntimeHost}
|
|
function CorBindToRuntimeEx(pwszVersion, pwszBuildFlavor: PWideChar;
|
|
startupFlags: DWORD; const rclsid: TCLSID; const riid: TIID;
|
|
out pv): HRESULT; stdcall;
|
|
{$EXTERNALSYM CorBindToRuntimeEx}
|
|
function CorBindToRuntimeByCfg(const pCfgStream: IStream;
|
|
const reserved, startupFlags: DWORD; const rclsid: TCLSID;
|
|
const riid: TIID; out pv): HRESULT; stdcall;
|
|
{$EXTERNALSYM CorBindToRuntimeByCfg}
|
|
function CorBindToRuntime(pwszVersion, pwszBuildFlavor: PWideChar;
|
|
const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;
|
|
{$EXTERNALSYM CorBindToRuntime}
|
|
function CorBindToCurrentRuntime(pwszFileName: PWideChar;
|
|
const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;
|
|
{$EXTERNALSYM CorBindToCurrentRuntime}
|
|
function ClrCreateManagedInstance(pTypeName: PWideChar;
|
|
const riid: TIID; out pv): HRESULT; stdcall;
|
|
{$EXTERNALSYM ClrCreateManagedInstance}
|
|
procedure CorMarkThreadInThreadPool; stdcall;
|
|
{$EXTERNALSYM CorMarkThreadInThreadPool}
|
|
function RunDll32ShimW(const hwnd: THandle; const hinst: HMODULE;
|
|
lpszCmdLine: PWideChar; const nCmdShow: Integer): HRESULT; stdcall;
|
|
{$EXTERNALSYM RunDll32ShimW}
|
|
function LoadLibraryShim(szDllName, szVersion: PWideChar;
|
|
const pvReserved: Pointer; out phModDll: HMODULE): HRESULT; stdcall;
|
|
{$EXTERNALSYM LoadLibraryShim}
|
|
function CallFunctionShim(szDllName: PWideChar; const szFunctionName: PChar;
|
|
const lpvArgument1, lpvArgument2: Pointer; szVersion: PWideChar;
|
|
const pvReserved: Pointer): HRESULT; stdcall;
|
|
{$EXTERNALSYM CallFunctionShim}
|
|
function GetRealProcAddress(const pwszProcName: PChar;
|
|
out ppv: Pointer): HRESULT; stdcall;
|
|
{$EXTERNALSYM GetRealProcAddress}
|
|
procedure CorExitProcess(const exitCode: Integer); stdcall;
|
|
{$EXTERNALSYM CorExitProcess}
|
|
|
|
type
|
|
CLSID_RESOLUTION_FLAGS = type Byte;
|
|
{$EXTERNALSYM CLSID_RESOLUTION_FLAGS}
|
|
|
|
const
|
|
CLSID_RESOLUTION_DEFAULT = $0;
|
|
{$EXTERNALSYM CLSID_RESOLUTION_DEFAULT}
|
|
CLSID_RESOLUTION_REGISTERED = $1;
|
|
{$EXTERNALSYM CLSID_RESOLUTION_REGISTERED}
|
|
|
|
function GetRequestedRuntimeVersionForCLSID(rclsid: TGuid; pVersion: PWideChar;
|
|
const cchBuffer: DWORD; var dwLength: DWORD;
|
|
const dwResolutionFlags: CLSID_RESOLUTION_FLAGS): HRESULT; stdcall;
|
|
{$EXTERNALSYM GetRequestedRuntimeVersionForCLSID}
|
|
|
|
const
|
|
mscoree_dll = 'mscoree.dll';
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
const
|
|
UnitVersioning: TUnitVersionInfo = (
|
|
RCSfile: '$URL: https://jcl.svn.sourceforge.net:443/svnroot/jcl/tags/JCL-1.100-Build2646/jcl/source/windows/JclDotNet.pas $';
|
|
Revision: '$Revision: 1747 $';
|
|
Date: '$Date: 2006-09-03 16:30:32 +0200 (dim., 03 sept. 2006) $';
|
|
LogPath: 'JCL\source\windows'
|
|
);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
implementation
|
|
|
|
uses
|
|
ComObj,
|
|
{$IFDEF HAS_UNIT_VARIANTS}
|
|
Variants,
|
|
{$ENDIF HAS_UNIT_VARIANTS}
|
|
JclSysUtils, JclResources, JclStrings;
|
|
|
|
function CompareCLRVersions(const LeftVersion, RightVersion: string): Integer;
|
|
var
|
|
LeftMajor, RightMajor, LeftMinor, RightMinor, LeftBuild, RightBuild, DotPos: Integer;
|
|
LeftStr, RightStr, LeftNum, RightNum: string;
|
|
begin
|
|
if (Length(LeftVersion) = 0) or (LeftVersion[1] <> 'v') then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);
|
|
|
|
if (Length(RightVersion) = 0) or (RightVersion[1] <> 'v') then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);
|
|
|
|
DotPos := Pos('.', LeftVersion);
|
|
if DotPos = 0 then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);
|
|
LeftNum := Copy(LeftVersion, 2, DotPos - 2);
|
|
LeftStr := Copy(LeftVersion, DotPos + 1, Length(LeftVersion) - DotPos);
|
|
if not TryStrToInt(LeftNum, LeftMajor) then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);
|
|
|
|
DotPos := Pos('.', RightVersion);
|
|
if DotPos = 0 then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);
|
|
RightNum := Copy(RightVersion, 2, DotPos - 2);
|
|
RightStr := Copy(RightVersion, DotPos + 1, Length(RightVersion) - DotPos);
|
|
if not TryStrToInt(RightNum, RightMajor) then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);
|
|
|
|
Result := -1;
|
|
if LeftMajor < RightMajor then
|
|
Exit;
|
|
Result := 1;
|
|
if LeftMajor > RightMajor then
|
|
Exit;
|
|
|
|
DotPos := Pos('.', LeftStr);
|
|
if DotPos = 0 then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);
|
|
LeftNum := Copy(LeftStr, 1, DotPos - 1);
|
|
LeftStr := Copy(LeftStr, DotPos + 1, Length(LeftStr) - DotPos);
|
|
if not TryStrToInt(LeftNum, LeftMinor) then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);
|
|
|
|
DotPos := Pos('.', RightStr);
|
|
if DotPos = 0 then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);
|
|
RightNum := Copy(RightStr, 1, DotPos - 1);
|
|
RightStr := Copy(RightStr, DotPos + 1, Length(RightStr) - DotPos);
|
|
if not TryStrToInt(RightNum, RightMinor) then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);
|
|
|
|
Result := -1;
|
|
if LeftMinor < RightMinor then
|
|
Exit;
|
|
Result := 1;
|
|
if LeftMinor > RightMinor then
|
|
Exit;
|
|
|
|
if not TryStrToInt(LeftStr, LeftBuild) then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);
|
|
if not TryStrToInt(RightStr, RightBuild) then
|
|
raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);
|
|
|
|
if LeftBuild < RightBuild then
|
|
Result := -1
|
|
else if LeftBuild > RightBuild then
|
|
Result := 1
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
procedure GetProcedureAddress(var P: Pointer; const ModuleName, ProcName: string);
|
|
var
|
|
ModuleHandle: HMODULE;
|
|
begin
|
|
if not Assigned(P) then
|
|
begin
|
|
ModuleHandle := GetModuleHandle(PChar(ModuleName));
|
|
if ModuleHandle = 0 then
|
|
begin
|
|
ModuleHandle := LoadLibrary(PChar(ModuleName));
|
|
if ModuleHandle = 0 then
|
|
raise EJclError.CreateResFmt(@RsELibraryNotFound, [ModuleName]);
|
|
end;
|
|
P := GetProcAddress(ModuleHandle, PChar(ProcName));
|
|
if not Assigned(P) then
|
|
raise EJclError.CreateResFmt(@RsEFunctionNotFound, [ModuleName, ProcName]);
|
|
end;
|
|
end;
|
|
|
|
{$WARNINGS OFF}
|
|
|
|
var
|
|
_GetCORSystemDirectory: Pointer = nil;
|
|
|
|
function GetCORSystemDirectory;
|
|
begin
|
|
GetProcedureAddress(_GetCORSystemDirectory, mscoree_dll, 'GetCORSystemDirectory');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_GetCORSystemDirectory]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_GetCORVersion: Pointer = nil;
|
|
|
|
function GetCORVersion;
|
|
begin
|
|
GetProcedureAddress(_GetCORVersion, mscoree_dll, 'GetCORVersion');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_GetCORVersion]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_GetFileVersion: Pointer = nil;
|
|
|
|
function GetFileVersion;
|
|
begin
|
|
GetProcedureAddress(_GetFileVersion, mscoree_dll, 'GetFileVersion');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_GetFileVersion]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_GetCORRequiredVersion: Pointer = nil;
|
|
|
|
function GetCORRequiredVersion;
|
|
begin
|
|
GetProcedureAddress(_GetCORRequiredVersion, mscoree_dll, 'GetCORRequiredVersion');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_GetCORRequiredVersion]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_GetRequestedRuntimeInfo: Pointer = nil;
|
|
|
|
function GetRequestedRuntimeInfo;
|
|
begin
|
|
GetProcedureAddress(_GetRequestedRuntimeInfo, mscoree_dll, 'GetRequestedRuntimeInfo');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_GetRequestedRuntimeInfo]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_GetRequestedRuntimeVersion: Pointer = nil;
|
|
|
|
function GetRequestedRuntimeVersion;
|
|
begin
|
|
GetProcedureAddress(_GetRequestedRuntimeVersion, mscoree_dll, 'GetRequestedRuntimeVersion');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_GetRequestedRuntimeVersion]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_CorBindToRuntimeHost: Pointer = nil;
|
|
|
|
function CorBindToRuntimeHost;
|
|
begin
|
|
GetProcedureAddress(_CorBindToRuntimeHost, mscoree_dll, 'CorBindToRuntimeHost');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_CorBindToRuntimeHost]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_CorBindToRuntimeEx: Pointer = nil;
|
|
|
|
function CorBindToRuntimeEx;
|
|
begin
|
|
GetProcedureAddress(_CorBindToRuntimeEx, mscoree_dll, 'CorBindToRuntimeEx');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_CorBindToRuntimeEx]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_CorBindToRuntimeByCfg: Pointer = nil;
|
|
|
|
function CorBindToRuntimeByCfg;
|
|
begin
|
|
GetProcedureAddress(_CorBindToRuntimeByCfg, mscoree_dll, 'CorBindToRuntimeByCfg');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_CorBindToRuntimeByCfg]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_CorBindToRuntime: Pointer = nil;
|
|
|
|
function CorBindToRuntime;
|
|
begin
|
|
GetProcedureAddress(_CorBindToRuntime, mscoree_dll, 'CorBindToRuntime');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_CorBindToRuntime]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_CorBindToCurrentRuntime: Pointer = nil;
|
|
|
|
function CorBindToCurrentRuntime;
|
|
begin
|
|
GetProcedureAddress(_CorBindToCurrentRuntime, mscoree_dll, 'CorBindToCurrentRuntime');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_CorBindToCurrentRuntime]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_ClrCreateManagedInstance: Pointer = nil;
|
|
|
|
function ClrCreateManagedInstance;
|
|
begin
|
|
GetProcedureAddress(_ClrCreateManagedInstance, mscoree_dll, 'ClrCreateManagedInstance');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_ClrCreateManagedInstance]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_CorMarkThreadInThreadPool: Pointer = nil;
|
|
|
|
procedure CorMarkThreadInThreadPool;
|
|
begin
|
|
GetProcedureAddress(_CorMarkThreadInThreadPool, mscoree_dll, 'CorMarkThreadInThreadPool');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_CorMarkThreadInThreadPool]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_RunDll32ShimW: Pointer = nil;
|
|
|
|
function RunDll32ShimW;
|
|
begin
|
|
GetProcedureAddress(_RunDll32ShimW, mscoree_dll, 'RunDll32ShimW');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_RunDll32ShimW]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_LoadLibraryShim: Pointer = nil;
|
|
|
|
function LoadLibraryShim;
|
|
begin
|
|
GetProcedureAddress(_LoadLibraryShim, mscoree_dll, 'LoadLibraryShim');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_LoadLibraryShim]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_CallFunctionShim: Pointer = nil;
|
|
|
|
function CallFunctionShim;
|
|
begin
|
|
GetProcedureAddress(_CallFunctionShim, mscoree_dll, 'CallFunctionShim');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_CallFunctionShim]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_GetRealProcAddress: Pointer = nil;
|
|
|
|
function GetRealProcAddress;
|
|
begin
|
|
GetProcedureAddress(_GetRealProcAddress, mscoree_dll, 'GetRealProcAddress');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_GetRealProcAddress]
|
|
end;
|
|
end;
|
|
|
|
var
|
|
_CorExitProcess: Pointer = nil;
|
|
|
|
procedure CorExitProcess;
|
|
begin
|
|
GetProcedureAddress(_CorExitProcess, mscoree_dll, 'CorExitProcess');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_CorExitProcess]
|
|
end;
|
|
end;
|
|
|
|
// truncated because the symbol was not found in assembler
|
|
var
|
|
_GetRequestedRuntimeVersionForCL: Pointer = nil;
|
|
|
|
function GetRequestedRuntimeVersionForCLSID;
|
|
begin
|
|
GetProcedureAddress(_GetRequestedRuntimeVersionForCL, mscoree_dll, 'GetRequestedRuntimeVersionForCLSID');
|
|
asm
|
|
mov esp, ebp
|
|
pop ebp
|
|
jmp [_GetRequestedRuntimeVersionForCL]
|
|
end;
|
|
end;
|
|
|
|
{$WARNINGS ON}
|
|
|
|
//=== { TJclClrHost } ========================================================
|
|
|
|
const
|
|
CLR_MAJOR_VERSION = 1;
|
|
CLR_MINOR_VERSION = 0;
|
|
CLR_BUILD_VERSION = 3705;
|
|
|
|
constructor TJclClrHost.Create(const ClrVer: WideString; const Flavor: TJclClrHostFlavor;
|
|
const ConcurrentGC: Boolean; const LoaderFlags: TJclClrHostLoaderFlags);
|
|
const
|
|
ClrHostFlavorNames: array [TJclClrHostFlavor] of WideString = ('srv', 'wks');
|
|
ClrHostLoaderFlagValues: array [TJclClrHostLoaderFlag] of DWORD =
|
|
(STARTUP_LOADER_OPTIMIZATION_SINGLE_DOMAIN,
|
|
STARTUP_LOADER_OPTIMIZATION_MULTI_DOMAIN,
|
|
STARTUP_LOADER_OPTIMIZATION_MULTI_DOMAIN_HOST,
|
|
STARTUP_LOADER_SAFEMODE,
|
|
STARTUP_LOADER_SETPREFERENCE);
|
|
var
|
|
Flags: DWORD;
|
|
ALoaderFlag: TJclClrHostLoaderFlag;
|
|
begin
|
|
inherited Create;
|
|
Flags := 0;
|
|
if ConcurrentGC then
|
|
Flags := Flags or STARTUP_CONCURRENT_GC;
|
|
for ALoaderFlag := Low(TJclClrHostLoaderFlag) to High(TJclClrHostLoaderFlag) do
|
|
if ALoaderFlag in LoaderFlags then
|
|
Flags := Flags or ClrHostLoaderFlagValues[ALoaderFlag];
|
|
OleCheck(CorBindToRuntimeEx(PWideCharOrNil(ClrVer),
|
|
PWideChar(ClrHostFlavorNames[Flavor]), Flags,
|
|
CLASS_CorRuntimeHost, IID_ICorRuntimeHost, FDefaultInterface));
|
|
end;
|
|
|
|
destructor TJclClrHost.Destroy;
|
|
begin
|
|
FreeAndNil(FAppDomains);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJclClrHost.EnumAppDomains;
|
|
var
|
|
hEnum: Pointer;
|
|
Unk: IUnknown;
|
|
begin
|
|
if Assigned(FAppDomains) then
|
|
FAppDomains.Clear
|
|
else
|
|
FAppDomains := TObjectList.Create;
|
|
|
|
OleCheck(FDefaultInterface.EnumDomains(hEnum));
|
|
try
|
|
while FDefaultInterface.NextDomain(hEnum, Unk) <> S_FALSE do
|
|
TJclClrAppDomain.Create(Self, Unk as IJclClrAppDomain);
|
|
finally
|
|
OleCheck(FDefaultInterface.CloseEnum(hEnum));
|
|
end;
|
|
end;
|
|
|
|
function TJclClrHost.FindAppDomain(const Intf: IJclClrAppDomain;
|
|
var Ret: TJclClrAppDomain): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to AppDomainCount-1 do
|
|
begin
|
|
Ret := AppDomains[I];
|
|
if Ret.DefaultInterface = Intf then
|
|
begin
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Ret := nil;
|
|
Result := False;
|
|
end;
|
|
|
|
function TJclClrHost.FindAppDomain(const Name: WideString;
|
|
var Ret: TJclClrAppDomain): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to AppDomainCount-1 do
|
|
begin
|
|
Ret := AppDomains[I];
|
|
if Ret.DefaultInterface.FriendlyName = Name then
|
|
begin
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Ret := nil;
|
|
Result := False;
|
|
end;
|
|
|
|
function TJclClrHost.GetAppDomain(const Idx: Integer): TJclClrAppDomain;
|
|
begin
|
|
Result := TJclClrAppDomain(FAppDomains.Items[Idx]);
|
|
end;
|
|
|
|
function TJclClrHost.GetAppDomainCount: Integer;
|
|
begin
|
|
Result := FAppDomains.Count;
|
|
end;
|
|
|
|
function TJclClrHost.GetDefaultAppDomain: IJclClrAppDomain;
|
|
var
|
|
Unk: IUnknown;
|
|
begin
|
|
OleCheck(FDefaultInterface.GetDefaultDomain(Unk));
|
|
Result := Unk as IJclClrAppDomain;
|
|
end;
|
|
|
|
class procedure TJclClrHost.GetClrVersions(VersionNames: TWideStrings);
|
|
function DirectoryExistsW(const DirectoryName: WideString): Boolean;
|
|
var
|
|
Code: DWORD;
|
|
begin
|
|
Code := GetFileAttributesW(PWideChar(DirectoryName));
|
|
Result := (Code <> $FFFFFFFF) and ((Code and FILE_ATTRIBUTE_DIRECTORY) <> 0);
|
|
end;
|
|
const
|
|
WideDirDelimiter: WideChar = '\';
|
|
var
|
|
SystemDirectory: WideString;
|
|
Index: Integer;
|
|
PathOk: Boolean;
|
|
FindData: TWin32FindDataW;
|
|
SearchHandle: THandle;
|
|
DirectoryBuffer, VersionBuffer: WideString;
|
|
DirectoryLength, VersionLength, OldErrorMode, RuntimeInfo: DWORD;
|
|
begin
|
|
SystemDirectory := CorSystemDirectory;
|
|
|
|
if Pos('V1', AnsiUpperCase(CorVersion)) > 0 then
|
|
RunTimeInfo := 0
|
|
else
|
|
RunTimeInfo := RUNTIME_INFO_DONT_SHOW_ERROR_DIALOG;
|
|
|
|
if (SystemDirectory = '') or not DirectoryExistsW(SystemDirectory) then
|
|
Exit;
|
|
|
|
PathOk := False;
|
|
for Index := Length(SystemDirectory) - 1 downto 1 do
|
|
if SystemDirectory[Index] = WideDirDelimiter then
|
|
begin
|
|
SetLength(SystemDirectory, Index);
|
|
PathOk := True;
|
|
Break;
|
|
end;
|
|
|
|
if PathOk then
|
|
begin
|
|
SearchHandle := FindFirstFileW(PWideChar(SystemDirectory + '*.*'), FindData);
|
|
if SearchHandle = INVALID_HANDLE_VALUE then
|
|
Exit;
|
|
try
|
|
repeat
|
|
if ((FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0)
|
|
and (WideString(FindData.cFileName) <> '.') and (WideString(FindData.cFileName) <> '..') then
|
|
begin
|
|
OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
|
|
try
|
|
if (GetRequestedRuntimeInfo(nil, FindData.cFileName, nil, 0, RunTimeInfo,
|
|
nil, 0, DirectoryLength, nil, 0, VersionLength) and $1FFF = ERROR_INSUFFICIENT_BUFFER)
|
|
and (DirectoryLength > 0) and (VersionLength > 0) then
|
|
begin
|
|
SetLength(DirectoryBuffer, DirectoryLength - 1);
|
|
SetLength(VersionBuffer, VersionLength - 1);
|
|
if GetRequestedRuntimeInfo(nil, FindData.cFileName, nil, 0, RUNTIME_INFO_DONT_SHOW_ERROR_DIALOG,
|
|
PWideChar(DirectoryBuffer), DirectoryLength, DirectoryLength,
|
|
PWideChar(VersionBuffer), VersionLength, VersionLength) = S_OK then
|
|
VersionNames.Values[VersionBuffer] := DirectoryBuffer + VersionBuffer;
|
|
end;
|
|
finally
|
|
SetErrorMode(OldErrorMode);
|
|
end;
|
|
end;
|
|
until not FindNextFileW(SearchHandle, FindData);
|
|
finally
|
|
Windows.FindClose(SearchHandle);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
class procedure TJclClrHost.GetClrVersions(VersionNames: TStrings);
|
|
var
|
|
AWideStrings: TWideStrings;
|
|
Index: Integer;
|
|
begin
|
|
AWideStrings := TWideStringList.Create;
|
|
try
|
|
GetCLRVersions(AWideStrings);
|
|
for Index := 0 to AWideStrings.Count - 1 do
|
|
VersionNames.Add(AWideStrings.Strings[Index]);
|
|
finally
|
|
AWideStrings.Free;
|
|
end;
|
|
end;
|
|
|
|
function TJclClrHost.GetCurrentAppDomain: IJclClrAppDomain;
|
|
var
|
|
Unk: IUnknown;
|
|
begin
|
|
OleCheck(FDefaultInterface.CurrentDomain(Unk));
|
|
Result := Unk as IJclClrAppDomain;
|
|
end;
|
|
|
|
function TJclClrHost.AddAppDomain(const AppDomain: TJclClrAppDomain): Integer;
|
|
begin
|
|
Result := FAppDomains.Add(AppDomain);
|
|
end;
|
|
|
|
function TJclClrHost.RemoveAppDomain(const AppDomain: TJclClrAppDomain): Integer;
|
|
begin
|
|
Result := FAppDomains.Remove(AppDomain);
|
|
end;
|
|
|
|
class function TJclClrHost.CorSystemDirectory: WideString;
|
|
var
|
|
Len: DWORD;
|
|
begin
|
|
SetLength(Result, MAX_PATH);
|
|
OleCheck(GetCORSystemDirectory(PWideChar(Result), Length(Result), Len));
|
|
if Len > 0 then
|
|
SetLength(Result, Len - 1);
|
|
end;
|
|
|
|
class function TJclClrHost.CorVersion: WideString;
|
|
var
|
|
Len: DWORD;
|
|
begin
|
|
SetLength(Result, 64);
|
|
OleCheck(GetCORVersion(PWideChar(Result), Length(Result), Len));
|
|
if Len > 0 then
|
|
SetLength(Result, Len - 1);
|
|
end;
|
|
|
|
class function TJclClrHost.CorRequiredVersion: WideString;
|
|
var
|
|
Len: DWORD;
|
|
begin
|
|
SetLength(Result, 64);
|
|
OleCheck(GetCORRequiredVersion(PWideChar(Result), Length(Result), Len));
|
|
if Len > 0 then
|
|
SetLength(Result, Len - 1);
|
|
end;
|
|
|
|
function TJclClrHost.CreateDomainSetup: TJclClrAppDomainSetup;
|
|
var
|
|
pUnk: IUnknown;
|
|
begin
|
|
OleCheck(FDefaultInterface.CreateDomainSetup(pUnk));
|
|
Result := TJclClrAppDomainSetup.Create(pUnk as IAppDomainSetup);
|
|
end;
|
|
|
|
function TJclClrHost.CreateAppDomain(const Name: WideString;
|
|
const Setup: TJclClrAppDomainSetup;
|
|
const Evidence: IJclClrEvidence): TJclClrAppDomain;
|
|
var
|
|
pUnk: IUnknown;
|
|
begin
|
|
OleCheck(FDefaultInterface.CreateDomainEx(PWideChar(Name), Setup as IAppDomainSetup, Evidence, pUnk));
|
|
Result := TJclClrAppDomain.Create(Self, pUnk as IJclClrAppDomain);
|
|
end;
|
|
|
|
procedure TJclClrHost.Start;
|
|
begin
|
|
OleCheck(DefaultInterface.Start);
|
|
Refresh;
|
|
end;
|
|
|
|
procedure TJclClrHost.Stop;
|
|
begin
|
|
OleCheck(DefaultInterface.Stop);
|
|
end;
|
|
|
|
procedure TJclClrHost.Refresh;
|
|
begin
|
|
EnumAppDomains;
|
|
end;
|
|
|
|
//=== { TJclClrAppDomain } ===================================================
|
|
|
|
constructor TJclClrAppDomain.Create(const AHost: TJclClrHost;
|
|
const AAppDomain: IJclClrAppDomain);
|
|
begin
|
|
Assert(Assigned(AHost));
|
|
Assert(Assigned(AAppDomain));
|
|
inherited Create;
|
|
FHost := AHost;
|
|
FDefaultInterface := AAppDomain;
|
|
FHost.AddAppDomain(Self);
|
|
end;
|
|
|
|
function TJclClrAppDomain.Execute(const AssemblyFile: TFileName;
|
|
const Arguments: TJclClrAssemblyArguments;
|
|
const AssemblySecurity: IJclClrEvidence): Integer;
|
|
var
|
|
Args: Variant;
|
|
begin
|
|
Assert(FileExists(AssemblyFile));
|
|
if Length(Arguments) = 0 then
|
|
Result := Execute(AssemblyFile, AssemblySecurity)
|
|
else
|
|
begin
|
|
DynArrayToVariant(Args, @Arguments[0], TypeInfo(TJclClrAssemblyArguments));
|
|
Result := DefaultInterface.ExecuteAssembly_3(AssemblyFile, AssemblySecurity, PSafeArray(TVarData(Args).VArray));
|
|
end;
|
|
end;
|
|
|
|
function TJclClrAppDomain.Execute(const AssemblyFile: TFileName;
|
|
const AssemblySecurity: IJclClrEvidence): Integer;
|
|
begin
|
|
Assert(FileExists(AssemblyFile));
|
|
if Assigned(AssemblySecurity) then
|
|
Result := DefaultInterface.ExecuteAssembly(AssemblyFile, AssemblySecurity)
|
|
else
|
|
Result := DefaultInterface.ExecuteAssembly_2(AssemblyFile);
|
|
end;
|
|
|
|
function TJclClrAppDomain.Execute(const AssemblyFile: TFileName;
|
|
const Arguments: TStrings; const AssemblySecurity: IJclClrEvidence): Integer;
|
|
var
|
|
Args: Variant;
|
|
Index: Integer;
|
|
begin
|
|
Assert(FileExists(AssemblyFile));
|
|
if Arguments.Count = 0 then
|
|
Result := Execute(AssemblyFile, AssemblySecurity)
|
|
else
|
|
begin
|
|
Args := VarArrayCreate([0, Arguments.Count - 1], varOleStr);
|
|
for Index := 0 to Arguments.Count - 1 do
|
|
Args[Index] := WideString(Arguments.Strings[Index]);
|
|
Result := DefaultInterface.ExecuteAssembly_3(AssemblyFile, AssemblySecurity, PSafeArray(TVarData(Args).VArray));
|
|
end;
|
|
end;
|
|
|
|
function TJclClrAppDomain.Load(const AssemblyString: WideString;
|
|
const AssemblySecurity: IJclClrEvidence): TJclClrAssembly;
|
|
begin
|
|
if Assigned(AssemblySecurity) then
|
|
Result := TJclClrAssembly.Create(DefaultInterface.Load_7(AssemblyString, AssemblySecurity))
|
|
else
|
|
Result := TJclClrAssembly.Create(DefaultInterface.Load_2(AssemblyString));
|
|
end;
|
|
|
|
function TJclClrAppDomain.Load(const RawAssemblyStream,
|
|
RawSymbolStoreStream: TStream;
|
|
const AssemblySecurity: IJclClrEvidence): TJclClrAssembly;
|
|
var
|
|
RawAssembly, RawSymbolStore: Variant;
|
|
begin
|
|
Assert(Assigned(RawAssemblyStream));
|
|
RawAssembly := VarArrayCreate([0, RawAssemblyStream.Size-1], varByte);
|
|
try
|
|
try
|
|
RawAssemblyStream.Read(VarArrayLock(RawAssembly)^, RawAssemblyStream.Size);
|
|
finally
|
|
VarArrayUnlock(RawAssembly);
|
|
end;
|
|
|
|
if not Assigned(RawSymbolStoreStream) then
|
|
Result := TJclClrAssembly.Create(DefaultInterface.Load_3(PSafeArray(TVarData(RawAssembly).VArray)))
|
|
else
|
|
begin
|
|
RawSymbolStore := VarArrayCreate([0, RawSymbolStoreStream.Size-1], varByte);
|
|
try
|
|
try
|
|
RawSymbolStoreStream.Read(VarArrayLock(RawSymbolStore)^, RawSymbolStoreStream.Size);
|
|
finally
|
|
VarArrayUnlock(RawSymbolStore);
|
|
end;
|
|
|
|
if Assigned(AssemblySecurity) then
|
|
Result := TJclClrAssembly.Create(DefaultInterface.Load_5(
|
|
PSafeArray(TVarData(RawAssembly).VArray),
|
|
PSafeArray(TVarData(RawSymbolStore).VArray),
|
|
AssemblySecurity))
|
|
else
|
|
Result := TJclClrAssembly.Create(DefaultInterface.Load_4(
|
|
PSafeArray(TVarData(RawAssembly).VArray),
|
|
PSafeArray(TVarData(RawSymbolStore).VArray)));
|
|
finally
|
|
VarClear(RawSymbolStore);
|
|
end;
|
|
end;
|
|
finally
|
|
VarClear(RawAssembly);
|
|
end;
|
|
end;
|
|
|
|
procedure TJclClrAppDomain.Unload;
|
|
var
|
|
AppDomain: TJclClrAppDomain;
|
|
begin
|
|
OleCheck(FHost.DefaultInterface.UnloadDomain(DefaultInterface));
|
|
if FHost.FindAppDomain(DefaultInterface, AppDomain) and (AppDomain = Self) then
|
|
FHost.RemoveAppDomain(Self);
|
|
end;
|
|
|
|
//=== { TJclClrObject } ======================================================
|
|
|
|
constructor TJclClrObject.Create(const AssemblyName, NamespaceName, ClassName: WideString;
|
|
const Parameters: array of const);
|
|
begin
|
|
inherited Create;
|
|
end;
|
|
|
|
constructor TJclClrObject.Create(const AssemblyName, NamespaceName, ClassName: WideString;
|
|
const NewInstance: Boolean);
|
|
begin
|
|
Create(AssemblyName, NamespaceName, ClassName, []);
|
|
end;
|
|
|
|
function TJclClrObject.GetField(const Name: WideString): TJclClrField;
|
|
begin
|
|
// (rom) added to suppress warning until implementation
|
|
Result := nil;
|
|
end;
|
|
|
|
function TJclClrObject.GetProperty(const Name: WideString): TJclClrProperty;
|
|
begin
|
|
// (rom) added to suppress warning until implementation
|
|
Result := nil;
|
|
end;
|
|
|
|
function TJclClrObject.GetMethod(const Name: WideString): TJclClrMethod;
|
|
begin
|
|
// (rom) added to suppress warning until implementation
|
|
Result := nil;
|
|
end;
|
|
|
|
//=== { TJclClrAppDomainSetup } ==============================================
|
|
|
|
constructor TJclClrAppDomainSetup.Create(Intf: IAppDomainSetup);
|
|
begin
|
|
Assert(Assigned(Intf));
|
|
inherited Create;
|
|
FDefaultInterface := Intf;
|
|
end;
|
|
|
|
function TJclClrAppDomainSetup.GetApplicationBase: WideString;
|
|
begin
|
|
OleCheck(FDefaultInterface.Get_ApplicationBase(Result));
|
|
end;
|
|
|
|
function TJclClrAppDomainSetup.GetApplicationName: WideString;
|
|
begin
|
|
OleCheck(FDefaultInterface.Get_ApplicationName(Result));
|
|
end;
|
|
|
|
function TJclClrAppDomainSetup.GetCachePath: WideString;
|
|
begin
|
|
OleCheck(FDefaultInterface.Get_CachePath(Result));
|
|
end;
|
|
|
|
function TJclClrAppDomainSetup.GetConfigurationFile: WideString;
|
|
begin
|
|
OleCheck(FDefaultInterface.Get_ConfigurationFile(Result));
|
|
end;
|
|
|
|
function TJclClrAppDomainSetup.GetDynamicBase: WideString;
|
|
begin
|
|
OleCheck(FDefaultInterface.Get_DynamicBase(Result));
|
|
end;
|
|
|
|
function TJclClrAppDomainSetup.GetLicenseFile: WideString;
|
|
begin
|
|
OleCheck(FDefaultInterface.Get_LicenseFile(Result));
|
|
end;
|
|
|
|
function TJclClrAppDomainSetup.GetPrivateBinPath: WideString;
|
|
begin
|
|
OleCheck(FDefaultInterface.Get_PrivateBinPath(Result));
|
|
end;
|
|
|
|
function TJclClrAppDomainSetup.GetPrivateBinPathProbe: WideString;
|
|
begin
|
|
OleCheck(FDefaultInterface.Get_PrivateBinPathProbe(Result));
|
|
end;
|
|
|
|
function TJclClrAppDomainSetup.GetShadowCopyDirectories: WideString;
|
|
begin
|
|
OleCheck(FDefaultInterface.Get_ShadowCopyDirectories(Result));
|
|
end;
|
|
|
|
function TJclClrAppDomainSetup.GetShadowCopyFiles: WideString;
|
|
begin
|
|
OleCheck(FDefaultInterface.Get_ShadowCopyFiles(Result));
|
|
end;
|
|
|
|
procedure TJclClrAppDomainSetup.SetApplicationBase(const Value: WideString);
|
|
begin
|
|
OleCheck(FDefaultInterface.Set_ApplicationBase(Value));
|
|
end;
|
|
|
|
procedure TJclClrAppDomainSetup.SetApplicationName(const Value: WideString);
|
|
begin
|
|
OleCheck(FDefaultInterface.Set_ApplicationName(Value));
|
|
end;
|
|
|
|
procedure TJclClrAppDomainSetup.SetCachePath(const Value: WideString);
|
|
begin
|
|
OleCheck(FDefaultInterface.Set_CachePath(Value));
|
|
end;
|
|
|
|
procedure TJclClrAppDomainSetup.SetConfigurationFile(const Value: WideString);
|
|
begin
|
|
OleCheck(FDefaultInterface.Set_ConfigurationFile(Value));
|
|
end;
|
|
|
|
procedure TJclClrAppDomainSetup.SetDynamicBase(const Value: WideString);
|
|
begin
|
|
OleCheck(FDefaultInterface.Set_DynamicBase(Value));
|
|
end;
|
|
|
|
procedure TJclClrAppDomainSetup.SetLicenseFile(const Value: WideString);
|
|
begin
|
|
OleCheck(FDefaultInterface.Set_LicenseFile(Value));
|
|
end;
|
|
|
|
procedure TJclClrAppDomainSetup.SetPrivateBinPath(const Value: WideString);
|
|
begin
|
|
OleCheck(FDefaultInterface.Set_PrivateBinPath(Value));
|
|
end;
|
|
|
|
procedure TJclClrAppDomainSetup.SetPrivateBinPathProbe(const Value: WideString);
|
|
begin
|
|
OleCheck(FDefaultInterface.Set_PrivateBinPathProbe(Value));
|
|
end;
|
|
|
|
procedure TJclClrAppDomainSetup.SetShadowCopyDirectories(const Value: WideString);
|
|
begin
|
|
OleCheck(FDefaultInterface.Set_ShadowCopyDirectories(Value));
|
|
end;
|
|
|
|
procedure TJclClrAppDomainSetup.SetShadowCopyFiles(const Value: WideString);
|
|
begin
|
|
OleCheck(FDefaultInterface.Set_ShadowCopyFiles(Value));
|
|
end;
|
|
|
|
//=== { TJclClrAssembly } ====================================================
|
|
|
|
constructor TJclClrAssembly.Create(Intf: IJclClrAssembly);
|
|
begin
|
|
Assert(Assigned(Intf));
|
|
inherited Create;
|
|
FDefaultInterface := Intf;
|
|
end;
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
initialization
|
|
RegisterUnitVersion(HInstance, UnitVersioning);
|
|
|
|
finalization
|
|
UnregisterUnitVersion(HInstance);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
end.
|