jcldotnet.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ 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)                                                                       }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Microsoft .Net framework support routines and classes.                                           }
{                                                                                                  }
{ Unit owner: Flier Lu                                                                             }
{                                                                                                  }
{**************************************************************************************************}

// Last modified: $Date: 2005/03/08 08:33:22 $
// For history see end of file

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 MSWINDOWS}
  Windows, ActiveX,
  {$ENDIF MSWINDOWS}
  Classes, SysUtils,
  {$IFDEF RTL130_UP}
  Contnrs,
  {$ENDIF RTL130_UP}
  JclBase,
  mscoree_TLB, mscorlib_TLB;

{ 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
  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;
    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;

type
  HDOMAINENUM = Pointer;

function GetCORSystemDirectory(pbuffer: PWideChar; const cchBuffer: DWORD;
  var dwLength: DWORD): HRESULT; stdcall;
function GetCORVersion(pbuffer: PWideChar; const cchBuffer: DWORD;
  var dwLength: DWORD): HRESULT; stdcall;
function GetCORRequiredVersion(pbuffer: PWideChar; const cchBuffer: DWORD;
  var dwLength: DWORD): HRESULT; stdcall;
function CorBindToRuntimeHost(pwszVersion, pwszBuildFlavor, pwszHostConfigFile: PWideChar;
  const pReserved: Pointer; const startupFlags: DWORD;
  const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;
function CorBindToRuntimeEx(pwszVersion, pwszBuildFlavor: PWideChar; startupFlags: DWORD;
  const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;
function CorBindToRuntimeByCfg(const pCfgStream: IStream; const reserved, startupFlags: DWORD;
  const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;
function CorBindToRuntime(pwszVersion, pwszBuildFlavor: PWideChar;
  const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;
function CorBindToCurrentRuntime(pwszFileName: PWideChar;
  const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;
function ClrCreateManagedInstance(pTypeName: PWideChar;
  const riid: TIID; out pv): HRESULT; stdcall;
procedure CorMarkThreadInThreadPool; stdcall;
function RunDll32ShimW(const hwnd: HWND; const hinst: HMODULE;
  lpszCmdLine: PWideChar; const nCmdShow: Integer): HRESULT; stdcall;
function LoadLibraryShim(szDllName, szVersion: PWideChar;
  const pvReserved: Pointer; out phModDll: HMODULE): HRESULT; stdcall;
function CallFunctionShim(szDllName: PWideChar; const szFunctionName: PChar;
  const lpvArgument1, lpvArgument2: Pointer; szVersion: PWideChar;
  const pvReserved: Pointer): HRESULT; stdcall;
function GetRealProcAddress(const pwszProcName: PChar; out ppv: Pointer): HRESULT; stdcall;
procedure CorExitProcess(const exitCode: Integer); stdcall;

implementation

uses
  ComObj, Variants, Provider,
  JclSysUtils;

const
  mscoree_dll = 'mscoree.dll';

function GetCORSystemDirectory; external mscoree_dll;
function GetCORVersion; external mscoree_dll;
function GetCORRequiredVersion; external mscoree_dll;
function CorBindToRuntimeHost; external mscoree_dll;
function CorBindToRuntimeEx; external mscoree_dll;
function CorBindToRuntimeByCfg; external mscoree_dll;
function CorBindToRuntime; external mscoree_dll;
function CorBindToCurrentRuntime; external mscoree_dll;
function ClrCreateManagedInstance; external mscoree_dll;
procedure CorMarkThreadInThreadPool; external mscoree_dll;
function RunDll32ShimW; external mscoree_dll;
function LoadLibraryShim; external mscoree_dll;
function CallFunctionShim; external mscoree_dll;
function GetRealProcAddress; external mscoree_dll;
procedure CorExitProcess; external mscoree_dll;

//=== { TJclClrHost } ========================================================

const
  CLR_MAJOR_VERSION = 1;
  CLR_MINOR_VERSION = 0;
  CLR_BUILD_VERSION = 3705;

  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;

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;