Jump to content

rcaspers

Members
  • Content Count

    2
  • Joined

  • Last visited

Community Reputation

0 Neutral

Recent Profile Visitors

The recent visitors block is disabled and is not being shown to other users.

  1. 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
  2. rcaspers

    Control TDataSet strings encoding (auto encode to utf-8)

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