Unbegrenzt viele Nachkommastellen

[Dano]

so, und nun das fertige ergebniss

Delphi-Quellcode:

unit InterfaceString;

interface   

type
  // Das String Interface
  IString = Interface(IInterface)
    function  IS_GetString: String;
    procedure IS_SetString(AString: String);
    function  IS_GetRefCount: Integer;
    property  RefCount: Integer read IS_GetRefCount ;
    property  AString: String read IS_GetString write IS_SetString;
  end;

  // Die VMT für das String Interface
  PStringVMT = ^TStringVMT;
  TStringVMT = packed record
    QueryInterface: Pointer;
    AddRef: Pointer;
    Release: Pointer;
    GetString: Pointer;
    SetString: Pointer;
    GetRefCount: Pointer;
  end;

  // Der Record für das String Interface
  //PPStringIntf = ^PStringIntf;
  PStringIntf = ^TStringIntf;
  TStringIntf = packed record
    StringVMT: PStringVMT;
    RefCount: Integer;
    AString: String;
  end;


procedure StringInit(var Dest: IString);
function  IS_QueryInterface(Self: PStringIntf; const IID: TGUID; out Obj): HResult; stdcall;
function  IS_AddRef(Self: PStringIntf): Integer; stdcall;
function  IS_Release(Self: PStringIntf): Integer; stdcall;
function  IS_GetString(Self: PStringIntf): String;
procedure IS_SetString(Self: PStringIntf; AString: String);
function  IS_GetRefCount(Self: PStringIntf): Integer;

function  InterlockedIncrement(var I: Integer): Integer;
function  InterlockedDecrement(var I: Integer): Integer;

const
  // Die VMT für IString fertig Initialisiert
  ISGlobalVMT: TStringVMT = (
    QueryInterface: @IS_QueryInterface;
    AddRef: @IS_AddRef;
    Release: @IS_Release;
    GetString: @IS_GetString;
    SetString: @IS_SetString;
    GetRefCount: @IS_GetRefCount);    

implementation

// Initialisiert das interface
procedure StringInit(var Dest: IString);
var
  NewIString: PStringIntf;
begin
  New(NewIString);
  NewIString^.StringVMT:=@ISGlobalVMT;
  NewIString^.RefCount:=0;
  NewIString^.AString:='Neues Interface';
  //SetLength(NewIString^.AString,$ffffff);  //test ob IString freigegeben wird
  Dest:=IString(NewIString);
end;

function IS_QueryInterface(Self: PStringIntf; const IID: TGUID; out Obj): HResult; stdcall;
begin Result := HResult($80004002); end;

function IS_AddRef(Self: PStringIntf): Integer;
begin
  InterlockedIncrement(Self.RefCount);
  Result := Self.RefCount;
end;

// refcounter verringern und bei 0 den string freigeben
function IS_Release(Self: PStringIntf): Integer;
begin
  InterlockedDecrement(Self.RefCount);
  Result := Self.RefCount;
  if Result = 0 then begin
    Self.AString:='';
    Dispose(Self);
  end;
end;

function  IS_GetString(Self: PStringIntf): String;
begin
  Result:=Self.AString;
end;

procedure IS_SetString(Self: PStringIntf; AString: String);
begin
  Self.AString:=AString;
end;

function  IS_GetRefCount(Self: PStringIntf): Integer;
begin
  Result:=Self.RefCount;
end;

function InterlockedIncrement(var I: Integer): Integer;
asm
      MOV   EDX,1
      XCHG  EAX,EDX
 LOCK XADD  [EDX],EAX
      INC   EAX
end;

function InterlockedDecrement(var I: Integer): Integer;
asm
      MOV   EDX,-1
      XCHG  EAX,EDX
 LOCK XADD  [EDX],EAX
      DEC   EAX
end;

end.

nur schade das man bei
IIString.AString:='lalalalalalalalalala'; kein "Copy on Write Demand" einbauen kann


aber immerhin funzt es erstmal

mfg Dano