unit core.recordModel;
// cxg 2026 delphi2010+
interface

uses
  Classes, Rtti, Generics.Collections,
  SysUtils, JSON, json.Serializers;

type
  ByteStr = RawByteString;
  PByteStr = PRawByteString;

type
  // record<-->json(binary)
  TRecordSerial<T> = record
  public
    // json-->record
    class procedure UnJson(const AJson: UTF8String; var AResult: T); static;
    // record-->json
    class procedure Json(const ARecord: T; var AResult: UTF8String); static;
    //record-->binary
    class procedure Bytes(const ARecord: T; var AResult: TBytes); static;
    class procedure ByteStr(const ARecord: T; var AResult: ByteStr); static;
    class procedure Stream(const ARecord: T; var AResult: TStream); static;
    //binary-->record
    class procedure UnBytes(const ABytes: TBytes; var AResult: T); static;
    class procedure UnBytestr(const AByteStr: ByteStr; var AResult: T); static;
    class procedure UnStream(const AStream: TStream; var AResult: T); static;
  end;

type
  TTableAttr = class(TCustomAttribute)  //表注解
    FTableName: string;            //表名
    FKeyFields: string;            //主键
  public
    constructor Create(ATableName, AKeyFields: string);
  end;

type
  TFieldAttr = class(TCustomAttribute)  //字段注解
    FFieldName: string;            //字段名
    FTitle: string;                //标题
  public
    constructor Create(AFieldName, ATitle: string);
  end;

type
  // Generate transaction SQL from a record
  TRecordCrud<T> = record
  private
    FRttiContext: TRttiContext;
    FRttiFields: TArray<TRttiField>;
    FTableAttr: TTableAttr;
    FFields: string;
    FTableName: string;  //table name
    FKeyFields: string;  //Primary keys
  public
    function SelectSQL(const ARecord: T): string;
    function InsertSQL(const ARecord: T): string;
    function DeleteSQL(const ARecord: T): string;
    function UpdateSQL(const ARecord: T): string;
  public
    procedure Create;
    procedure Free;
  private
    function ProcessValue(const ARttiField: TRttiField; const ARecord: T): string;
  end;

  TJsonSerializerPool = record
  private
    FList: TList<TJsonSerializer>;
    FLock: TObject;
    FPoolSize: integer;
  private
    procedure Init;
    function NewObject: TJsonSerializer;
  public
    procedure Create(APoolSize: integer);
    procedure Free;
  public
    // get a object from pool
    function Lock: TJsonSerializer;
    // return a object to the pool
    procedure Unlock(AValue: TJsonSerializer);
  end;

var JsonSerializerPool: TJsonSerializerPool;

implementation

{ TRecordSerial<T> }

class procedure TRecordSerial<T>.Json(const ARecord: T; var AResult: UTF8String);
begin
  if @ARecord = nil then Exit;
  var LJsonSerializer: TJsonSerializer := JsonSerializerPool.Lock;
  try
    AResult := UTF8Encode(LJsonSerializer.Serialize<T>(ARecord));
  finally
    JsonSerializerPool.Unlock(LJsonSerializer);
  end;
end;

class procedure TRecordSerial<T>.Stream(const ARecord: T; var AResult: TStream);
begin
  if @ARecord = nil then Exit;
  if AResult = nil then
    AResult := TMemoryStream.Create;
  AResult.Write(ARecord, SizeOf(ARecord));
  AResult.Position := 0;
end;

class procedure TRecordSerial<T>.Bytes(const ARecord: T; var AResult: TBytes);
var len: Integer;
begin
  if @ARecord = nil then Exit;
  len := SizeOf(ARecord);
  SetLength(AResult, len);
  Move(ARecord,  PByte(AResult)^, len);
end;

class procedure TRecordSerial<T>.ByteStr(const ARecord: T; var AResult: RawByteString);
var len: Integer;
begin
  if @ARecord = nil then Exit;
  len := SizeOf(ARecord);
  SetLength(AResult, len);
  Move(ARecord, PByteStr(AResult)^, len);
end;

class procedure TRecordSerial<T>.UnJson(const AJson: UTF8String; var AResult: T);
begin
  if AJson = '' then
    Exit;
  var LJsonSerializer: TJsonSerializer := JsonSerializerPool.Lock;
  try
    AResult := LJsonSerializer.Deserialize<T>(string(AJson));
  finally
    JsonSerializerPool.Unlock(LJsonSerializer);
  end;
end;

class procedure TRecordSerial<T>.UnStream(const AStream: TStream; var AResult: T);
begin
  if AStream = nil then Exit;
  AStream.Read(AResult, AStream.Size);
end;

class procedure TRecordSerial<T>.UnBytes(const ABytes: TBytes; var AResult: T);
var len: Integer;
begin
  len := Length(ABytes);
  if len = 0 then Exit;
  Move(PByte(ABytes)^, AResult, len);
end;

class procedure TRecordSerial<T>.UnByteStr(const AByteStr: RawByteString; var AResult: T);
var len: Integer;
begin
  len := Length(AByteStr);
  if len = 0 then Exit;
  Move(PByteStr(AByteStr)^, AResult, len);
end;

{ TRecordCrud<T> }

procedure TRecordCrud<T>.Create;
var
  LRttiType: TRttiType;
  LRttiField: TRttiField;
  LFieldAttr: TFieldAttr;
begin
  FRttiContext := TRttiContext.Create;
  LRttiType := FRttiContext.GetType(TypeInfo(T));
  FRttiFields := LRttiType.GetFields;
  FTableAttr := LRttiType.GetAttribute<TTableAttr>;
  FTableName := FTableAttr.FTableName;
  FKeyFields := FTableAttr.FKeyFields;
  FFields := '';
  for LRttiField in FRttiFields do
  begin
    LFieldAttr := LRttiField.GetAttribute<TFieldAttr>;
    FFields := FFields + ',' + LFieldAttr.FFieldName;
  end;
  System.Delete(FFields, 1, 1);
end;

function TRecordCrud<T>.DeleteSQL(const ARecord: T): string;
var
  LRttiField: TRttiField;
  LWhere, LValue: string;
  LFieldAttr: TFieldAttr;
begin
  if @ARecord = nil then
    Exit;
  LValue := '';
  LWhere := '';
  for LRttiField in FRttiFields do
  begin
    LFieldAttr := LRttiField.GetAttribute<TFieldAttr>;
    if Pos(LFieldAttr.FFieldName, FKeyFields) = 0 then //Only primary keys can be used as WHERE conditions
      Continue;
    LValue := ProcessValue(LRttiField, ARecord);
    LWhere := LWhere + ' and ' + LFieldAttr.FFieldName + '=' + LValue;
  end;
  System.Delete(LWhere, 1, 5);
  Result := 'delete from ' + FTableName + ' where ' + LWhere;
end;

procedure TRecordCrud<T>.Free;
begin
  FRttiContext.Free;
end;

function TRecordCrud<T>.InsertSQL(const ARecord: T): string;
var
  LRttiField: TRttiField;
  LValues, LValue: string;
begin
  if @ARecord = nil then
    Exit;
  LValues := '';
  LValue := '';
  for LRttiField in FRttiFields do
  begin
    LValue := ProcessValue(LRttiField, ARecord);
    LValues := LValues + ',' + LValue;
  end;
  System.Delete(LValues, 1, 1);
  Result := 'insert into ' + FTableName + ' (' + FFields + ') values (' +
    LValues + ')';
end;

function TRecordCrud<T>.ProcessValue(const ARttiField: TRttiField; const ARecord: T): string;
begin
  if (@ARecord = nil) or (ARttiField = nil) then
    Exit;
  //TDateTime convert to string
  if SameText(ARttiField.FieldType.ToString, 'TDateTime') then
    Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', ARttiField.GetValue(@ARecord).AsType<TDateTime>)
  else if SameText(ARttiField.FieldType.ToString, 'TDate') then
    Result := FormatDateTime('yyyy-mm-dd', ARttiField.GetValue(@ARecord).AsType<TDate>)
  else if SameText(ARttiField.FieldType.ToString, 'TTime') then
    Result := FormatDateTime('hh:nn:ss', ARttiField.GetValue(@ARecord).AsType<TTime>)
  else
    Result := ARttiField.GetValue(@ARecord).ToString;
  //QuotedStr() process sql-string
  if SameText(ARttiField.FieldType.ToString, 'string') or
    SameText('UTF8String', ARttiField.FieldType.ToString) or
    SameText(ARttiField.FieldType.ToString, 'TDateTime') or
    SameText(ARttiField.FieldType.ToString, 'TDate') or
    SameText(ARttiField.FieldType.ToString, 'TTime') then
    Result := QuotedStr(Result);
end;

function TRecordCrud<T>.SelectSQL(const ARecord: T): string;
begin
  if @ARecord = nil then
    Exit;
  Result := 'select ' + FFields + ' from ' + FTableName;
end;

function TRecordCrud<T>.UpdateSQL(const ARecord: T): string;
var
  LRttiField: TRttiField;
  LWhere, LValue, LSet: string;
  LFieldAttr: TFieldAttr;
begin
  if @ARecord = nil then
    Exit;
  LValue := '';
  LWhere := '';
  LSet := '';
  for LRttiField in FRttiFields do
  begin
    LValue := ProcessValue(LRttiField, ARecord);
    LFieldAttr := LRttiField.GetAttribute<TFieldAttr>;
    LSet := LSet + ',' + LFieldAttr.FFieldName + '=' + LValue;
    if Pos(LFieldAttr.FFieldName, FKeyFields) = 0 then //Only primary keys can be used as WHERE conditions
      Continue;
    LWhere := LWhere + ' and ' + LFieldAttr.FFieldName + '=' + LValue;
  end;
  System.Delete(LWhere, 1, 5);
  System.Delete(LSet, 1, 1);
  Result := 'update ' + FTableName + ' set ' + LSet + ' where ' + LWhere;
end;

{ TJsonSerializerPool }

procedure TJsonSerializerPool.Create(APoolSize: integer);
begin
  FList := TList<TJsonSerializer>.Create;
  FLock := TObject.Create;
  Self.FPoolSize := APoolSize;
  Self.Init;
end;

procedure TJsonSerializerPool.Free;
var i: Integer;
begin
  for i := FList.Count - 1 to 0 do
  begin
    FList[i].Free;
    FList.Delete(i);
  end;
  FList.Free;
  FLock.Free;
end;

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

function TJsonSerializerPool.Lock: TJsonSerializer;
begin
  TMonitor.Enter(FLock);
  try
    if FList.Count > 0 then
    begin
      Result := FList.Last;
      FList.Delete(FList.Count - 1);
    end
    else
      Result := NewObject;
  finally
    TMonitor.Exit(FLock);
  end;
end;

function TJsonSerializerPool.NewObject: TJsonSerializer;
begin
  Result := TJsonSerializer.Create;
end;

procedure TJsonSerializerPool.Unlock(AValue: TJsonSerializer);
begin
  if not Assigned(AValue) then
    Exit;
  TMonitor.Enter(FLock);
  try
    FList.Add(AValue);
  finally
    TMonitor.Exit(FLock);
  end;
end;

{ TTableAttr }

constructor TTableAttr.Create(ATableName, AKeyFields: string);
begin
  FTableName := ATableName;
  FKeyFields := AKeyFields;
end;

{ TFieldAttr }

constructor TFieldAttr.Create(AFieldName, ATitle: string);
begin
  FFieldName := AFieldName;
  FTitle := ATitle;
end;

initialization
  JsonSerializerPool.Create(1);

end.

unit Unit1;

interface

uses  core.recordModel,
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    Button7: TButton;
    Button8: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

type
  //定义数据模型
  [TTableAttr('table1', 'field1')]
  TTest = record
    [TFieldAttr('field1', '字段一')]
    str: UTF8String;
  end;

procedure TForm1.Button1Click(Sender: TObject);
//json序列TArray<record>
begin
  var ts: TArray<TTest>;
  SetLength(ts, 2);
  ts[1].str := '中国';
  var s: UTF8String;
  TRecordSerial<TArray<TTest>>.json(ts, s); //序列
  Memo1.Text := s; //[{"str":""},{"str":"中国"}]
  ShowMessage(Length(s).ToString);   //29 bytes
  var t2: TArray<TTest>;
  TRecordSerial<TArray<TTest>>.unjson(s, t2); //还原
  ShowMessage(t2[1].str); //中国
end;

procedure TForm1.Button2Click(Sender: TObject);
//json序列record
begin
  var t: TTest;
  t.str := '中国';
  var s: UTF8String;
  TRecordSerial<TTest>.json(t, s);  //序列
  Memo1.Text := s;  //{"str":"中国"}

  var t2: TTest;
  TRecordSerial<TTest>.unjson(s, t2); //还原
  ShowMessage(t2.str); //中国
end;

procedure TForm1.Button3Click(Sender: TObject);
//二进制序列TArray<record>
begin
  var ts: TArray<TTest>;
  SetLength(ts, 2);
  ts[1].str := '中国';
  var s: TBytes;
  TRecordSerial<TArray<TTest>>.bytes(ts, s); //序列
  ShowMessage(Length(s).ToString); //4 bytes

  var t2: TArray<TTest>;
  TRecordSerial<TArray<TTest>>.unbytes(s, t2); //还原
  ShowMessage(t2[1].str);
end;

procedure TForm1.Button4Click(Sender: TObject);
//二进制序列record
begin
  var ts: TTest;
  ts.str := '中国';
  var s: TBytes;
  TRecordSerial<TTest>.bytes(ts, s); //序列

  var t2: TTest;
  TRecordSerial<TTest>.unbytes(s, t2); //还原
  ShowMessage(t2.str);
end;

procedure TForm1.Button5Click(Sender: TObject);
//select
begin
  var t: TTest;
  t.str := '中国';
  var crud: TRecordCrud<TTest>;
  crud.Create;
  Memo1.Text := crud.SelectSQL(t);  //select field1 from table1
  crud.Free;
end;

procedure TForm1.Button6Click(Sender: TObject);
//insert
begin
  var t: TTest;
  t.str := '中国';
  var crud: TRecordCrud<TTest>;
  crud.Create;
  Memo1.Text := crud.InsertSQL(t);  //insert into table1 (field1) values ('中国')
  crud.Free;
end;

procedure TForm1.Button7Click(Sender: TObject);
//update
begin
  var t: TTest;
  t.str := '中国';
  var crud: TRecordCrud<TTest>;
  crud.Create;
  Memo1.Text := crud.UpdateSQL(t);  //update table1 set field1='中国' where set field1='中国'
  crud.Free;
end;

procedure TForm1.Button8Click(Sender: TObject);
//update
begin
  var t: TTest;
  t.str := '中国';
  var crud: TRecordCrud<TTest>;
  crud.Create;
  Memo1.Text := crud.DeleteSQL(t);  //delete from table1 where field1='中国'
  crud.Free;
end;

end.