core.binary.pas

unit core.binary;
// binary key-value pairs serialization
// Need support delphi6/7, The latest grammar cannot be used.
// cxg 2026
{$ifdef fpc}
{$mode delphi}{$H+}
{$endif}

interface

uses Variants, SysUtils, Classes, SyncObjs;

{$IFNDEF fpc}
{$IF CompilerVersion < 18}

// before delphi 2007
type
  TBytes = array of byte;
{$IFEND}
{$IFNDEF UNICODE}

type
  RawByteString = AnsiString;
  PRawByteString = ^RawByteString;
{$ENDIF}
{$ENDIF}

type
  str = RawByteString;
  Pstr = PRawByteString;
  int = integer;
  Pint = PInteger;
  bool = Boolean;
  Pbool = PBoolean;

  TMemPool = class
  private
    FList: TList;
    CS: TCriticalSection;
    FPoolSize: Integer;
  private
    procedure Init;
    function NewObject: TMemoryStream;
  public
    constructor Create(APoolSize: Integer);
    destructor Destroy; override;
  public
    //get a object from pool
    function Lock: TMemoryStream; virtual;
    //return a object to the pool
    procedure Unlock(AValue: TMemoryStream); virtual;
  end;

  TData = class
  private
    FKey: str; // The key must be unique
    FValue: TBytes; // value
  private
    FList: TList;
  private
    function Path(const AKey: str): TData;
    function GetByteCount: int;
  private
    function GetByte(const AKey: str): byte;
    procedure SetByte(const AKey: str; const AValue: byte);
    function GetWord(const AKey: str): Word;
    procedure SetWord(const AKey: str; const AValue: Word);
    function GetCardinal(const AKey: str): Cardinal;
    procedure SetCardinal(const AKey: str; const AValue: Cardinal);
    function GetI(const AKey: str): int;
    procedure SetI(const AKey: str; const AValue: int);
    function GetI64(const AKey: str): Int64;
    procedure SetI64(const AKey: str; const AValue: Int64);
    function GetB(const AKey: str): bool;
    procedure SetB(const AKey: str; const AValue: bool);
    function GetD(const AKey: str): Double;
    procedure SetD(const AKey: str; const AValue: Double);
    function GetDT(const AKey: str): TDateTime;
    procedure SetDT(const AKey: str; const AValue: TDateTime);
    function GetC(const AKey: str): Currency;
    procedure SetC(const AKey: str; const AValue: Currency);
    function GetS(const AKey: str): str;
    procedure SetS(const AKey, AValue: str);
    function GetV(const AKey: str): Variant;
    procedure SetV(const AKey: str; const AValue: Variant);
    function GetST(const AKey: str): TStream;
    procedure SetST(const AKey: str; const AValue: TStream);
    function GetBT(const AKey: str): TBytes;
    procedure SetBT(const AKey: str; const AValue: TBytes);
  public
    property byte[const key: str]: byte read GetByte write SetByte;
    property Word[const key: str]: Word read GetWord write SetWord;
    property Cardinal[const key: str]: Cardinal read GetCardinal
      write SetCardinal;
    property I[const key: str]: int read GetI write SetI;
    property I64[const key: str]: Int64 read GetI64 write SetI64;
    property B[const key: str]: bool read GetB write SetB;
    property C[const key: str]: Currency read GetC write SetC;
    property D[const key: str]: Double read GetD write SetD;
    property DateTime[const key: str]: TDateTime read GetDT write SetDT;
    property S[const key: str]: str read GetS write SetS;
    property V[const key: str]: Variant read GetV write SetV;
    // TClientDataset's data and delta
    property Stream[const key: str]: TStream read GetST write SetST;
    property Bytes[const key: str]: TBytes read GetBT write SetBT;
  public // marshal
    procedure ToStream(AStream: TStream);
    function ToRaw: str;
    function ToBytes: TBytes;
  public // unmarshal
    procedure FromStream(AStream: TStream);
    procedure FromRaw(const AValue: str);
    procedure FromBytes(const AValue: TBytes);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear; // clear list;
  end;

var MemPool: TMemPool;

implementation

procedure TData.Clear;
begin
  while FList.Count > 0 do
  begin
    TData(FList[0]).free;
    FList.Delete(0);
  end;
end;

constructor TData.Create;
begin
  FList := TList.Create;
end;

destructor TData.Destroy;
begin
  Clear;
  FreeAndNil(FList);
end;

function TData.Path(const AKey: str): TData;
var
  I: int;
  LFound: bool;
begin
  Result := nil;
  LFound := False;
  for I := 0 to FList.Count - 1 do
  begin
    if AKey = TData(FList[I]).FKey then
    begin
      Result := TData(FList[I]);
      exit;
    end;
  end;
  if not LFound then
  begin
    Result := TData.Create;
    Result.FKey := AKey;
    FList.Add(Result);
  end;
end;

procedure TData.FromBytes(const AValue: TBytes);
var
  LData: TData;
  LPos, LLen: int;
  LKey: str;
begin
  LPos := 0;
  while LPos < length(AValue) do
  begin
    Move(AValue[LPos], LLen, SizeOf(int));
    LPos := LPos + SizeOf(int);
    SetLength(LKey, LLen);
    Move(AValue[LPos], Pstr(LKey)^, LLen);
    LPos := LPos + LLen;
    Move(AValue[LPos], LLen, SizeOf(int));
    LPos := LPos + SizeOf(int);
    LData := TData.Create;
    SetLength(LData.FValue, LLen);
    Move(AValue[LPos], pbyte(LData.FValue)^, LLen);
    LPos := LPos + LLen;
    LData.FKey := LKey;
    FList.Add(LData);
  end;
end;

procedure TData.FromRaw(const AValue: str);
var
  LData: TData;
  LPos, LLen: int;
  LKey: str;
begin
  LPos := 1;
  while LPos < length(AValue) do
  begin
    Move(AValue[LPos], LLen, SizeOf(int));
    LPos := LPos + SizeOf(int);
    SetLength(LKey, LLen);
    Move(AValue[LPos], Pstr(LKey)^, LLen);
    LPos := LPos + LLen;
    Move(AValue[LPos], LLen, SizeOf(int));
    LPos := LPos + SizeOf(int);
    LData := TData.Create;
    SetLength(LData.FValue, LLen);
    Move(AValue[LPos], pbyte(LData.FValue)^, LLen);
    LPos := LPos + LLen;
    LData.FKey := LKey;
    FList.Add(LData);
  end;
end;

procedure TData.FromStream(AStream: TStream);
var
  LLen: int;
  LKey: str;
  LData: TData;
begin
  AStream.Position := 0;
  while AStream.Position < AStream.size do
  begin
    AStream.Read(LLen, SizeOf(int));
    SetLength(LKey, LLen);
    AStream.Read(Pstr(LKey)^, LLen);
    AStream.Read(LLen, SizeOf(int));
    LData := TData.Create;
    SetLength(LData.FValue, LLen);
    AStream.Read(pbyte(LData.FValue)^, LLen);
    LData.FKey := LKey;
    FList.Add(LData);
  end;
end;

function TData.GetB(const AKey: str): bool;
var
  LData: TData;
begin
  LData := Path(AKey);
  Result := Pbool(LData.FValue)^;
end;

function TData.GetBT(const AKey: str): TBytes;
var
  LData: TData;
  LLen: int;
begin
  LData := Path(AKey);
  LLen := length(LData.FValue);
  SetLength(Result, LLen);
  Move(pbyte(LData.FValue)^, pbyte(Result)^, LLen);
end;

function TData.GetD(const AKey: str): Double;
var
  LData: TData;
begin
  LData := Path(AKey);
  Result := PDouble(LData.FValue)^;
end;

function TData.GetDT(const AKey: str): TDateTime;
var
  LData: TData;
begin
  LData := Path(AKey);
  Result := PDateTime(LData.FValue)^;
end;

function TData.GetI(const AKey: str): int;
var
  LData: TData;
begin
  LData := Path(AKey);
  Result := Pint(LData.FValue)^;
end;

function TData.GetI64(const AKey: str): Int64;
var
  LData: TData;
begin
  LData := Path(AKey);
  Result := PInt64(LData.FValue)^;
end;

function TData.GetS(const AKey: str): str;
var
  LData: TData;
  LLen: int;
begin
  LData := Path(AKey);
  LLen := length(LData.FValue);
  if LLen = 0 then
    Result := ''
  else
  begin
    SetLength(Result, LLen);
    Move(pbyte(LData.FValue)^, Pstr(Result)^, LLen);
  end;
end;

function TData.GetByte(const AKey: str): byte;
var
  LData: TData;
begin
  LData := Path(AKey);
  Result := pbyte(LData.FValue)^;
end;

function TData.GetByteCount: int;
var
  I: int;
begin
  Result := 0;
  for I := 0 to FList.Count - 1 do
    Result := Result + SizeOf(int) * 2 + length(TData(FList[I]).FKey) +
      length(TData(FList[I]).FValue);
end;

function TData.GetC(const AKey: str): Currency;
var
  LData: TData;
begin
  LData := Path(AKey);
  Result := PCurrency(LData.FValue)^;
end;

function TData.GetCardinal(const AKey: str): Cardinal;
var
  LData: TData;
begin
  LData := Path(AKey);
  Result := PCardinal(LData.FValue)^;
end;

function TData.GetST(const AKey: str): TStream;
var
  LData: TData;
  LLen: int;
begin
  LData := Path(AKey);
  LLen := length(LData.FValue);
  Result := MemPool.Lock;
  Result.size := LLen;
  Result.Write(pbyte(LData.FValue)^, LLen);
  Result.Position := 0;
end;

function TData.GetV(const AKey: str): Variant;
var
  LPByte: pbyte;
  LLen: int;
  LData: TData;
begin
  LData := Path(AKey);
  LLen := length(LData.FValue);
  Result := VarArrayCreate([0, LLen - 1], varByte);
  LPByte := VarArrayLock(Result);
  try
    Move(pbyte(LData.FValue)^, LPByte^, LLen);
  finally
    VarArrayUnlock(Result);
  end;
end;

function TData.GetWord(const AKey: str): Word;
var
  LData: TData;
begin
  LData := Path(AKey);
  Result := pbyte(LData.FValue)^;
end;

procedure TData.SetB(const AKey: str; const AValue: bool);
var
  LData: TData;
begin
  LData := Path(AKey);
  SetLength(LData.FValue, SizeOf(bool));
  Pbool(LData.FValue)^ := AValue;
end;

procedure TData.SetBT(const AKey: str; const AValue: TBytes);
var
  LData: TData;
  LLen: int;
begin
  LLen := length(AValue);
  LData := Path(AKey);
  SetLength(LData.FValue, LLen);
  Move(pbyte(AValue)^, pbyte(LData.FValue)^, LLen);
end;

procedure TData.SetByte(const AKey: str; const AValue: byte);
var
  LData: TData;
begin
  LData := Path(AKey);
  SetLength(LData.FValue, 1);
  pbyte(LData.FValue)^ := AValue;
end;

procedure TData.SetC(const AKey: str; const AValue: Currency);
var
  LData: TData;
begin
  LData := Path(AKey);
  SetLength(LData.FValue, SizeOf(Currency));
  PCurrency(LData.FValue)^ := AValue;
end;

procedure TData.SetCardinal(const AKey: str; const AValue: Cardinal);
var
  LData: TData;
begin
  LData := Path(AKey);
  SetLength(LData.FValue, 4);
  PCardinal(LData.FValue)^ := AValue;
end;

procedure TData.SetD(const AKey: str; const AValue: Double);
var
  LData: TData;
begin
  LData := Path(AKey);
  SetLength(LData.FValue, SizeOf(Double));
  PDouble(LData.FValue)^ := AValue;
end;

procedure TData.SetDT(const AKey: str; const AValue: TDateTime);
var
  LData: TData;
begin
  LData := Path(AKey);
  SetLength(LData.FValue, SizeOf(TDateTime));
  PDateTime(LData.FValue)^ := AValue;
end;

procedure TData.SetI(const AKey: str; const AValue: integer);
var
  LData: TData;
begin
  LData := Path(AKey);
  SetLength(LData.FValue, SizeOf(int));
  PInteger(LData.FValue)^ := AValue;
end;

procedure TData.SetI64(const AKey: str; const AValue: Int64);
var
  LData: TData;
begin
  LData := Path(AKey);
  SetLength(LData.FValue, SizeOf(Int64));
  PInt64(LData.FValue)^ := AValue;
end;

procedure TData.SetS(const AKey, AValue: str);
var
  LLen: int;
  LData: TData;
begin
  LData := Path(AKey);
  LLen := length(AValue);
  SetLength(LData.FValue, LLen);
  if LLen > 0 then
    Move(Pstr(AValue)^, pbyte(LData.FValue)^, LLen);
end;

procedure TData.SetST(const AKey: str; const AValue: TStream);
var
  LData: TData;
begin
  LData := Path(AKey);
  SetLength(LData.FValue, AValue.size);
  AValue.Position := 0;
  AValue.Read(pbyte(LData.FValue)^, AValue.size);
  AValue.Position := 0;
end;

procedure TData.SetV(const AKey: str; const AValue: Variant);
var
  LPByte: pbyte;
  LLen: int;
  LData: TData;
begin
  LData := Path(AKey);
  LLen := VarArrayHighBound(AValue, 1) - VarArrayLowBound(AValue, 1) + 1;
  LPByte := VarArrayLock(AValue);
  try
    SetLength(LData.FValue, LLen);
    Move(LPByte^, pbyte(LData.FValue)^, LLen);
  finally
    VarArrayUnlock(AValue);
  end;
end;

procedure TData.SetWord(const AKey: str; const AValue: Word);
var
  LData: TData;
begin
  LData := Path(AKey);
  SetLength(LData.FValue, 2);
  PWord(LData.FValue)^ := AValue;
end;

function TData.ToBytes: TBytes;
var
  I, LLen, LPos: int;
begin
  SetLength(Result, GetByteCount);
  LPos := 0;
  for I := 0 to FList.Count - 1 do
  begin
    LLen := length(TData(FList[I]).FKey);
    Move(LLen, Result[LPos], SizeOf(int));
    LPos := LPos + SizeOf(int);
    Move(Pstr(TData(FList[I]).FKey)^, Result[LPos], LLen);
    LPos := LPos + LLen;
    LLen := length(TData(FList[I]).FValue);
    Move(LLen, Result[LPos], SizeOf(int));
    LPos := LPos + SizeOf(int);
    Move(pbyte(TData(FList[I]).FValue)^, Result[LPos], LLen);
    LPos := LPos + LLen;
  end;
end;

function TData.ToRaw: str;
var
  I, LLen, LPos: int;
begin
  SetLength(Result, GetByteCount);
  LPos := 1;
  for I := 0 to FList.Count - 1 do
  begin
    LLen := length(TData(FList[I]).FKey);
    Move(LLen, Result[LPos], SizeOf(int));
    LPos := LPos + SizeOf(int);
    Move(Pstr(TData(FList[I]).FKey)^, Result[LPos], LLen);
    LPos := LPos + LLen;
    LLen := length(TData(FList[I]).FValue);
    Move(LLen, Result[LPos], SizeOf(int));
    LPos := LPos + SizeOf(int);
    Move(pbyte(TData(FList[I]).FValue)^, Result[LPos], LLen);
    LPos := LPos + LLen;
  end;
end;

procedure TData.ToStream(AStream: TStream);
var
  I, LLen: int;
begin
  AStream.Position := 0;
  for I := 0 to FList.Count - 1 do
  begin
    LLen := length(TData(FList[I]).FKey);
    AStream.Write(LLen, SizeOf(int));
    AStream.Write(Pstr(TData(FList[I]).FKey)^, LLen);
    LLen := length(TData(FList[I]).FValue);
    AStream.Write(LLen, SizeOf(int));
    AStream.Write(pbyte(TData(FList[I]).FValue)^, LLen);
  end;
  AStream.Position := 0;
end;

{ TMemPool }

constructor TMemPool.Create(APoolSize: Integer);
begin
  FList := TList.Create;
  CS := TCriticalSection.Create;
  Self.FPoolSize := APoolSize;
  Self.Init;
end;

destructor TMemPool.Destroy;
begin
  FList.Clear;
  FreeAndNil(FList);
  FreeAndNil(CS);
  inherited Destroy;
end;

procedure TMemPool.Init;
begin
  while FList.Count < Self.FPoolSize do
    FList.Add(NewObject);
end;

function TMemPool.Lock: TMemoryStream;
begin
  CS.Enter;
  try
    if FList.Count > 0 then
    begin
      Result := TMemoryStream(FList.First);
      FList.Remove(Result);
    end
    else
    begin
      FList.Add(NewObject);
      Result := TMemoryStream(FList.First);
      FList.Remove(Result);
    end;
  finally
    cs.Leave;
  end;
end;

function TMemPool.NewObject: TMemoryStream;
begin
  Result := TMemoryStream.Create;
end;

procedure TMemPool.Unlock(AValue: TMemoryStream);
begin
  AValue.Clear;   //free memory
  FList.Add(AValue);
end;

initialization
  MemPool := TMemPool.Create(1000);

end.