rcaspers

Hello,

I need to run a .Net standard Assembly from a Delphi unit.

Up to .Net 4 we used JclDotNet to do so, but JclDotNet does not support .Net Stanard Code or .Net 5.0

I am stuck on the coreclr_create_delegate method.

Any help would be mutch apprecieaded.

This what i have so far.

The c++ headers i wil have to translate are attached.

unit Unit2;

interface

uses
  WinApi.Windows,
  System.Classes,
  System.SysUtils;

const
  coreClrPath = 'C:\Program Files (x86)\dotnet\shared\Microsoft.NETCore.App\3.1.13';

type
 TAnsiArray = array[0..1] of PAnsiChar;

type
	TClrInitialize = function(AssemblyPath, AppDomainName: PAnsiChar; PropertyCount: NativeUInt; const PropertyKeys, PropertyValues: TAnsiArray; hostHandle: PPointer; DomainId: PNativeUInt) : NativeInt; stdcall;
  TClrCreateDelegate = function(HostHandle: Pointer; DomainId: THandle; AssemblyName, Classname, MethodName: PAnsiChar; MethodHandle: PPointer): NativeInt; stdcall;
  TClrShutDown = function(HostHandle: Pointer; DomainId: NativeUInt): NativeInt; stdcall;

  TFileList = class(TStringList)
  public
    procedure AddFiles(Directory, FileMask: String);
  end;

  procedure Test;

implementation

procedure TFileList.AddFiles(Directory, FileMask: String);
var
  Found: Boolean;
  SearchRec: TSearchRec;
begin
  Directory := IncludeTrailingPathDelimiter(Directory);
  Found := FindFirst(Directory + FileMask, faAnyFile, SearchRec) = 0;
  try
    while Found do
    begin
      if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') and (SearchRec.Attr and faDirectory <> faDirectory) then
        Add(Directory + SearchRec.Name);
      Found := (FindNext(SearchRec) = 0);
    end;
  finally
    FindClose(SearchRec);
  end;
end;

function GetTrustedAssemblies(RunTimeDirectory: String): AnsiString;
var
  FileList: TFileList;
begin
  FileList := TFileList.Create;
  try
    FileList.Delimiter := ';';
    FileList.AddFiles(RunTimeDirectory, '*.dll');
    Result := AnsiString(FileList.DelimitedText);
  finally
    FreeAndNil(FileList);
  end;
end;

procedure Test;
var
  DomainId: NativeUInt;
  ResultHandle: HResult;
  DllPath: String;
  propertyKeys, propertyValues: TAnsiArray;
  AssemblyPath, AssemblyName, ExePath, ClassName, MethodName: AnsiString;
  coreClrLibrary: THandle;
  clrHostHandle: PNativeUInt;
  clrMethodHandle: PPointer;//NativeUInt;
  clrInitialize: TClrInitialize;
  clrCreateDelegate: TClrCreateDelegate;
  clrShutDown: TClrShutDown;
begin
  AssemblyPath := AnsiString(ExtractFilePath(ParamStr(0)));

  propertyKeys[0] := 'APP_PATHS';
  propertyKeys[1] := 'TRUSTED_PLATFORM_ASSEMBLIES';

  propertyValues[0] := PAnsiChar(AssemblyPath);
  propertyValues[1] := PAnsiChar(GetTrustedAssemblies(coreClrPath));

  DomainId := 0;
  DllPath := IncludeTrailingPathDelimiter(coreClrPath) + 'coreclr.dll';
  SetLastError(0);
  coreClrLibrary := LoadLibrary(PWideChar(DLLPath));
  if (coreClrLibrary = 0) then
  begin
    WriteLn(SysErrorMessage(GetLastError()));
    Exit;
  end;

  SetLastError(0);
  @clrInitialize := GetProcAddress(coreClrLibrary, 'coreclr_initialize');
  if not Assigned(clrInitialize) then
  begin
    WriteLn(SysErrorMessage(GetLastError()));
    Exit;
  end;

  @clrCreateDelegate := GetProcAddress(coreClrLibrary, 'coreclr_create_delegate');
  if not Assigned(clrCreateDelegate) then
  begin
    WriteLn(SysErrorMessage(GetLastError()));
    Exit;
  end;

  @clrShutDown := GetProcAddress(coreClrLibrary, 'coreclr_shutdown');
  if not Assigned(clrShutDown) then
  begin
    WriteLn(SysErrorMessage(GetLastError()));
    Exit;
  end;

  SetLastError(0);
  ExePath := AnsiString(Paramstr(0));
  WriteLn('Initialize clr');
  ResultHandle := clrInitialize(PAnsiChar(ExePath), 'AppDomain', Length(PropertyKeys), propertyKeys, propertyValues, @clrHostHandle, @DomainId);
  if not Assigned(clrHostHandle) or (ResultHandle <> 0) then
  begin
    WriteLn(SysErrorMessage(GetLastError()));
    Exit;
  end;

  AssemblyName := 'ClassLibrary1, Version = 1.0.0.0';
  ClassName := 'TestNamespace.Class1';
  MethodName := 'SaySomething';

  SetLastError(0);
  WriteLn('Create Delegate');
  ResultHandle := clrCreateDelegate(clrHostHandle, DomainId, PAnsiChar(AssemblyName), PAnsiChar(ClassName), PAnsiChar(MethodName), @clrMethodHandle);
  if not Assigned(clrMethodHandle) or (ResultHandle <> 0) then
  begin
    //clrMethodHandle = nil
    // GetLastError = 0
    // ResultHandle = -2146233069
    WriteLn(SysErrorMessage(GetLastError()));
  end;

  WriteLn('shutdown');
  ResultHandle := clrShutDown(clrHostHandle, DomainId);
  if (ResultHandle <> 0) then
  begin
    WriteLn(SysErrorMessage(GetLastError()));
  end;
end;

end.

namespace TestNamespace
{
    using System;
    public class Class1
    {
        public string SaySomething()
        {
            return "Hello everyone";
        }
    }
}

corclrhost.h

maybe you can override a TStringField and tell your program to use that as the default.

i, on the other hand am very curious for the solution you seem to have found

René

  TUnicodeStringField = class(TStringField)
  protected
    function GetAsString: string; override;
    procedure SetAsString(const Value: string); override;
  end;

implementation

{ TUnicodeStringField }

function TUnicodeStringField.GetAsString: string;
begin
  // your solution here
end;

procedure TUnicodeStringField.SetAsString(const Value: string);
begin
  inherited;
  // your solution here
end;

    DefaultFieldClasses[ftString] := TUnicodeStringField;