Project1.dpr

program Project1;
{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64 OWNNORMTOUPPER
{$IFOPT D+} {$DEFINE DEBUG} {$ENDIF}
{$ASSERTIONS ON}

{$APPTYPE CONSOLE}

uses
  SysUtils, Classes,
  SynCommons, SynLog, SynCrypto, mORMot;

type
{$M+}

  // Exactly the same as in SynCommons.pas
  TSynPersistent = class(TObject)
  protected
    procedure AssignTo(Dest: TSynPersistent); virtual;
    procedure AssignError(Source: TSynPersistent);
  public
    constructor Create; virtual;
    procedure Assign(Source: TSynPersistent); virtual;
    {$ifndef FPC_OR_PUREPASCAL}
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
    {$endif}
  end;

//  TSample = class(TPersistent) // Does not work
  TSample = class(TSynPersistent) // Does not work
//  TSample = class(SynCommons.TSynPersistent) // Works
  private
    FContent: TStrings;
  published
    property Content: TStrings read FContent;
  public
//    constructor Create; // if inherits from TPersistent
    constructor Create; override; // if inherits from TSynPersistent or SynCommons.TSynPersistent
    destructor Destroy; override;

  end;

{ TSynPersistent }

constructor TSynPersistent.Create;
begin // nothing to do by default - overridden constructor may add custom code
end;

procedure TSynPersistent.AssignError(Source: TSynPersistent);
var SourceName: string;
begin
  if Source <> nil then
    SourceName := Source.ClassName else
    SourceName := 'nil';
  raise EConvertError.CreateFmt('Cannot assign a %s to a %s', [SourceName, ClassName]);
end;

procedure TSynPersistent.AssignTo(Dest: TSynPersistent);
begin
  Dest.AssignError(Self);
end;

procedure TSynPersistent.Assign(Source: TSynPersistent);
begin
  if Source<>nil then
    Source.AssignTo(Self) else
    AssignError(nil);
end;


{$ifndef FPC_OR_PUREPASCAL}

class function TSynPersistent.NewInstance: TObject;
asm
        push    eax  // class
        mov     eax, [eax].vmtInstanceSize
        push    eax  // size
        call    System.@GetMem
        pop     edx   // size
        push    eax  // self
        mov     cl, 0
        call    dword ptr[FillcharFast]
        pop     eax   // self
        pop     edx   // class
        mov     [eax], edx // store VMT
end; // TSynPersistent has no interface -> bypass vmtIntfTable

procedure TSynPersistent.FreeInstance;
asm
        push    ebx
        mov     ebx, eax
@loop:  mov     ebx, [ebx] // handle three VMT levels per iteration
        mov     edx, [ebx].vmtInitTable
        mov     ebx, [ebx].vmtParent
        test    edx, edx
        jnz     @clr
        test    ebx, ebx
        jz      @end
        mov     ebx, [ebx]
        mov     edx, [ebx].vmtInitTable
        mov     ebx, [ebx].vmtParent
        test    edx, edx
        jnz     @clr
        test    ebx, ebx
        jz      @end
        mov     ebx, [ebx]
        mov     edx, [ebx].vmtInitTable
        mov     ebx, [ebx].vmtParent
        test    edx, edx
        jnz     @clr
        test    ebx, ebx
        jnz     @loop
@end:   pop     ebx
        jmp     System.@FreeMem
        // TSynPersistent has no TMonitor -> bypass TMonitor.Destroy(self)
        // BTW, TMonitor.Destroy is private, so unreachable
@clr:   push    offset @loop // parent has never any vmtInitTable -> @loop
        jmp     RecordClear // eax=self edx=typeinfo
end;

{$endif FPC_OR_PUREPASCAL}

{ TSample }

constructor TSample.Create;
begin
  inherited Create;
  FContent := TStringList.Create;
  FContent.Add('line 1 of 2');
  FContent.Add('line 2 of 2');
end;

destructor TSample.Destroy;
begin
  FContent.Free;
  inherited Destroy;
end;

var
  WriterOptions: TTextWriterWriteObjectOptions;
  Sample: TSample;
  JsonContentRaw: RawByteString;
  JsonContentUTF8: RawUTF8;
  JsonContentUTF8Buf: PUTF8Char;
  JsonContentValid: Boolean;
begin
  try
    TJSONSerializer.RegisterClassForJSON([TSynPersistent, TSample]);

    WriterOptions := [
      woHumanReadable
//      , woFullExpand
      , woStoreClassName
//      , woHumanReadableFullSetsAsStar
//      , woHumanReadableEnumSetAsComment
    ];

    Sample := TSample.Create;
    Sample.Content.Add('new line 3');
    SynCommons.FileFromString(ObjectToJSON(Sample, WriterOptions), ChangeFileExt(ParamStr(0), '.Sample.json'));
    FreeAndNil(Sample);

    JsonContentRaw := SynCommons.StringFromFile(ChangeFileExt(ParamStr(0), '.Sample.json'));
    JsonContentUTF8 := CurrentAnsiConvert.AnsiToUTF8(JsonContentRaw);
    JsonContentUTF8Buf := @JsonContentUTF8[1];
    Sample := JSONToNewObject(JsonContentUTF8Buf, JsonContentValid) as TSample;
    Writeln(Format('%s', [BoolToStr(JsonContentValid, True)]));
    if JsonContentValid then
    begin
      Writeln(Format('%s', [Sample.ClassName]));
      Writeln(Format('%s', [Sample.Content.Text]));
    end;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.