mORMot and Open Source friends
Check-in [9408c0ea83]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:{2697} Linux 64, ARM 32 and ARM 64 support patch by ALF, using FPC compiler - merged from https://github.com/LongDirtyAnimAlf/mORMot - we tested only against regression with Delphi Win32/Win64, so it is still a work in progress, but ORM and SOA have been reported to work as expected on those new targets - thanks a lot Alfred for sharing such valuable code!
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 9408c0ea832c5662af9895559f7c90eafdba613c
User & Date: ab 2016-05-28 15:39:17
Context
2016-05-29
10:39
{2698} enhanced TAESPRNG.GetEntropy to gather from more sources (including Intel's RdRand opcode, if available) check-in: a22528b5e8 user: ab tags: trunk
2016-05-28
15:39
{2697} Linux 64, ARM 32 and ARM 64 support patch by ALF, using FPC compiler - merged from https://github.com/LongDirtyAnimAlf/mORMot - we tested only against regression with Delphi Win32/Win64, so it is still a work in progress, but ORM and SOA have been reported to work as expected on those new targets - thanks a lot Alfred for sharing such valuable code! check-in: 9408c0ea83 user: ab tags: trunk
11:07
{2696} TAESPRNG.GetEntropy will use NIST SP 800-90A compliant RDRAND Intel x86/x64 opcode (if available) check-in: 6348a14d82 user: ab tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to SQLite3/DDD/infra/dddInfraApps.pas.

591
592
593
594
595
596
597

598

599
600
601
602
603
604

605

606
607
608
609
610
611
612
613
614

615

616
617
618
619
620
621
622
623

624

625
626
627
628
629
630
631
...
733
734
735
736
737
738
739

740
741
742
743
744
745

746
747
748
749
750
751
752
....
1766
1767
1768
1769
1770
1771
1772

1773

1774
1775
1776
1777
1778
1779
1780
  inherited;
end;

{$ifdef MSWINDOWS} // to support Windows Services

procedure TDDDDaemon.DoStart(Sender: TService);
begin

  SQLite3Log.Enter('DoStart %',[fSettings.ServiceName],self);

  fDaemon := NewDaemon;
  fDaemon.Start;
end;

procedure TDDDDaemon.DoStop(Sender: TService);
begin

  SQLite3Log.Enter('DoStop %',[fSettings.ServiceName],self);

  fDaemon := nil; // will stop the daemon
end;

{$endif MSWINDOWS} // to support Windows Services

function TDDDDaemon.NewDaemon: TDDDAdministratedDaemon;
begin
  if Assigned(fSettings) then 
    if fSettings.Log.LowLevelWebSocketsFrames then begin

      WebSocketLog := SQLite3Log;

      HttpServerFullWebSocketsLog := true;
      HttpClientFullWebSocketsLog := true;
    end;
  result := nil;
end;

procedure TDDDDaemon.Execute;
begin

  SQLite3Log.Enter(self);

  fDaemon := NewDaemon;
  fDaemon.Start;
end;

type
  TExecuteCommandLineCmd = (cNone, cInstall, cUninstall, cStart, cStop, cState,
    cVersion, cVerbose, cHelp, cConsole, cDaemon);
................................................................................
          TextColor(ccCyan);
          writeln(#10'Powered by Synopse mORMot ' + SYNOPSE_FRAMEWORK_VERSION);
        end;
      cConsole, cDaemon, cVerbose:
        begin
          writeln('Launched in ', cmdText, ' mode'#10);
          TextColor(ccLightGray);

          case cmd of
            cConsole:
              SQLite3Log.Family.EchoToConsole := LOG_STACKTRACE + [sllDDDInfo];
            cVerbose:
              SQLite3Log.Family.EchoToConsole := LOG_VERBOSE;
          end;

          daemon := NewDaemon;
          try
            fDaemon := daemon;
            {$ifdef WITHLOG}
            if cmd = cDaemon then
              if (daemon.AdministrationServer = nil) or not ({$ifdef MSWINDOWS}
                daemon.AdministrationServer.ExportedAsMessageOrNamedPipe or {$endif}
................................................................................
    raise EDDDInfraException.Create('AdministratedDaemonServer(Settings=nil)');
  with Settings.RemoteAdmin do
    result := DaemonClass.Create(AuthUserName, AuthHashedPassword, AuthRootURI, AuthNamedPipeName);
  result.InternalSettings := Settings;
  if Settings.Storage is TDDDAppSettingsStorageFile then
    result.InternalSettingsFolder := ExtractFilePath(
      TDDDAppSettingsStorageFile(Settings.Storage).SettingsJsonFileName);

  result.Log.SynLog.Log(sllTrace, '%.Create(%)', [DaemonClass, Settings], result);

  with Settings.RemoteAdmin do
    if AuthHttp.BindPort <> '' then
      result.AdministrationHTTPServer := TSQLHttpServer.Create(
        result.AdministrationServer, AuthHttp);
end;

initialization






>

>






>

>









>

>








>

>







 







>






>







 







>

>







591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
...
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
....
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
  inherited;
end;

{$ifdef MSWINDOWS} // to support Windows Services

procedure TDDDDaemon.DoStart(Sender: TService);
begin
  {$ifdef WITHLOG}
  SQLite3Log.Enter('DoStart %',[fSettings.ServiceName],self);
  {$endif}
  fDaemon := NewDaemon;
  fDaemon.Start;
end;

procedure TDDDDaemon.DoStop(Sender: TService);
begin
  {$ifdef WITHLOG}
  SQLite3Log.Enter('DoStop %',[fSettings.ServiceName],self);
  {$endif}
  fDaemon := nil; // will stop the daemon
end;

{$endif MSWINDOWS} // to support Windows Services

function TDDDDaemon.NewDaemon: TDDDAdministratedDaemon;
begin
  if Assigned(fSettings) then 
    if fSettings.Log.LowLevelWebSocketsFrames then begin
      {$ifdef WITHLOG}
      WebSocketLog := SQLite3Log;
      {$endif}
      HttpServerFullWebSocketsLog := true;
      HttpClientFullWebSocketsLog := true;
    end;
  result := nil;
end;

procedure TDDDDaemon.Execute;
begin
  {$ifdef WITHLOG}
  SQLite3Log.Enter(self);
  {$endif}
  fDaemon := NewDaemon;
  fDaemon.Start;
end;

type
  TExecuteCommandLineCmd = (cNone, cInstall, cUninstall, cStart, cStop, cState,
    cVersion, cVerbose, cHelp, cConsole, cDaemon);
................................................................................
          TextColor(ccCyan);
          writeln(#10'Powered by Synopse mORMot ' + SYNOPSE_FRAMEWORK_VERSION);
        end;
      cConsole, cDaemon, cVerbose:
        begin
          writeln('Launched in ', cmdText, ' mode'#10);
          TextColor(ccLightGray);
          {$ifdef WITHLOG}
          case cmd of
            cConsole:
              SQLite3Log.Family.EchoToConsole := LOG_STACKTRACE + [sllDDDInfo];
            cVerbose:
              SQLite3Log.Family.EchoToConsole := LOG_VERBOSE;
          end;
          {$endif}
          daemon := NewDaemon;
          try
            fDaemon := daemon;
            {$ifdef WITHLOG}
            if cmd = cDaemon then
              if (daemon.AdministrationServer = nil) or not ({$ifdef MSWINDOWS}
                daemon.AdministrationServer.ExportedAsMessageOrNamedPipe or {$endif}
................................................................................
    raise EDDDInfraException.Create('AdministratedDaemonServer(Settings=nil)');
  with Settings.RemoteAdmin do
    result := DaemonClass.Create(AuthUserName, AuthHashedPassword, AuthRootURI, AuthNamedPipeName);
  result.InternalSettings := Settings;
  if Settings.Storage is TDDDAppSettingsStorageFile then
    result.InternalSettingsFolder := ExtractFilePath(
      TDDDAppSettingsStorageFile(Settings.Storage).SettingsJsonFileName);
  {$ifdef WITHLOG}
  result.Log.SynLog.Log(sllTrace, '%.Create(%)', [DaemonClass, Settings], result);
  {$endif}
  with Settings.RemoteAdmin do
    if AuthHttp.BindPort <> '' then
      result.AdministrationHTTPServer := TSQLHttpServer.Create(
        result.AdministrationServer, AuthHttp);
end;

initialization

Changes to SQLite3/DDD/infra/dddInfraEmailer.pas.

518
519
520
521
522
523
524

525

526
527
528
529
530
531
532
    exit; }
  Email := RestClass.Create;
  try
    Email.Recipients := aRecipients;
    Email.Sender := aSender;
    Email.Subject := aSubject;
    Email.Headers := aHeaders;

    Rest.LogClass.Enter('SendEmail %',[Email],self);

    Email.MessageCompressed := SynLZCompressToBytes(aBody);
    CqrsBeginMethod(qaNone,result);
    if not Email.FilterAndValidate(Rest,msg) then
      CqrsSetResultString(cqrsDDDValidationFailed,msg) else
      if Rest.Add(Email,true)=0 then
        CqrsSetResult(cqrsDataLayerError) else
        CqrsSetResult(cqrsSuccess);






>

>







518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
    exit; }
  Email := RestClass.Create;
  try
    Email.Recipients := aRecipients;
    Email.Sender := aSender;
    Email.Subject := aSubject;
    Email.Headers := aHeaders;
    {$ifdef WITHLOG}
    Rest.LogClass.Enter('SendEmail %',[Email],self);
    {$endif}
    Email.MessageCompressed := SynLZCompressToBytes(aBody);
    CqrsBeginMethod(qaNone,result);
    if not Email.FilterAndValidate(Rest,msg) then
      CqrsSetResultString(cqrsDDDValidationFailed,msg) else
      if Rest.Add(Email,true)=0 then
        CqrsSetResult(cqrsDataLayerError) else
        CqrsSetResult(cqrsSuccess);

Changes to SQLite3/DDD/infra/dddInfraSettings.pas.

489
490
491
492
493
494
495

496
497
498
499
500
501
502
...
508
509
510
511
512
513
514

515
516
517
518
519
520
521
implementation

{ TDDDAppSettingsAbstract }

procedure TDDDAppSettingsAbstract.Initialize(const aDescription: string);
begin

  with SQLite3Log.Family do begin
    Level := Log.Levels-[sllNone]; // '*' would include sllNone
    if Log.ConsoleLevels<>[] then
      EchoToConsole := Log.ConsoleLevels-[sllNone];
    PerThreadLog := ptIdentifiedInOnFile;
    if Log.DestinationPath<>'' then
     DestinationPath := Log.DestinationPath;
................................................................................
    FileExistsAction := acAppend; // default rotation mode
    if Log.StackTraceViaAPI then
      StackTraceUse := stOnlyAPI;
    {$ifdef MSWINDOWS}
    AutoFlushTimeOut := Log.AutoFlushTimeOut;
    {$endif}
  end;

  if fDescription='' then
    fDescription := aDescription;
end;

procedure TDDDAppSettingsAbstract.SetProperties(Instance: TObject);
begin
  CopyObject(self,Instance);






>







 







>







489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
...
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
implementation

{ TDDDAppSettingsAbstract }

procedure TDDDAppSettingsAbstract.Initialize(const aDescription: string);
begin
  {$ifdef WITHLOG}
  with SQLite3Log.Family do begin
    Level := Log.Levels-[sllNone]; // '*' would include sllNone
    if Log.ConsoleLevels<>[] then
      EchoToConsole := Log.ConsoleLevels-[sllNone];
    PerThreadLog := ptIdentifiedInOnFile;
    if Log.DestinationPath<>'' then
     DestinationPath := Log.DestinationPath;
................................................................................
    FileExistsAction := acAppend; // default rotation mode
    if Log.StackTraceViaAPI then
      StackTraceUse := stOnlyAPI;
    {$ifdef MSWINDOWS}
    AutoFlushTimeOut := Log.AutoFlushTimeOut;
    {$endif}
  end;
  {$endif}
  if fDescription='' then
    fDescription := aDescription;
end;

procedure TDDDAppSettingsAbstract.SetProperties(Instance: TObject);
begin
  CopyObject(self,Instance);

Changes to SQLite3/Samples/06 - Remote JSON REST Service/Project06Client.dpr.

1
2
3
4
5



6
7

8

9
10
11
12
13
14
program Project06Client;

uses
  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  Forms,



  Project06ClientMain in 'Project06ClientMain.pas' {Form1};


{$R *.res}


begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.




>
>
>


>

>






1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
program Project06Client;

uses
  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  Forms,
  {$ifdef FPC}
  Interfaces,
  {$endif}
  Project06ClientMain in 'Project06ClientMain.pas' {Form1};

{$ifndef FPC}
{$R *.res}
{$endif FPC}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Changes to SQLite3/Samples/06 - Remote JSON REST Service/Project06ClientMain.pas.

30
31
32
33
34
35
36

37

38
39
40
41
42
43
44
var
  Form1: TForm1;

implementation

{$R *.dfm}


{$R Vista.res}


procedure TForm1.btnCancelClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.btnCallClick(Sender: TObject);






>

>







30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
var
  Form1: TForm1;

implementation

{$R *.dfm}

{$ifndef FPC}
{$R Vista.res}
{$endif FPC}

procedure TForm1.btnCancelClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.btnCallClick(Sender: TObject);

Changes to SQLite3/Samples/08 - TaskDialog/TaskDialogTest.dpr.

2
3
4
5
6
7
8
9



10


11
12
13

14
15
16
17
18
19
20
uses
  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  SysUtils,
  SynTaskDialog,
  mORMot,
  mORMotUILogin,
  Forms;






{$R *.res}

{$R Vista.res} // to enable XP/Vista/Seven theming


var
  MainCounter: integer;

type
  TCallBack = class
  public






|
>
>
>
|
>
>



>







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
uses
  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  SysUtils,
  SynTaskDialog,
  mORMot,
  mORMotUILogin,
  Forms
  {$ifdef FPC}
  ,Interfaces
  {$endif}
  ;

{$ifndef FPC}
{$R *.res}

{$R Vista.res} // to enable XP/Vista/Seven theming
{$endif}

var
  MainCounter: integer;

type
  TCallBack = class
  public

Changes to SQLite3/Samples/12 - SynDB Explorer/SynDBExplorer.dpr.

41
42
43
44
45
46
47



48
49
50
51
52
53
54
  first line of uses clause below must be {$I SynDprUses.inc} to enable FastMM4
  conditional define should contain INCLUDE_FTS3 to handle FTS3/FTS4 in SQLite3 
*)

uses
  {$I SynDprUses.inc}
  Forms,



  SynDBExplorerMain in 'SynDBExplorerMain.pas' {DbExplorerMain},
  SynDBExplorerClasses in 'SynDBExplorerClasses.pas',
  SynDBExplorerFrame in 'SynDBExplorerFrame.pas' {DBExplorerFrame: TFrame},
  SynDBExplorerQueryBuilder in 'SynDBExplorerQueryBuilder.pas' {DBQueryBuilderForm},
  SynDBExplorerExportTables in 'SynDBExplorerExportTables.pas' {DBExportTablesForm},
  SynDBExplorerServer in 'SynDBExplorerServer.pas' {HTTPServerForm};







>
>
>







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
  first line of uses clause below must be {$I SynDprUses.inc} to enable FastMM4
  conditional define should contain INCLUDE_FTS3 to handle FTS3/FTS4 in SQLite3 
*)

uses
  {$I SynDprUses.inc}
  Forms,
  {$ifdef FPC}
  Interfaces,
  {$endif}
  SynDBExplorerMain in 'SynDBExplorerMain.pas' {DbExplorerMain},
  SynDBExplorerClasses in 'SynDBExplorerClasses.pas',
  SynDBExplorerFrame in 'SynDBExplorerFrame.pas' {DBExplorerFrame: TFrame},
  SynDBExplorerQueryBuilder in 'SynDBExplorerQueryBuilder.pas' {DBQueryBuilderForm},
  SynDBExplorerExportTables in 'SynDBExplorerExportTables.pas' {DBExportTablesForm},
  SynDBExplorerServer in 'SynDBExplorerServer.pas' {HTTPServerForm};

Changes to SQLite3/Samples/12 - SynDB Explorer/SynDBExplorerMain.pas.

4
5
6
7
8
9
10
11


12

13
14
15
16
17
18
19
interface

{.$define USEZEOS}

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Grids, ExtCtrls, StdCtrls, Consts,


  {$ifdef HASINLINE}XPMan, Contnrs,{$endif}

  {$ifdef ISDELPHIXE}
  SynSQLite3RegEx, // use direct PCRE library as available since Delphi XE
  {$endif}
  SynCommons, SynZip, mORMot, SynSQLite3, SynSQLite3Static,
  mORMoti18n, mORMotUI, mORMotUIEdit, mORMotUILogin, mORMotToolBar,
  SynTaskDialog, // also fix QC 37403 for Delphi 6/7/2006
  SynDB, SynDBOracle, SynOleDB, SynDBSQLite3, SynDBODBC, SynDBRemote,






|
>
>

>







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
interface

{.$define USEZEOS}

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Grids, ExtCtrls, StdCtrls,
  {$ifndef FPC}
  Consts,
  {$ifdef HASINLINE}XPMan, Contnrs,{$endif}
  {$endif}
  {$ifdef ISDELPHIXE}
  SynSQLite3RegEx, // use direct PCRE library as available since Delphi XE
  {$endif}
  SynCommons, SynZip, mORMot, SynSQLite3, SynSQLite3Static,
  mORMoti18n, mORMotUI, mORMotUIEdit, mORMotUILogin, mORMotToolBar,
  SynTaskDialog, // also fix QC 37403 for Delphi 6/7/2006
  SynDB, SynDBOracle, SynOleDB, SynDBSQLite3, SynDBODBC, SynDBRemote,

Changes to SQLite3/Samples/14 - Interface based services/Project14Client.dpr.

1
2
3
4
5



6
7
8

9

10
11
12
13
14
15
program Project14Client;

uses
  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  Forms,



  Project14ClientMain in 'Project14ClientMain.pas' {Form1},
  Project14Interface in 'Project14Interface.pas';


{$R *.res}


begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.




>
>
>



>

>






1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
program Project14Client;

uses
  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  Forms,
  {$ifdef FPC}
  Interfaces,
  {$endif}
  Project14ClientMain in 'Project14ClientMain.pas' {Form1},
  Project14Interface in 'Project14Interface.pas';

{$ifndef FPC}
{$R *.res}
{$endif}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Changes to SQLite3/Samples/14 - Interface based services/Project14ClientMain.pas.

33
34
35
36
37
38
39

40

41
42
43
44
45
46
47
var
  Form1: TForm1;

implementation

{$R *.dfm}


{$R Vista.res}


procedure TForm1.btnCancelClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.btnCallClick(Sender: TObject);






>

>







33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
var
  Form1: TForm1;

implementation

{$R *.dfm}

{$ifndef FPC}
{$R Vista.res}
{$endif}

procedure TForm1.btnCancelClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.btnCallClick(Sender: TObject);

Changes to SQLite3/Samples/20 - DTO interface based service/Project20Client.dpr.

1
2
3
4
5
6



7
8
9

10

11
12
13
14
15
16
program Project20Client;

//   first line of uses clause must be   {$I SynDprUses.inc}
uses
  {$I SynDprUses.inc}
  Forms,



  Project20ClientMain in 'Project20ClientMain.pas' {Form1},
  Project20Interface in 'Project20Interface.pas';


{$R *.res}


begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.





>
>
>



>

>






1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
program Project20Client;

//   first line of uses clause must be   {$I SynDprUses.inc}
uses
  {$I SynDprUses.inc}
  Forms,
  {$ifdef FPC}
  Interfaces,
  {$endif}
  Project20ClientMain in 'Project20ClientMain.pas' {Form1},
  Project20Interface in 'Project20Interface.pas';

{$ifndef FPC}
{$R *.res}
{$endif}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Changes to SQLite3/Samples/20 - DTO interface based service/Project20ClientMain.pas.

34
35
36
37
38
39
40

41

42
43
44
45
46
47
48
var
  Form1: TForm1;

implementation

{$R *.dfm}


{$R Vista.res}


procedure TForm1.btnCancelClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.btnCallClick(Sender: TObject);






>

>







34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
var
  Form1: TForm1;

implementation

{$R *.dfm}

{$ifndef FPC}
{$R Vista.res}
{$endif}

procedure TForm1.btnCancelClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.btnCallClick(Sender: TObject);

Changes to SQLite3/Samples/26 - RESTful ORM/RESTClient.dpr.

1
2
3
4
5



6
7

8

9
10
11
12
13
14
program RESTClient;

uses
  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  Forms,



  RestClientMain in 'RestClientMain.pas' {MainForm};


{$R *.res}


begin
  Application.Initialize;
  Application.CreateForm(TMainForm, MainForm);
  Application.Run;
end.




>
>
>


>

>






1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
program RESTClient;

uses
  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  Forms,
  {$ifdef FPC}
  Interfaces,
  {$endif}
  RestClientMain in 'RestClientMain.pas' {MainForm};

{$ifndef FPC}
{$R *.res}
{$endif FPC}

begin
  Application.Initialize;
  Application.CreateForm(TMainForm, MainForm);
  Application.Run;
end.

Changes to SQLite3/Samples/30 - MVC Server/MVCServer.dpr.

1
2










3
4
5
6
7
8
9
/// MVC sample web application, publishing a simple BLOG
program MVCServer;











{$APPTYPE CONSOLE}

{$I Synopse.inc} // define HASINLINE WITHLOG USETHREADPOOL ONLYUSEHTTPSOCKET

uses
  {$I SynDprUses.inc}    // will enable FastMM4 prior to Delphi 2006

>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/// MVC sample web application, publishing a simple BLOG
program MVCServer;

{$ifdef Linux}
  {$ifdef FPC_CROSSCOMPILING}
    {$ifdef CPUARM}
      //if GUI, then uncomment
      //{$linklib GLESv2}
    {$endif}
    {$linklib libc_nonshared.a}
  {$endif}
{$endif}

{$APPTYPE CONSOLE}

{$I Synopse.inc} // define HASINLINE WITHLOG USETHREADPOOL ONLYUSEHTTPSOCKET

uses
  {$I SynDprUses.inc}    // will enable FastMM4 prior to Delphi 2006

Changes to SQLite3/Samples/31 - WebSockets/Project31ChatClient.dpr.

1
2


3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/// simple SOA client using callbacks for a chat room
program Project31LongWorkClient;



uses
  {$I SynDprUses.inc} // use FastMM4 on older versions of Delphi
  SysUtils,
  Classes,
  SynCommons,
  mORMot,
  mORMotHttpClient,
  Project31ChatCallbackInterface in 'Project31ChatCallbackInterface.pas';

{$APPTYPE CONSOLE}

type
  TChatCallback = class(TInterfacedCallback,IChatCallback)
  protected
    procedure NotifyBlaBla(const pseudo, msg: string);
  end;

procedure TChatCallback.NotifyBlaBla(const pseudo, msg: string);
|
>
>










<
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14


15
16
17
18
19
20
21
/// simple SOA client using callbacks for a chat room
program Project31ChatClient;

{$APPTYPE CONSOLE}

uses
  {$I SynDprUses.inc} // use FastMM4 on older versions of Delphi
  SysUtils,
  Classes,
  SynCommons,
  mORMot,
  mORMotHttpClient,
  Project31ChatCallbackInterface in 'Project31ChatCallbackInterface.pas';



type
  TChatCallback = class(TInterfacedCallback,IChatCallback)
  protected
    procedure NotifyBlaBla(const pseudo, msg: string);
  end;

procedure TChatCallback.NotifyBlaBla(const pseudo, msg: string);

Changes to SQLite3/Samples/31 - WebSockets/Project31ChatServer.dpr.

1
2
3


4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
/// simple SOA server using callbacks for a chat room
program Project31ChatServer;



uses
  {$I SynDprUses.inc} // use FastMM4 on older versions of Delphi
  SysUtils,
  Classes,
  SynCommons,
  SynLog,
  mORMot,
  SynBidirSock,
  mORMotHttpServer,
  Project31ChatCallbackInterface in 'Project31ChatCallbackInterface.pas';

{$APPTYPE CONSOLE}

type
  TChatService = class(TInterfacedObject,IChatService)
  protected
    fConnected: array of IChatCallback;
  public
    procedure Join(const pseudo: string; const callback: IChatCallback);
    procedure BlaBla(const pseudo,msg: string);


>
>











<
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16


17
18
19
20
21
22
23
/// simple SOA server using callbacks for a chat room
program Project31ChatServer;

{$APPTYPE CONSOLE}

uses
  {$I SynDprUses.inc} // use FastMM4 on older versions of Delphi
  SysUtils,
  Classes,
  SynCommons,
  SynLog,
  mORMot,
  SynBidirSock,
  mORMotHttpServer,
  Project31ChatCallbackInterface in 'Project31ChatCallbackInterface.pas';



type
  TChatService = class(TInterfacedObject,IChatService)
  protected
    fConnected: array of IChatCallback;
  public
    procedure Join(const pseudo: string; const callback: IChatCallback);
    procedure BlaBla(const pseudo,msg: string);

Changes to SQLite3/Samples/31 - WebSockets/Project31SimpleEchoServer.dpr.

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
  writeln(' from ',Sender.ServerSock.RemoteIP,'/',PtrInt(Sender.ServerSock.Sock));
end;

procedure Run;                   
var Server: TWebSocketServer;
    protocol: TWebSocketProtocolEcho;
begin
  Server := TWebSocketServer.Create('8888');
  try
    protocol := TWebSocketProtocolEcho.Create('meow','');
    protocol.OnIncomingFrame := protocol.EchoFrame;
    Server.WebSocketProtocols.Add(protocol);
    TextColor(ccLightGreen);
    writeln('WebSockets Chat Server running on localhost:8888'#13#10);
    TextColor(ccWhite);






|







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
  writeln(' from ',Sender.ServerSock.RemoteIP,'/',PtrInt(Sender.ServerSock.Sock));
end;

procedure Run;                   
var Server: TWebSocketServer;
    protocol: TWebSocketProtocolEcho;
begin
  Server := TWebSocketServer.Create('8888',nil,nil,'test');
  try
    protocol := TWebSocketProtocolEcho.Create('meow','');
    protocol.OnIncomingFrame := protocol.EchoFrame;
    Server.WebSocketProtocols.Add(protocol);
    TextColor(ccLightGreen);
    writeln('WebSockets Chat Server running on localhost:8888'#13#10);
    TextColor(ccWhite);

Changes to SQLite3/Samples/MainDemo/FileTables.pas.

200
201
202
203
204
205
206
207
208
begin
  result := TSQLModel.Create(Owner,
    @FileTabs,length(FileTabs),sizeof(FileTabs[0]),[],
    TypeInfo(TFileAction),TypeInfo(TFileEvent));
end;

initialization
  SetExecutableVersion(3,0,0);
end.






|

200
201
202
203
204
205
206
207
208
begin
  result := TSQLModel.Create(Owner,
    @FileTabs,length(FileTabs),sizeof(FileTabs[0]),[],
    TypeInfo(TFileAction),TypeInfo(TFileEvent));
end;

initialization
  SetExecutableVersion('3.1');
end.

Changes to SQLite3/mORMot.pas.

5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
....
9997
9998
9999
10000
10001
10002
10003
10004
10005
10006


10007






10008
10009
10010
10011
10012
10013
10014
.....
10326
10327
10328
10329
10330
10331
10332
10333
10334
10335
10336
10337
10338
10339
10340
.....
10341
10342
10343
10344
10345
10346
10347
10348
10349
10350
10351
10352
10353
10354
10355
.....
10735
10736
10737
10738
10739
10740
10741



10742
10743
10744
10745
10746
10747
10748
.....
11754
11755
11756
11757
11758
11759
11760
11761
11762
11763
11764
11765
11766
11767
11768
.....
23401
23402
23403
23404
23405
23406
23407




23408
23409
23410
23411
23412
23413
23414
.....
28174
28175
28176
28177
28178
28179
28180




28181
28182
28183
28184
28185
28186
28187
.....
28195
28196
28197
28198
28199
28200
28201




28202
28203
28204
28205
28206
28207
28208
.....
28465
28466
28467
28468
28469
28470
28471




28472


28473



28474
28475
28476




28477


28478



28479
28480
28481
28482
28483
28484
28485
28486
28487
28488
28489
28490
28491
28492
28493
28494
.....
28509
28510
28511
28512
28513
28514
28515




28516
28517
28518
28519
28520






28521

28522
28523
28524
28525
28526
28527
28528
.....
28533
28534
28535
28536
28537
28538
28539




28540
28541



28542
28543




28544
28545
28546




28547
28548
28549
28550







28551
28552
28553




28554
28555
28556





28557

28558
28559
28560

28561
28562
28563
28564
28565
28566
28567
28568
28569
28570
28571
28572
28573



28574

28575
28576
28577
28578
28579
28580



28581

28582
28583
28584
28585
28586
28587
28588
.....
30460
30461
30462
30463
30464
30465
30466



30467
30468
30469
30470
30471
30472
30473
.....
30901
30902
30903
30904
30905
30906
30907

30908
30909
30910
30911
30912
30913
30914
.....
36089
36090
36091
36092
36093
36094
36095












36096
36097

36098
36099
36100
36101
36102
36103
36104
.....
41597
41598
41599
41600
41601
41602
41603

41604

41605
41606
41607
41608
41609
41610
41611
.....
43252
43253
43254
43255
43256
43257
43258

43259
43260
43261
43262
43263
43264
43265
.....
46588
46589
46590
46591
46592
46593
46594
46595
46596
46597
46598
46599
46600
46601
46602
.....
47971
47972
47973
47974
47975
47976
47977

47978
47979
47980
47981
47982
47983
47984
.....
50207
50208
50209
50210
50211
50212
50213
50214
50215
50216








50217

50218
50219
50220
50221
50222
50223
50224

50225
50226
50227
50228
50229

50230
50231
50232
50233
50234
50235
50236
50237
50238
50239
50240
50241
50242
50243
50244
50245
50246
50247

50248
50249
50250
50251
50252
50253
50254
50255

50256
50257
50258
50259
50260
50261


50262




















50263
50264
























50265

50266
50267
50268
50269
50270
50271
50272
50273
50274
50275
50276
50277
50278
50279
50280
50281
50282
50283
50284
.....
50291
50292
50293
50294
50295
50296
50297
50298
50299
50300
50301

50302
50303

50304
50305
50306
50307


50308
50309
50310



50311
50312



50313
50314
50315
50316
50317
50318
50319
50320
50321
50322
50323








50324
50325
50326
50327
50328
50329
50330
.....
50391
50392
50393
50394
50395
50396
50397

50398
50399
50400

50401
50402
50403
50404
50405
50406
50407
.....
50421
50422
50423
50424
50425
50426
50427
50428
50429
50430
50431
50432
50433
50434
50435
.....
50439
50440
50441
50442
50443
50444
50445
50446
50447
50448
50449
50450
50451
50452
50453
50454
50455
50456
50457
.....
50475
50476
50477
50478
50479
50480
50481
50482
50483
50484
50485
50486
50487
50488
50489
50490
50491
50492
50493
50494
50495
50496
50497
50498
50499
50500
50501
50502
50503
50504
50505
50506
50507
50508
50509
50510
50511
50512
50513
50514
50515
.....
50654
50655
50656
50657
50658
50659
50660

50661









50662
50663
50664
50665
50666
50667
50668
50669
50670
50671
50672

50673
50674
50675
50676
50677
50678







50679
50680
50681
50682
50683
50684
50685
50686
50687
50688
.....
51034
51035
51036
51037
51038
51039
51040



51041
51042
51043
51044







51045
51046




51047
51048
51049
51050
51051
51052
51053
51054
51055
51056
51057
51058



51059
51060
51061
51062
51063
51064
51065
.....
51163
51164
51165
51166
51167
51168
51169


51170

51171




51172
51173
51174










51175
51176


51177
51178
51179
51180
51181
51182
51183
.....
51185
51186
51187
51188
51189
51190
51191
51192
51193
51194
51195
51196
51197
51198
51199
51200
51201
51202
.....
51219
51220
51221
51222
51223
51224
51225
51226
51227



51228













51229
51230
51231
51232
51233
51234
51235
51236
51237
51238
51239
51240
51241
51242
51243
51244
51245




51246
51247





51248
































51249

51250











51251
51252
51253
51254
51255
51256
51257
51258
51259
51260
51261
51262
51263
51264
.....
51375
51376
51377
51378
51379
51380
51381
51382




































































51383
51384
51385


51386
51387
51388
51389


51390
51391
51392
51393
51394



51395
51396




51397
51398
51399
51400
51401
51402






51403
51404
51405
51406
51407
51408
51409
51410
51411



51412
51413

51414
51415



51416
51417
51418
51419
51420
51421
51422
51423
51424
51425






























































































































51426
51427
51428
51429
51430
51431
51432
.....
51439
51440
51441
51442
51443
51444
51445




51446

51447
51448
51449


51450

51451
51452
51453
51454
51455
51456
51457
51458




51459
51460
51461
51462
51463
51464
51465
.....
51473
51474
51475
51476
51477
51478
51479
51480
51481
51482
51483
51484
51485
51486
51487
51488
51489
51490








51491

51492
51493
51494
51495
51496
51497
51498
51499
51500



























51501
51502
51503
51504
51505
51506
51507
51508
51509

51510
51511
51512
51513
51514
51515
51516
.....
51577
51578
51579
51580
51581
51582
51583

51584
51585
51586
51587
51588
51589
51590
51591
51592
51593
51594
51595
51596
51597
51598
51599
51600
51601
51602
51603
.....
53538
53539
53540
53541
53542
53543
53544



53545

53546
53547




53548
53549
53550
53551



53552
53553
53554
53555













































































53556
53557

53558







































































53559
53560

53561



53562





53563
53564
53565
53566
53567
53568
53569













53570
53571
53572
53573
53574
53575
53576
53577
53578
53579
53580
53581
53582
53583
53584
53585








53586
53587
53588
53589
53590
53591






53592
53593
53594
53595







53596

53597




53598
53599
53600
53601
53602
53603
53604
53605
53606
53607
53608
53609
53610
53611
53612
53613
53614
53615
53616
53617
53618
53619
53620
53621
53622
53623
53624
53625
53626
53627
53628
53629
53630
53631
53632
53633
53634
53635
53636
53637
53638
53639
53640

53641
53642
53643


53644
53645
53646
53647
53648
53649
53650
.....
53654
53655
53656
53657
53658
53659
53660
53661
53662
53663
53664
53665
53666
53667
53668
53669
53670
.....
53676
53677
53678
53679
53680
53681
53682
53683
53684
53685
53686
53687
53688
53689
53690
53691
.....
55492
55493
55494
55495
55496
55497
55498
55499
55500
55501
55502
55503
55504
55505

55506
55507

55508
55509




















55510
55511
55512
55513
55514
55515
55516
.....
55520
55521
55522
55523
55524
55525
55526
55527
55528
55529
55530

55531






55532
55533

55534

55535















55536
55537
55538
55539
55540
55541
55542
.....
55544
55545
55546
55547
55548
55549
55550

55551









55552
55553
55554
55555
55556
55557
55558
.....
55637
55638
55639
55640
55641
55642
55643
55644
55645
55646
55647
55648
55649
55650
55651
    ServiceMethodIndex: integer;
    /// the JSON array of parameters for an the interface-based service
    // - Service member has already be retrieved from URI (so is not nil)
    ServiceParameters: PUTF8Char;
    /// the instance ID for interface-based services instance
    // - can be e.g. the client session ID for sicPerSession or the thread ID for
    // sicPerThread
    ServiceInstanceID: cardinal;
    /// the current execution context of an interface-based service
    // - maps to Service.fExecution[ServiceMethodIndex]
    ServiceExecution: PServiceFactoryExecution;
    /// force the interface-based service methods to return a JSON object
    // - default behavior is to follow Service.ResultAsJSONObject property value
    // (which own default is to return a more convenient JSON array)
    // - if set to TRUE, this execution context will FORCE the method to return
................................................................................
    // - vIsInFPR is used for floating point constant arguments
    ValueKindAsm: set of (vIsString, vPassedByReference, vIsObjArray, vIsInFPR);
    /// byte offset in the CPU stack of this argument
    // - may be -1 if pure register parameter with no backup on stack (x86)
    InStackOffset: integer;
    /// used to specify if the argument is passed as register
    // - contains 0 if parameter is not a register
    // - contains 1 for EAX, 2 for EDX and 3 for ECX registers (for x86)
    // - contains 1 for RCX/XMM0L, 2 for RDX/XMM1L, 3 for R8/XMM2L, and
    // 4 for R9/XMM3L, with a backing store on the stack (for Win64)


    RegisterIdent: integer;






    /// size (in bytes) of this argument on the stack
    SizeInStack: integer;
    /// size (in bytes) of this smvv64 ordinal value
    // - e.g. depending of the associated kind of enumeration
    SizeInStorage: integer;
    /// index of the associated variable in the local array[ArgsUsedCount[]]
    // - for smdConst argument, contains -1 (no need to a local var: the value
................................................................................
    fServiceCustomAnswerHead: RawUTF8;
    fServiceCustomAnswerStatus: cardinal;
    fLastException: Exception;
    fInput: TDocVariantData;
    fOutput: TDocVariantData;
    fCurrentStep: TServiceMethodExecuteEventStep;
    procedure BeforeExecute;
    procedure RawExecute(Instances: PPointerArray; InstancesLast: integer);
    procedure AfterExecute;
  public
    /// initialize the execution instance
    constructor Create(aMethod: PServiceMethod);
    /// finalize the execution instance
    destructor Destroy; override;
    /// allow to hook method execution
................................................................................
    // - if optInterceptInputOutput is defined in Options, then Sender.Input/Output
    // fields would contain the execution data context when Hook is called
    procedure AddInterceptor(const Hook: TServiceMethodExecuteEvent);
    /// execute the corresponding method of a given TInterfacedObject instance
    // - will retrieve a JSON array of parameters from Par
    // - will append a JSON array of results in Res, or set an Error message, or
    // a JSON object (with parameter names) in Res if ResultAsJSONObject is set
    function ExecuteJson(Instances: array of pointer; Par: PUTF8Char;
      Res: TTextWriter; ResAsJSONObject: boolean=false): boolean;
    /// low-level direct access to the associated method information
    property Method: PServiceMethod read fMethod;
    /// low-level direct access to the current input/output parameter values
    // - you should not need to access this, but rather set
    // optInterceptInputOutput in Options, and read Input/Output content
    property Values: TPPointerDynArray read fValues;
................................................................................
    {$ifndef NOVARIANTS}
    fDocVariantOptions: TDocVariantOptions;
    {$endif}
    fFakeVTable: array of pointer;
    fFakeStub: PByteArray;
    fMethodIndexCallbackReleased: Integer;
    fMethodIndexCurrentFrameCallback: Integer;



    procedure AddMethodsFromTypeInfo(aInterface: PTypeInfo); virtual; abstract;
    function GetMethodsVirtualTable: pointer;
  public
    /// this is the main entry point to the global interface factory cache
    // - access to this method is thread-safe
    // - this method will also register the class to further retrieval
    class function Get(aInterface: PTypeInfo): TInterfaceFactory; overload;
................................................................................
  /// server-side service provider uses this to store one internal instance
  // - used by TServiceFactoryServer in sicClientDriven, sicPerSession,
  // sicPerUser or sicPerGroup mode
  TServiceFactoryServerInstance = {$ifndef ISDELPHI2010}object{$else}record{$endif}
  public
    /// the internal Instance ID, as remotely sent in "id":1
    // - is set to 0 when an entry in the array is free
    InstanceID: Cardinal;
    /// GetTickCount64() time stamp corresponding to the last access of
    // this instance
    LastAccess64: Int64;
    /// the implementation instance itself
    Instance: TInterfacedObject;
    /// used to release the implementation instance
    // - direct FreeAndNil(Instance) may lead to A/V if self has been assigned
................................................................................
    inc(j,FieldCount);
  end;
  assert(n-1=fRowCount);
  // recalcultate Bits[]
  FillcharFast(Bits,(fRowCount shr 3)+1,0);
  for i := 0 to nSet-1 do
    SetBit(Bits,i); // slow but accurate




end;

function TSQLTable.IDColumnHide: boolean;
var FID,R,F: integer;
    S,D1,D2: PPUTF8Char;
begin
  // 1. check if possible
................................................................................

{$endif USETYPEINFO}


type
  TIntfFlag = (ifHasGuid,ifDispInterface,ifDispatch{$ifdef FPC},ifHasStrGUID{$endif});
  TIntfFlags = set of TIntfFlag;





  PInterfaceTypeData = ^TInterfaceTypeData;
  TInterfaceTypeData =
    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif} record
    IntfParent: PPTypeInfo; // ancestor
    IntfFlags: TIntfFlags;
    IntfGuid: TGUID;
................................................................................
    RawIntfParent: PTypeInfo;
    RawIntfFlags : TIntfFlagsBase;
    IID: TGUID;
    RawIntfUnit: ShortString;
    IIDStr: ShortString;
  end;
  {$endif}






  TMethodKind = (mkProcedure, mkFunction, mkConstructor, mkDestructor,
    mkClassProcedure, mkClassFunction, { Obsolete } mkSafeProcedure, mkSafeFunction);

  TIntfMethodEntryTail =
    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif} record
................................................................................
      result := sftUnknown;
      exit;
    end;
  end;
end;

function TTypeInfo.FloatType: TFloatType;




begin


  result := TFloatType(PByte(AlignToPtr(@Name[ord(Name[0])+1]))^);



end;

function TTypeInfo.OrdType: TOrdType;




begin


  result := TOrdType(PByte(AlignToPtr(@Name[ord(Name[0])+1]))^);



end;

function TTypeInfo.SetEnumType: PEnumType;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
var p: pointer;
begin
  if (@self=nil) or (Kind<>tkSet) then
    result := nil else begin
    p := AlignToPtr(@Name[ord(Name[0])+1]);
    inc(p,sizeof(TOrdType));
    p := AlignToPtr(p);
    result := PPTypeInfo(PPointer(p)^)^.EnumBaseType;
  end;
{$else}
begin
  if (@self=nil) or (Kind<>tkSet) then
................................................................................
begin
  if @self=nil then
    result := 0 else
    DynArrayTypeInfoToRecordInfo(@self,@result);
end;

function TTypeInfo.AnsiStringCodePage: integer;




begin
  {$ifdef HASCODEPAGE}
  if @self=TypeInfo(TSQLRawBlob) then
    result := CP_SQLRAWBLOB else
    if Kind in [{$ifdef FPC}tkAString,{$endif} tkLString] then






      result := PWord(AlignToPtr(@Name[ord(Name[0])+1]))^ else // from RTTI

  {$else}
  if @self=TypeInfo(RawUTF8) then
    result := CP_UTF8 else
  if @self=TypeInfo(WinAnsiString) then
    result := CODEPAGE_US else
  if @self=TypeInfo(RawUnicode) then
    result := CP_UTF16 else
................................................................................
  if (@self=TypeInfo(AnsiString)) or IdemPropName(Name,'TCaption') then
    result := 0 else
  {$endif}
    result := CP_UTF8; // default is UTF-8
end;

function TTypeInfo.InterfaceGUID: PGUID;




begin
  if (@self=nil) or (Kind<>tkInterface) then



    result := nil else
    result := AlignToPtr(@PInterfaceTypeData(AlignToPtr(@Name[ord(Name[0])+1]))^.IntfGuid);




end;

function TTypeInfo.InterfaceUnitName: PShortString;




begin
  if (@self=nil) or (Kind<>tkInterface) then
    result := @NULL_SHORTSTRING else
    result := AlignToPtr(@PInterfaceTypeData(AlignToPtr(@Name[ord(Name[0])+1]))^.IntfUnit);







end;

function TTypeInfo.InterfaceAncestor: PTypeInfo;




begin
  if (@self=nil) or (Kind<>tkInterface) then
    result := nil else





    with PInterfaceTypeData(AlignToPtr(@Name[ord(Name[0])+1]))^ do

      if IntfParent=nil then
        result := nil else
        result := IntfParent{$ifndef FPC}^{$endif};

end;

procedure TTypeInfo.InterfaceAncestors(out Ancestors: PTypeInfoDynArray;
  OnlyImplementedBy: TInterfacedObjectClass;
  out AncestorsImplementedEntry: TPointerDynArray);
var n: integer;
    nfo: PTypeInfo;
    typ: PInterfaceTypeData;
    entry: pointer;
begin
  if (@self=nil) or (Kind<>tkInterface) then
    exit;
  n := 0;



  typ := AlignToPtr(@Name[ord(Name[0])+1]);

  repeat
    if typ^.IntfParent=nil then
      exit;
    nfo := typ^.IntfParent{$ifndef FPC}^{$endif};
    if nfo=TypeInfo(IInterface) then
      exit;



    typ := AlignToPtr(@nfo^.Name[ord(nfo^.Name[0])+1]);

    if ifHasGuid in typ^.IntfFlags then begin
      if OnlyImplementedBy<>nil then begin
        entry := OnlyImplementedBy.GetInterfaceEntry(typ^.IntfGuid);
        if entry=nil then
          continue;
        Setlength(AncestorsImplementedEntry,n+1);
        AncestorsImplementedEntry[n] := entry;
................................................................................
  if n=0 then
    exit;
  SetLength(Objects,n*2+1);
  SetLength(ObjectsClass,n*2+1);
  Objects[0] := self;
  ObjectsClass[0] := PSQLRecordClass(self)^;
  SetLength(fFill.fTableMapRecordManyInstances,n);  // fFill.UnMap will release memory



  for f := 0 to n-1 do begin
    M := TSQLRecordMany(Props.ManyFields[f].GetInstance(self));
    if M=nil then
      raise EORMException.CreateUTF8('%.Create should have created %:% for EnginePrepareMany',
        [self,Props.ManyFields[f].Name,Props.ManyFields[f].ObjectClass]);
    fFill.fTableMapRecordManyInstances[f] := M;
    Objects[f*2+1] := M;
................................................................................
    ValidateRest: TSynValidateRest absolute Validate;
    wasTSynValidateRest: boolean;
begin
  result := '';
  if (self=nil) or IsZero(aFields) then
    // avoid GPF and handle case if no field was selected
    exit;

  with RecordProps do
  if Filters<>nil then
  for f := 0 to Fields.Count-1 do
  if Fields.List[f].SQLFieldType in COPIABLE_FIELDS then begin
    for i := 0 to length(Filters[f])-1 do begin
      Validate := TSynValidate(Filters[f,i]);
      if Validate.InheritsFrom(TSynValidate) then begin
................................................................................
  SetString(call.InBody,P,PtrInt(input^.cbData)-(P-input^.lpData));
  call.RestAccessRights := @SUPERVISOR_ACCESS_RIGHTS;
  // note: it's up to URI overridden method to implement access rights
  URI(call);
  Res.Magic := MAGIC_SYN;
  Res.Status := call.OutStatus;
  Res.InternalState := call.OutInternalState;












  SetString(ResStr,PAnsiChar(@Res),sizeof(Res));
  ResStr := ResStr+call.OutHead+#1+call.OutBody;

  Data.dwData := fServerWindow;
  Data.cbData := length(ResStr);
  Data.lpData := pointer(ResStr);
  SendMessage(Msg.From,WM_COPYDATA,fServerWindow,PtrInt(@Data));
end;

function TSQLRestServer.CloseServerNamedPipe: boolean;
................................................................................
  if aStoredClass=nil then
    fStoredClass := TSQLMonitorUsage else
    fStoredClass := aStoredClass;
  fStorage := aStorage;
  for g := low(fStoredCache) to high(fStoredCache) do
    fStoredCache[g] := fStoredClass.Create;
  fProcessID := aProcessID;

  fLog := fStorage.LogFamily;

  inherited Create;
end;

destructor TSynMonitorUsageRest.Destroy;
var g: TSynMonitorUsageGranularity;
begin
  inherited Destroy; // would save pending changes
................................................................................
  end;
  if WhereValue[1]='"' then
    UnQuoteSQLStringVar(pointer(WhereValue),WhereValueString) else
    WhereValueString := WhereValue;
  // search indexes, then apply updates
  Where := TList.Create;
  StorageLock(true);

  try
    // find matching Where[]
    if FindWhereEqual(WhereFieldIndex,WhereValueString,AddIntegerDynArrayEvent,Where,0,0)=0 then
      exit; // Where.Count=0 -> nothing to update
    // check that all records can be updated
    for i := 0 to Where.Count-1 do
      if not RecordCanBeUpdated(fStoredClass,
................................................................................
  {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): longint;
{$else}
function TSQLRecordInterfaced.QueryInterface(const IID: TGUID; out Obj): HResult;
{$endif}
begin
  if GetInterface(IID,Obj) then
    result := 0 else
    result := E_NOINTERFACE;
end;

function TSQLRecordInterfaced._AddRef: {$ifdef FPC}longint{$else}integer{$endif};
begin
  result := InterlockedIncrement(fRefCount);
end;

................................................................................

function TSynValidateUniqueFields.Process(aFieldIndex: integer;
  const Value: RawUTF8; var ErrorMsg: string): boolean;
var where: RawUTF8;
    i: integer;
    aID: TID;
begin

  if (fProcessRest=nil) or (fProcessRec=nil) or (fFieldNames=nil) then
    result := true else begin
    for i := 0 to high(fFieldNames) do begin
      if where<>'' then
        where := where+' AND ';
      where := where+fFieldNames[i]+'=:('+
        QuotedStr(fProcessRec.GetFieldValue(fFieldNames[i]),'''')+'):';
................................................................................

  // QueryInterface, _AddRef and _Release methods are hard-coded
  RESERVED_VTABLE_SLOTS = 3;

// see http://docwiki.embarcadero.com/RADStudio/en/Program_Control

{$ifdef CPU64}
const
  // maximum stack size at method execution must match .PARAMS 64 (minus 4 regs)
  MAX_EXECSTACK = 60*8;










  {$ifdef LINUX}
  REGRDI = 1;
  REGRSI = 2;
  REGRDX = 3;
  REGRCX = 4;
  REGR8 = 5;
  REGR9 = 6;

  {$else}
  REGRCX = 1;
  REGRDX = 2;
  REGR8 = 3;
  REGR9 = 4;

  {$endif}
  REG_FIRST = 1;
  REG_LAST = REGR9;

  REGXMM0 = 1;
  REGXMM1 = 2;
  REGXMM2 = 3;
  REGXMM3 = 4;
  {$ifdef LINUX}
  REGXMM4 = 5;
  REGXMM5 = 6;
  REGXMM6 = 7;
  REGXMM7 = 8;
  REG_XMMCOUNT = REGXMM7;
  {$else}
  REG_XMMCOUNT = 0;
  {$endif}


  // x64 calling convention under Linux: rax,rsi,rdi,rcx,rdx,r8,r9 + xmm0..xmm7
  // see http://www.yankeerino.com/windowsx64callingconvention.bhs

{$else}

  // maximum stack size at method execution
  MAX_EXECSTACK = 1024;


  REGEAX = 1;
  REGEDX = 2;
  REGECX = 3;
  REG_FIRST = REGEAX;
  REG_LAST = REGECX;
  REG_XMMCOUNT = 0;























{$endif CPU64}

























  PTRSIZ = sizeof(Pointer);


  STACKOFFSET_NONE = -1;

  // ordinal values are stored within 64 bit buffer, and records in a RawUTF8
  CONST_ARGS_TO_VAR: array[TServiceMethodValueType] of TServiceMethodValueVar = (
    smvvNone, smvvSelf, smvv64, smvv64, smvv64, smvv64, smvv64, smvv64, smvv64,
    smvv64, smvv64,
    smvvRawUTF8, smvvString, smvvRawUTF8, smvvWideString, smvvRecord,
    {$ifndef NOVARIANTS}smvvRecord,{$endif} smvvObject, smvvRawUTF8,
    smvvDynArray, smvvInterface);

  // always aligned to 8 bytes boundaries for x64
  CONST_ARGS_IN_STACK_SIZE: array[TServiceMethodValueType] of Cardinal = (
     0,  PTRSIZ,PTRSIZ, PTRSIZ,PTRSIZ,PTRSIZ, PTRSIZ,    8,     8,      8,
 // None, Self, Boolean, Enum, Set,  Integer, Cardinal, Int64, Double, DateTime,
     8,       PTRSIZ,  PTRSIZ, PTRSIZ,        PTRSIZ,     PTRSIZ,
 // Currency, RawUTF8, String, RawByteString, WideString, Record,
    {$ifndef NOVARIANTS}PTRSIZ,{$endif} // Variant
    PTRSIZ, PTRSIZ,  PTRSIZ, PTRSIZ);
................................................................................
  CONST_PSEUDO_RESULT_NAME: string[6] = 'Result';
  CONST_PSEUDO_SELF_NAME: string[4] = 'Self';
  CONST_INTEGER_NAME: string[7] = 'Integer';

type
  /// map the stack memory layout at TInterfacedObjectFake.FakeCall()
  TFakeCallStack = packed record
    {$ifdef CPU64}
    {$ifdef LINUX}
    XMM0, XMM1, XMM2, XMM3, XMM4, XMM5, XMM6, XMM7: double;
    {$else}

    XMM1, XMM2, XMM3: double;
    {$endif}

    MethodIndex: PtrUInt;
    Frame, Ret: pointer;
    {$ifdef LINUX}
    RDI, RSI, RDX, RCX, R8, R9: pointer;


    {$else}
    RCX, RDX, R8, R9: pointer;
    {$endif}



    {$else}
    EDX, ECX, MethodIndex, EBP, Ret: Cardinal;



    {$endif}
    Stack: array[word] of byte;
  end;

  /// instances of this class will emulate a given interface
  // - as used by TInterfaceFactory.CreateFakeInstance
  TInterfacedObjectFake = class(TInterfacedObjectFromFactory)
  protected
    fVTable: PPointerArray;
    function FakeCall(var aCall: TFakeCallStack): Int64;
    {$ifdef FPC}








    function FakeQueryInterface(
      {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID;
      out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
    function Fake_AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
    function Fake_Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
    {$else}
    function FakeQueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
................................................................................

function TInterfacedObjectFake.SelfFromInterface: TInterfacedObjectFake;
{$ifdef PUREPASCAL}
begin
  result := pointer(PtrInt(self)-PtrInt(@TInterfacedObjectFake(nil).fVTable));
end;
{$else}

asm
  sub eax,TInterfacedObjectFake.fVTable
end;

{$endif}

function TInterfacedObjectFake.Fake_AddRef: {$ifdef FPC}longint{$else}integer{$endif};
begin
  result := SelfFromInterface._AddRef;
end;

................................................................................
  if IsEqualGUID(IID,fFactory.fInterfaceIID) then begin
    pointer(Obj) := @fVTable;
    _AddRef;
    result := NOERROR;
  end else
  if GetInterface(IID,Obj) then
    result := NOERROR else
    result := E_NOINTERFACE;
end;

procedure TInterfacedObjectFake.Get(out Obj);
begin
  pointer(Obj) := @fVTable;
  _AddRef;
end;
................................................................................
  if P<>nil then begin
    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);
    if P^=',' then inc(P);
  end;
end;

function TInterfacedObjectFake.FakeCall(var aCall: TFakeCallStack): Int64;
{$ifdef CPUARM}
begin
  raise EInterfaceFactoryException.Create('You encountered an ALF! ARM not yet supported');
end;
{$else}
var method: ^TServiceMethod;
procedure RaiseError(const Format: RawUTF8; const Args: array of const);
var msg: RawUTF8;
begin
  msg := FormatUTF8(Format,Args);
  raise EInterfaceFactoryException.CreateUTF8('%.FakeCall(%.%) failed: %',
    [self,fFactory.fInterfaceTypeInfo^.Name,method^.URI,msg]);
................................................................................
    if ifoJsonAsExtended in fOptions then
      include(Params.fCustomOptions,twoForceJSONExtended) else
      include(Params.fCustomOptions,twoForceJSONStandard); // e.g. for AJAX
    FillcharFast(I64s,method^.ArgsUsedCount[smvv64]*sizeof(Int64),0);
    for arg := 1 to high(method^.Args) do
    with method^.Args[arg] do
    if ValueType>smvSelf then begin
      case RegisterIdent of
      {$ifdef CPU64}
      REG_FIRST: begin
        RaiseError('unexpected self',[]);
        V := nil; // make compiler happy
      end;
      {$ifdef LINUX}
      {$else} // see https://msdn.microsoft.com/en-us/library/zthk2dkh.aspx
      REGRDX: if vIsInFPR in ValueKindAsm then
                V := @aCall.XMM1 else
                V := @aCall.RDX;
      REGR8:  if vIsInFPR in ValueKindAsm then
                V := @aCall.XMM2 else
                V := @aCall.R8;
      REGR9:  if vIsInFPR in ValueKindAsm then
                V := @aCall.XMM3 else
                V := @aCall.R9;
      {$endif}
      {$else}
      REGEAX: begin V := nil; RaiseError('unexpected self',[]); end;
      REGEDX: V := @aCall.EDX;
      REGECX: V := @aCall.ECX;
      {$endif}
      else if SizeInStack>0 then
        V := @aCall.Stack[InStackOffset] else
        V := @I64s[IndexVar]; // for results in CPU
      end;
      if vPassedByReference in ValueKindAsm then
        V := PPointer(V)^;
      case ValueType of
      smvDynArray:
        DynArrays[IndexVar].Init(ArgTypeInfo,V^);
      end;
      Value[arg] := V;
................................................................................
    if method^.ArgsOutputValuesCount>0 then
      RaiseError('method returned value, but ResArray=''''',[]);
end;
begin
  // WELCOME ABOARD: you just landed in TInterfacedObjectFake.FakeCall() !
  // if your debugger reached here, you are executing a "fake" interface
  // forged to call a remote SOA server or mock/stub an interface

  self := SelfFromInterface;









  if aCall.MethodIndex>=fFactory.fMethodsCount then
    raise EInterfaceFactoryException.CreateUTF8(
      '%.FakeCall(%.%) failed: out of range method %>=%',
      [self,fFactory.fInterfaceTypeInfo^.Name,aCall.MethodIndex,fFactory.fMethodsCount]);
  method := @fFactory.fMethods[aCall.MethodIndex];
  if not Assigned(fInvoke)then
    RaiseError('fInvoke=nil',[]);
  result := 0;
  resultType := smvNone;
  InternalProcess; // use an inner proc to ensure direct fld/fild FPU ops
  case resultType of // al/ax/eax/eax:edx/rax already in result

  {$ifdef CPU64}
  smvDouble,smvDateTime: aCall.XMM1 := PDouble(@result)^;
  {$else}
  smvDouble,smvDateTime: asm fld  qword ptr [result] end;  // in st(0)
  smvCurrency:           asm fild qword ptr [result] end;  // in st(0)
  {$endif}







  end;
end;
{$endif CPUARM}

procedure TInterfacedObjectFake.InterfaceWrite(W: TJSONSerializer;
  const aMethod: TServiceMethod; const aParamInfo: TServiceMethodArgument;
  aParamValue: Pointer);
begin
  raise EInterfaceFactoryException.CreateUTF8('%: unhandled %.%(%: %) argument',
    [self,fFactory.fInterfaceTypeInfo^.Name,aMethod.URI,
................................................................................
class function TInterfaceFactory.GetUsedInterfaces: TObjectList;
begin
  result := InterfaceFactoryCache;
end;

constructor TInterfaceFactory.Create(aInterface: PTypeInfo);
var m,a,reg: integer;



    WR: TTextWriter;
    C: TClass;
    ErrorMsg: RawUTF8;
{$ifdef CPU64}







    resultIsRDX: boolean;
{$else}




    offs: integer;
{$endif}
label error;
begin
  if aInterface=nil then
    raise EInterfaceFactoryException.CreateUTF8('%.Create(nil)',[self]);
  if aInterface^.Kind<>tkInterface then
    raise EInterfaceFactoryException.CreateUTF8(
      '%.Create(%): % is not an interface',[self,aInterface^.Name,aInterface^.Name]);
  {$ifndef NOVARIANTS}
  fDocVariantOptions := JSON_OPTIONS_FAST;
  {$endif}



  fInterfaceTypeInfo := aInterface;
  fInterfaceIID := aInterface^.InterfaceGUID^;
  if IsNullGUID(fInterfaceIID) then
    raise EInterfaceFactoryException.CreateUTF8(
      '%.Create: % has no GUID',[self,aInterface^.Name]);
  fInterfaceName := ToUTF8(fInterfaceTypeInfo^.Name);
  // retrieve all interface methods (recursively including ancestors)
................................................................................
            fMethodIndexCallbackReleased := m;
      end;
  end;
  // compute asm low-level layout of the parameters for each method
  for m := 0 to fMethodsCount-1 do
  with fMethods[m] do begin
    // prepare stack and register layout


    reg := REG_FIRST;

    {$ifdef CPU64}




    resultIsRDX := (ArgsResultIndex>=0) and
      (Args[ArgsResultIndex].ValueType in CONST_ARGS_RESULT_BY_REF);
    {$endif}










    for a := 0 to high(Args) do
    with Args[a] do begin


      ValueVar := CONST_ARGS_TO_VAR[ValueType];
      IndexVar := ArgsUsedCount[ValueVar];
      inc(ArgsUsedCount[ValueVar]);
      include(ArgsUsed,ValueType);
      if (ValueType in [smvRecord{$ifndef NOVARIANTS},smvVariant{$endif}
          {$ifdef FPC},smvDynArray{$endif}]) or
         (ValueDirection in [smdVar,smdOut]) or
................................................................................
        Include(ValueKindAsm,vPassedByReference);
      case ValueType of
      smvRawUTF8..smvWideString:
        Include(ValueKindAsm,vIsString);
      smvDynArray:
        if ObjArraySerializers.Find(ArgTypeInfo)<>nil then
          Include(ValueKindAsm,vIsObjArray);
      {$ifdef CPU64}
      smvDouble,smvDateTime:
        if (reg<=REG_LAST) and not (vPassedByReference in ValueKindAsm) then
          Include(ValueKindAsm,vIsInFPR);
      {$endif}
      end;
      case ValueType of
        smvBoolean:
          SizeInStorage := 1;
        smvInteger, smvCardinal:
          SizeInStorage := 4;
................................................................................
            SizeInStorage := PTRSIZ; // handle only records when passed by ref
        else
          SizeInStorage := PTRSIZ;
      end;
      if ValueDirection=smdResult then begin
        if not(ValueType in CONST_ARGS_RESULT_BY_REF) then
          continue; // ordinal/real/class results are returned in CPU/FPU registers
        {$ifdef CPU64} // Delphi always put the result pointer as RDX in x64
        InStackOffset := STACKOFFSET_NONE;



        RegisterIdent := REGRDX;













        continue;
        {$endif}
      end;
      {$ifndef CPU64}
      if ValueDirection=smdConst then
        SizeInStack := CONST_ARGS_IN_STACK_SIZE[ValueType] else
      {$endif}
        SizeInStack := PTRSIZ;
      if (reg>REG_LAST) or (SizeInStack<>PTRSIZ)
        // TODO: fix smvDynArray as expected by fpc\compiler\i386\cpupara.pas
        {$ifdef FPC}or ((ValueType in [smvRecord,smvDynArray]) and
          not (vPassedByReference in ValueKindAsm)){$endif} then begin
        InStackOffset := ArgsSizeInStack;
        inc(ArgsSizeInStack,SizeInStack);
      end else begin
        InStackOffset := STACKOFFSET_NONE;
        {$ifdef CPU64}




        if resultIsRDX and (reg=REGRDX) then
          inc(reg); // RDX is reserved by Delphi for function result pointer





        {$endif}
































        RegisterIdent := reg;

        inc(reg);











      end;
    end;
    if ArgsSizeInStack>MAX_EXECSTACK then
      raise EInterfaceFactoryException.CreateUTF8(
        '%.Create: Stack size % > % for %.% method',
        [self,ArgsSizeInStack,MAX_EXECSTACK,fInterfaceTypeInfo^.Name,URI]);
    {$ifndef CPU64}
    // pascal/register convention are passed left-to-right -> reverse order
    offs := ArgsSizeInStack;
    for a := 0 to high(Args) do
    with Args[a] do
      if InStackOffset>=0 then begin
        dec(offs,SizeInStack);
        InStackOffset := offs;
................................................................................
    result := GetMethodName(aMethodIndex);
    if result = '' then
      result := fInterfaceName else
      result := fInterfaceName+'.'+result;
  end;
end;

{ low-level ASM for TInterfaceFactory.GetMethodsVirtualTable }





































































{$ifdef CPU64}
procedure x64FakeStub; {$ifdef FPC} assembler; {$endif}


{$ifdef LINUX}
var smetndx, sxmm7, sxmm6, sxmm5, sxmm4, sxmm3, sxmm2, sxmm1, sxmm0: pointer;
{$else}
var smetndx, sxmm3, sxmm2, sxmm1: pointer;


{$endif}
asm // mov ax,{MethodIndex}; jmp x64FakeStub
  {$ifdef FPC}
  {$else}
  .params 2 // FakeCall(self: TInterfacedObjectFake; var aCall: TFakeCallStack): Int64



  {$endif}
  and rax,$ffff




  {$ifdef LINUX}
  movsd sxmm0,xmm0
  movsd sxmm4,xmm4
  movsd sxmm5,xmm5
  movsd sxmm6,xmm6
  movsd sxmm7,xmm7






  {$endif}
  movsd sxmm1,xmm1
  movsd sxmm2,xmm2
  movsd sxmm3,xmm3
  mov smetndx,rax
  {$ifdef LINUX}
  // TODO: check RDI, RSI, RDX, RCX, R8, R9 on [rbp+...]
  lea rsi,sxmm1 // TFakeCallStack address as 2nd parameter
  {$else}



  mov [rbp+$50],rcx
  mov [rbp+$58],rdx

  mov [rbp+$60],r8
  mov [rbp+$68],r9



  lea rdx,sxmm1 // TFakeCallStack address as 2nd parameter
  {$endif}
  call TInterfacedObjectFake.FakeCall
  // FakeCall should set Int64 result in method result, and float in aCall.XMM1
  movsd xmm0,sxmm1
end;
{$endif}

const
  STUB_SIZE = 65536; // 16*4 KB (4 KB = memory granularity)































































































































type
  // internal memory buffer created with PAGE_EXECUTE_READWRITE flags
  TFakeStubBuffer = class
  protected
    fStub: PByteArray;
    fStubUsed: cardinal;
................................................................................

var
  CurrentFakeStubBuffer: TFakeStubBuffer;

constructor TFakeStubBuffer.Create;
begin
  {$ifdef MSWINDOWS}




  fStub := VirtualAlloc(nil,STUB_SIZE,MEM_COMMIT,PAGE_EXECUTE_READWRITE);

  {$else}
  fStub := {$ifdef KYLIX3}mmap{$else}fpmmap{$endif}(
    nil,STUB_SIZE,PROT_READ OR PROT_WRITE OR PROT_EXEC,MAP_PRIVATE OR MAP_ANONYMOUS,-1,0);


  {$endif}

end;

destructor TFakeStubBuffer.Destroy;
begin
  {$ifdef MSWINDOWS}
  VirtualFree(fStub,0,MEM_RELEASE);
  {$else}
  {$ifdef KYLIX3}munmap{$else}fpmunmap{$endif}(fStub,0);




  {$endif}
  inherited;
end;

class function TFakeStubBuffer.Reserve(size: Cardinal): pointer;
begin
  if size>STUB_SIZE then
................................................................................
  with CurrentFakeStubBuffer do begin
    result := @fStub[fStubUsed];
    inc(fStubUsed,size);
  end;
end;

function TInterfaceFactory.GetMethodsVirtualTable: pointer;
var i: integer;
    P: PCardinal;
begin
  if fFakeVTable=nil then begin
    InterfaceFactoryCache.Safe.Lock;
    try
      if fFakeVTable=nil then begin // avoid race condition error
        SetLength(fFakeVTable,fMethodsCount+RESERVED_VTABLE_SLOTS);
        fFakeVTable[0] := @TInterfacedObjectFake.FakeQueryInterface;
        fFakeVTable[1] := @TInterfacedObjectFake.Fake_AddRef;
        fFakeVTable[2] := @TInterfacedObjectFake.Fake_Release;








        fFakeStub := TFakeStubBuffer.Reserve(fMethodsCount*{$ifdef CPU64}12{$else}24{$endif});

        P := pointer(fFakeStub);
        for i := 0 to fMethodsCount-1 do begin
          fFakeVTable[i+RESERVED_VTABLE_SLOTS] := P;
          {$ifdef CPU64}
          P^ := $b866+(i shl 16); inc(P);          // mov ax,{MethodIndex}
          PByte(P)^ := $e9; inc(PByte(P));         // jmp x64FakeStub
          P^ := PtrUInt(@x64FakeStub)-PtrUInt(P)-4; inc(P);
          P^ := $909090;
          {$else}



























          P^ := $68ec8b55; inc(P);                 // push ebp; mov ebp,esp
          P^ := i; inc(P);                         // push {MethodIndex}
          P^ := $e2895251; inc(P);                 // push ecx; push edx; mov edx,esp
          PByte(P)^ := $e8; inc(PByte(P));         // call FakeCall
          P^ := PtrUInt(@TInterfacedObjectFake.FakeCall)-PtrUInt(P)-4; inc(P);
          P^ := $c25dec89; inc(P);                 // mov esp,ebp; pop ebp
          P^ := fMethods[i].ArgsSizeInStack or $900000;  // ret {StackSize}; nop
          {$endif}
          inc(PByte(P),3);

        end;
      end;
    finally
      InterfaceFactoryCache.Safe.UnLock;
    end;
  end;
  result := pointer(fFakeVTable);
................................................................................
  {$else}
  P := AlignToPtr(@PI^.IntfUnit[ord(PI^.IntfUnit[0])+1]);
  {$endif}
  n := PW^; inc(PW);
  if (PW^=$ffff) or (n=0) then
    exit; // no RTTI or no method at this level of interface
  inc(PW);

  for m := fMethodsCount to fMethodsCount+n-1 do begin
    // retrieve method name, and add to the methods list (with hashing)
    SetString(aURI,PAnsiChar(@PS^[1]),ord(PS^[0]));
    with PServiceMethod(fMethod.AddUniqueName(aURI,
      '%.% method: duplicated name for %',[fInterfaceTypeInfo^.Name,aURI,self]))^ do begin
      HierarchyLevel := fAddMethodsLevel;
      {$ifdef FPC} // FPC has its own RTTI layout only since late 3.x
      inc(PB,ord(PS^[0])+1);
      inc(PB); // skip Version field (always 3)
      {$ifndef CPUARM}
      if PCallingConvention(P)^<>ccRegister then
         RaiseError('method shall use register calling convention',[]);
      {$endif}
      inc(PB,sizeOf(TCallingConvention));
      P := AlignToPtr(P);// new Alignment
      aResultType := PTypeInfo(ppointer(P)^);
      inc(PP);
      inc(PW); // skip StackSize
      n := PB^;
      inc(PB);
................................................................................
end;


{ TServiceFactoryServer }

type
  PCallMethodArgs = ^TCallMethodArgs;



  TCallMethodArgs = record

    StackSize, StackAddr, method: PtrInt;
    Regs: array[REG_FIRST..REG_LAST+REG_XMMCOUNT] of PtrInt;




    res64: Int64Rec;
    resKind: TServiceMethodValueType;
  end;




procedure CallMethod(var Args: TCallMethodArgs);
{$ifdef CPUARM}
begin
  raise EInterfaceFactoryException.Create('FPC+ARM not supported yet');













































































end;
{$else}

{$ifdef CPU64}







































































{$ifdef FPC}
var r12sav: pointer;

asm



    mov r12sav,r12





    mov r12,Args
    // copy stack content (if any)
    mov RDI,[r12].TCallMethodArgs.StackAddr
    lea RSI,[rsp+$20]
    mov RDX, [r12].TCallMethodArgs.StackSize
    call Move
    // call method













    {$ifdef LINUX}
    // Linux/BSD System V AMD64 ABI
    mov RDI,[r12+TCallMethodArgs.Regs+REGRDI*8-8]
    mov RSI,[r12+TCallMethodArgs.Regs+REGRSI*8-8]
    mov RDX, [r12+TCallMethodArgs.Regs+REGRDX *8-8]
    mov RCX, [r12+TCallMethodArgs.Regs+REGRCX *8-8]
    mov R8,[r12+TCallMethodArgs.Regs+REGR8*8-8]
    mov R9,[r12+TCallMethodArgs.Regs+REGR9*8-8]
    movsd xmm0,[r12+TCallMethodArgs.Regs+REG_LAST*8+REGXMM0*8-8]
    movsd xmm1,[r12+TCallMethodArgs.Regs+REG_LAST*8+REGXMM1*8-8]
    movsd xmm2,[r12+TCallMethodArgs.Regs+REG_LAST*8+REGXMM2*8-8]
    movsd xmm3,[r12+TCallMethodArgs.Regs+REG_LAST*8+REGXMM3*8-8]
    movsd xmm4,[r12+TCallMethodArgs.Regs+REG_LAST*8+REGXMM4*8-8]
    movsd xmm5,[r12+TCallMethodArgs.Regs+REG_LAST*8+REGXMM5*8-8]
    movsd xmm6,[r12+TCallMethodArgs.Regs+REG_LAST*8+REGXMM6*8-8]
    movsd xmm7,[r12+TCallMethodArgs.Regs+REG_LAST*8+REGXMM7*8-8]








    {$else}
    // Win64 ABI
    mov rcx,[r12+TCallMethodArgs.Regs+REGRCX*8-8]
    mov rdx,[r12+TCallMethodArgs.Regs+REGRDX*8-8]
    mov r8, [r12+TCallMethodArgs.Regs+REGR8 *8-8]
    mov r9, [r12+TCallMethodArgs.Regs+REGR9 *8-8]






    movsd xmm0,[r12+TCallMethodArgs.Regs+REGXMM0*8-8]
    movsd xmm1,[r12+TCallMethodArgs.Regs+REGXMM1*8-8]
    movsd xmm2,[r12+TCallMethodArgs.Regs+REGXMM2*8-8]
    movsd xmm3,[r12+TCallMethodArgs.Regs+REGXMM3*8-8]







    {$endif}

    call [r12].TCallMethodArgs.method




    // retrieve result
    mov [r12].TCallMethodArgs.res64,rax
    mov cl,[r12].TCallMethodArgs.resKind
    cmp cl,smvDouble
    je @d
    cmp cl,smvDateTime
    je @d
    cmp cl,smvCurrency
    jne @e
@d: movsd [r12].TCallMethodArgs.res64,xmm0
@e: mov r12,r12sav
end;
{$else}
asm
    .params 64    // size for 64 parameters
    .pushnv r12   // generate prolog+epilog to save and restore non-volatile r12
    mov r12,Args
    // copy stack content (if any)
    mov rcx,[r12].TCallMethodArgs.StackAddr
    lea rdx,[rsp+$20]
    mov r8, [r12].TCallMethodArgs.StackSize
    call qword ptr [MoveFast]
    // call method
    mov rcx,[r12+TCallMethodArgs.Regs+REGRCX*8-8]
    mov rdx,[r12+TCallMethodArgs.Regs+REGRDX*8-8]
    mov r8, [r12+TCallMethodArgs.Regs+REGR8 *8-8]
    mov r9, [r12+TCallMethodArgs.Regs+REGR9 *8-8]
    movsd xmm0,[r12+TCallMethodArgs.Regs+REGXMM0*8-8]
    movsd xmm1,[r12+TCallMethodArgs.Regs+REGXMM1*8-8]
    movsd xmm2,[r12+TCallMethodArgs.Regs+REGXMM2*8-8]
    movsd xmm3,[r12+TCallMethodArgs.Regs+REGXMM3*8-8]
    call [r12].TCallMethodArgs.method
    // retrieve result
    mov [r12].TCallMethodArgs.res64,rax
    mov cl,[r12].TCallMethodArgs.resKind
    cmp cl,smvDouble
    je @d
    cmp cl,smvDateTime
    je @d
    cmp cl,smvCurrency
    jne @e
@d: movsd [r12].TCallMethodArgs.res64,xmm0
@e:

end;
{$endif}
{$else}


asm
    push esi
    push ebp
    mov ebp,esp
    mov esi,Args
    // copy stack content (if any)
    mov eax,[esi].TCallMethodArgs.StackSize
................................................................................
    jz @z
@n: sub edx,4
    mov ecx,[edx]
    push ecx
    dec eax
    jnz @n
    // call method
@z: mov eax,[esi+TCallMethodArgs.Regs+REGEAX*4-4]
    mov edx,[esi+TCallMethodArgs.Regs+REGEDX*4-4]
    mov ecx,[esi+TCallMethodArgs.Regs+REGECX*4-4]
    call [esi].TCallMethodArgs.method
    // retrieve result
    mov cl,[esi].TCallMethodArgs.resKind
    cmp cl,smvDouble
    je @d
    cmp cl,smvDateTime
    je @d
................................................................................
    jmp @e
@i: mov [esi].TCallMethodArgs.res64.Lo,eax
    mov [esi].TCallMethodArgs.res64.Hi,edx
@e: mov esp,ebp
    pop ebp
    pop esi
end;
{$endif CPU64}
{$endif CPUARM}

procedure BackgroundExecuteProc(Call: pointer);
var synch: PBackgroundLauncher absolute Call;
    threadContext: PServiceRunningContext;
    backup: TServiceRunningContext;
begin
  threadContext := @ServiceContext; // faster to use a pointer than GetTls()
................................................................................
      Input.InitFast(ArgsInputValuesCount,dvObject);
      Output.InitFast(ArgsOutputValuesCount,dvObject);
    end;
  end;
  fAlreadyExecuted := true;
end;

procedure TServiceMethodExecute.RawExecute(Instances: PPointerArray;
  InstancesLast: integer);
var Value: pointer;
    a,i,e: integer;
    call: TCallMethodArgs;
    Stack: array[0..MAX_EXECSTACK-1] of byte;
begin

  with fMethod^ do begin
    // create the stack content

    call.StackAddr := PtrInt(@Stack);
    call.StackSize := ArgsSizeInStack;




















    for a := 1 to high(Args) do
    with Args[a] do begin
      case ValueVar of
      smvvSelf:       continue; // call.Regs[REG_FIRST] := Instance[i] below
      smvv64:         Value := @fInt64s[IndexVar];
      smvvRawUTF8:    Value := @fRawUTF8s[IndexVar];
      smvvString:     Value := @fStrings[IndexVar];
................................................................................
      smvvRecord:     Value := pointer(fRecords[IndexVar]);
      smvvDynArray:   Value := @fDynArrays[IndexVar].Value;
      else raise EInterfaceFactoryException.CreateUTF8(
        'Invalid % argument type = %',[ParamName^,ord(ValueType)]);
      end;
      fValues[a] := Value;
      if (ValueDirection<>smdConst) or
         (ValueType in [smvRecord{$ifndef NOVARIANTS},smvVariant{$endif}]) then
        // pass by reference
        if RegisterIdent=0 then
          MoveFast(Value,Stack[InStackOffset],SizeInStack) else

          call.Regs[RegisterIdent] := PtrInt(Value) else






        // pass by value
        if RegisterIdent=0 then

          MoveFast(Value^,Stack[InStackOffset],SizeInStack) else

          call.Regs[RegisterIdent] := PPtrInt(Value)^;















    end;
    // execute the method
    for i := 0 to InstancesLast do begin
      // handle method execution interception
      fCurrentStep := smsBefore;
      if fOnExecute<>nil then begin
        if (Input.Count=0) and (optInterceptInputOutput in Options) then
................................................................................
        for e := 0 to length(fOnExecute)-1 do
        try
          fOnExecute[e](self,smsBefore);
        except // ignore any exception during interception
        end;
      end;
      // prepare the low-level call context for the asm stub

      call.Regs[REG_FIRST] := PtrInt(Instances[i]);









      call.method := PPtrIntArray(PPointer(Instances[i])^)^[ExecutionMethodIndex];
      if ArgsResultIndex>=0 then
        call.resKind := Args[ArgsResultIndex].ValueType else
        call.resKind := smvNone;
      // launch the asm stub in the expected execution context
      try
        {$ifndef LVCL}
................................................................................
      end;
      {$endif}
      end;
    end;
  end;
end;

function TServiceMethodExecute.ExecuteJson(Instances: array of pointer; Par: PUTF8Char;
  Res: TTextWriter; ResAsJSONObject: boolean): boolean;
var a,a1: integer;
    wasString, valid: boolean;
    Val: PUTF8Char;
    Name: PUTF8Char;
    NameLen: integer;
    EndOfObject: AnsiChar;






|







 







|
|
|
>
>

>
>
>
>
>
>







 







|







 







|







 







>
>
>







 







|







 







>
>
>
>







 







>
>
>
>







 







>
>
>
>







 







>
>
>
>

>
>
|
>
>
>



>
>
>
>

>
>
|
>
>
>








|







 







>
>
>
>





>
>
>
>
>
>
|
>







 







>
>
>
>

|
>
>
>
|
<
>
>
>
>



>
>
>
>



|
>
>
>
>
>
>
>



>
>
>
>



>
>
>
>
>
|
>


|
>













>
>
>
|
>






>
>
>
|
>







 







>
>
>







 







>







 







>
>
>
>
>
>
>
>
>
>
>
>


>







 







>

>







 







>







 







|







 







>







 







<


>
>
>
>
>
>
>
>

>







>





>

<
|
<









|

|

<
>
|
<

<
<
<
<
<
>



|
|
|
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>











|







 







|
|
<

>
|

>

|
<
|
>
>
|
<

>
>
>
|
<
>
>
>

|









>
>
>
>
>
>
>
>







 







>



>







 







|







 







<
<
<
<
<







 







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







 







>

>
>
>
>
>
>
>
>
>











>

|




>
>
>
>
>
>
>


<







 







>
>
>



|
>
>
>
>
>
>
>
|
|
>
>
>
>

|










>
>
>







 







>
>
|
>
|
>
>
>
>
|
|

>
>
>
>
>
>
>
>
>
>


>
>







 







|

|
|







 







|

>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>



|




|
|






|
>
>
>
>
|
|
>
>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>






|







 







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|
>
>
|
|
|
|
>
>
|

|
<
|
>
>
>


>
>
>
>

<
|
|
|
|
>
>
>
>
>
>
|
<
<
<


<
|

>
>
>
|
|
>
|
|
>
>
>
|
|

|
|

|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>

>
|
|
|
>
>

>







|
>
>
>
>







 







|










>
>
>
>
>
>
>
>
|
>



|
|
|


|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







<

>







 







>









|


|







 







>
>
>

>
|
<
>
>
>
>



<
>
>
>


<
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

<
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
>

>
>
>
|
>
>
>
>
>

|
|
<
|
<
<
>
>
>
>
>
>
>
>
>
>
>
>
>


|
|
|
|
|
|
<
<
<
<
<
<
<
<
>
>
>
>
>
>
>
>


|
|
|
|
>
>
>
>
>
>
|
|
|
|
>
>
>
>
>
>
>

>

>
>
>
>









|
|
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>

|
<
>
>







 







|
|
|







 







|
<







 







|




|

>

|
>
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
|
|
|
>
|
>
>
>
>
>
>
|
<
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
|
>
>
>
>
>
>
>
>
>







 







|







5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
....
9997
9998
9999
10000
10001
10002
10003
10004
10005
10006
10007
10008
10009
10010
10011
10012
10013
10014
10015
10016
10017
10018
10019
10020
10021
10022
.....
10334
10335
10336
10337
10338
10339
10340
10341
10342
10343
10344
10345
10346
10347
10348
.....
10349
10350
10351
10352
10353
10354
10355
10356
10357
10358
10359
10360
10361
10362
10363
.....
10743
10744
10745
10746
10747
10748
10749
10750
10751
10752
10753
10754
10755
10756
10757
10758
10759
.....
11765
11766
11767
11768
11769
11770
11771
11772
11773
11774
11775
11776
11777
11778
11779
.....
23412
23413
23414
23415
23416
23417
23418
23419
23420
23421
23422
23423
23424
23425
23426
23427
23428
23429
.....
28189
28190
28191
28192
28193
28194
28195
28196
28197
28198
28199
28200
28201
28202
28203
28204
28205
28206
.....
28214
28215
28216
28217
28218
28219
28220
28221
28222
28223
28224
28225
28226
28227
28228
28229
28230
28231
.....
28488
28489
28490
28491
28492
28493
28494
28495
28496
28497
28498
28499
28500
28501
28502
28503
28504
28505
28506
28507
28508
28509
28510
28511
28512
28513
28514
28515
28516
28517
28518
28519
28520
28521
28522
28523
28524
28525
28526
28527
28528
28529
28530
28531
28532
28533
28534
28535
.....
28550
28551
28552
28553
28554
28555
28556
28557
28558
28559
28560
28561
28562
28563
28564
28565
28566
28567
28568
28569
28570
28571
28572
28573
28574
28575
28576
28577
28578
28579
28580
.....
28585
28586
28587
28588
28589
28590
28591
28592
28593
28594
28595
28596
28597
28598
28599
28600
28601

28602
28603
28604
28605
28606
28607
28608
28609
28610
28611
28612
28613
28614
28615
28616
28617
28618
28619
28620
28621
28622
28623
28624
28625
28626
28627
28628
28629
28630
28631
28632
28633
28634
28635
28636
28637
28638
28639
28640
28641
28642
28643
28644
28645
28646
28647
28648
28649
28650
28651
28652
28653
28654
28655
28656
28657
28658
28659
28660
28661
28662
28663
28664
28665
28666
28667
28668
28669
28670
28671
28672
28673
28674
28675
28676
28677
28678
28679
28680
.....
30552
30553
30554
30555
30556
30557
30558
30559
30560
30561
30562
30563
30564
30565
30566
30567
30568
.....
30996
30997
30998
30999
31000
31001
31002
31003
31004
31005
31006
31007
31008
31009
31010
.....
36185
36186
36187
36188
36189
36190
36191
36192
36193
36194
36195
36196
36197
36198
36199
36200
36201
36202
36203
36204
36205
36206
36207
36208
36209
36210
36211
36212
36213
.....
41706
41707
41708
41709
41710
41711
41712
41713
41714
41715
41716
41717
41718
41719
41720
41721
41722
.....
43363
43364
43365
43366
43367
43368
43369
43370
43371
43372
43373
43374
43375
43376
43377
.....
46700
46701
46702
46703
46704
46705
46706
46707
46708
46709
46710
46711
46712
46713
46714
.....
48083
48084
48085
48086
48087
48088
48089
48090
48091
48092
48093
48094
48095
48096
48097
.....
50320
50321
50322
50323
50324
50325
50326

50327
50328
50329
50330
50331
50332
50333
50334
50335
50336
50337
50338
50339
50340
50341
50342
50343
50344
50345
50346
50347
50348
50349
50350
50351
50352
50353

50354

50355
50356
50357
50358
50359
50360
50361
50362
50363
50364
50365
50366
50367

50368
50369

50370





50371
50372
50373
50374
50375
50376
50377
50378
50379
50380
50381
50382
50383
50384
50385
50386
50387
50388
50389
50390
50391
50392
50393
50394
50395
50396
50397
50398
50399
50400
50401
50402
50403
50404
50405
50406
50407
50408
50409
50410
50411
50412
50413
50414
50415
50416
50417
50418
50419
50420
50421
50422
50423
50424
50425
50426
50427
50428
50429
50430
50431
50432
50433
50434
50435
50436
50437
50438
50439
50440
50441
50442
50443
50444
50445
50446
50447
.....
50454
50455
50456
50457
50458
50459
50460
50461
50462

50463
50464
50465
50466
50467
50468
50469

50470
50471
50472
50473

50474
50475
50476
50477
50478

50479
50480
50481
50482
50483
50484
50485
50486
50487
50488
50489
50490
50491
50492
50493
50494
50495
50496
50497
50498
50499
50500
50501
50502
50503
50504
50505
50506
50507
.....
50568
50569
50570
50571
50572
50573
50574
50575
50576
50577
50578
50579
50580
50581
50582
50583
50584
50585
50586
.....
50600
50601
50602
50603
50604
50605
50606
50607
50608
50609
50610
50611
50612
50613
50614
.....
50618
50619
50620
50621
50622
50623
50624





50625
50626
50627
50628
50629
50630
50631
.....
50649
50650
50651
50652
50653
50654
50655
50656
50657
50658
50659
50660
50661
50662
50663
50664
50665
50666
50667
50668
50669
50670
50671
50672
50673
50674
50675
50676
50677
50678
50679
50680
50681
50682
50683
50684
50685
50686
50687
50688
50689
.....
50828
50829
50830
50831
50832
50833
50834
50835
50836
50837
50838
50839
50840
50841
50842
50843
50844
50845
50846
50847
50848
50849
50850
50851
50852
50853
50854
50855
50856
50857
50858
50859
50860
50861
50862
50863
50864
50865
50866
50867
50868
50869
50870
50871
50872

50873
50874
50875
50876
50877
50878
50879
.....
51225
51226
51227
51228
51229
51230
51231
51232
51233
51234
51235
51236
51237
51238
51239
51240
51241
51242
51243
51244
51245
51246
51247
51248
51249
51250
51251
51252
51253
51254
51255
51256
51257
51258
51259
51260
51261
51262
51263
51264
51265
51266
51267
51268
51269
51270
51271
51272
51273
.....
51371
51372
51373
51374
51375
51376
51377
51378
51379
51380
51381
51382
51383
51384
51385
51386
51387
51388
51389
51390
51391
51392
51393
51394
51395
51396
51397
51398
51399
51400
51401
51402
51403
51404
51405
51406
51407
51408
51409
51410
.....
51412
51413
51414
51415
51416
51417
51418
51419
51420
51421
51422
51423
51424
51425
51426
51427
51428
51429
.....
51446
51447
51448
51449
51450
51451
51452
51453
51454
51455
51456
51457
51458
51459
51460
51461
51462
51463
51464
51465
51466
51467
51468
51469
51470
51471
51472
51473
51474
51475
51476
51477
51478
51479
51480
51481
51482
51483
51484
51485
51486
51487
51488
51489
51490
51491
51492
51493
51494
51495
51496
51497
51498
51499
51500
51501
51502
51503
51504
51505
51506
51507
51508
51509
51510
51511
51512
51513
51514
51515
51516
51517
51518
51519
51520
51521
51522
51523
51524
51525
51526
51527
51528
51529
51530
51531
51532
51533
51534
51535
51536
51537
51538
51539
51540
51541
51542
51543
51544
51545
51546
51547
51548
51549
51550
51551
51552
51553
51554
51555
51556
51557
51558
51559
51560
.....
51671
51672
51673
51674
51675
51676
51677
51678
51679
51680
51681
51682
51683
51684
51685
51686
51687
51688
51689
51690
51691
51692
51693
51694
51695
51696
51697
51698
51699
51700
51701
51702
51703
51704
51705
51706
51707
51708
51709
51710
51711
51712
51713
51714
51715
51716
51717
51718
51719
51720
51721
51722
51723
51724
51725
51726
51727
51728
51729
51730
51731
51732
51733
51734
51735
51736
51737
51738
51739
51740
51741
51742
51743
51744
51745
51746
51747
51748
51749
51750
51751
51752
51753
51754
51755
51756
51757
51758
51759
51760

51761
51762
51763
51764
51765
51766
51767
51768
51769
51770
51771

51772
51773
51774
51775
51776
51777
51778
51779
51780
51781
51782



51783
51784

51785
51786
51787
51788
51789
51790
51791
51792
51793
51794
51795
51796
51797
51798
51799
51800
51801
51802
51803
51804
51805
51806
51807
51808
51809
51810
51811
51812
51813
51814
51815
51816
51817
51818
51819
51820
51821
51822
51823
51824
51825
51826
51827
51828
51829
51830
51831
51832
51833
51834
51835
51836
51837
51838
51839
51840
51841
51842
51843
51844
51845
51846
51847
51848
51849
51850
51851
51852
51853
51854
51855
51856
51857
51858
51859
51860
51861
51862
51863
51864
51865
51866
51867
51868
51869
51870
51871
51872
51873
51874
51875
51876
51877
51878
51879
51880
51881
51882
51883
51884
51885
51886
51887
51888
51889
51890
51891
51892
51893
51894
51895
51896
51897
51898
51899
51900
51901
51902
51903
51904
51905
51906
51907
51908
51909
51910
51911
51912
51913
51914
51915
51916
51917
51918
51919
51920
51921
51922
51923
51924
51925
51926
51927
51928
51929
51930
51931
51932
51933
51934
51935
51936
51937
51938
51939
51940
.....
51947
51948
51949
51950
51951
51952
51953
51954
51955
51956
51957
51958
51959
51960
51961
51962
51963
51964
51965
51966
51967
51968
51969
51970
51971
51972
51973
51974
51975
51976
51977
51978
51979
51980
51981
51982
51983
51984
51985
.....
51993
51994
51995
51996
51997
51998
51999
52000
52001
52002
52003
52004
52005
52006
52007
52008
52009
52010
52011
52012
52013
52014
52015
52016
52017
52018
52019
52020
52021
52022
52023
52024
52025
52026
52027
52028
52029
52030
52031
52032
52033
52034
52035
52036
52037
52038
52039
52040
52041
52042
52043
52044
52045
52046
52047
52048
52049
52050
52051
52052
52053
52054
52055
52056
52057
52058
52059
52060
52061
52062
52063

52064
52065
52066
52067
52068
52069
52070
52071
52072
.....
52133
52134
52135
52136
52137
52138
52139
52140
52141
52142
52143
52144
52145
52146
52147
52148
52149
52150
52151
52152
52153
52154
52155
52156
52157
52158
52159
52160
.....
54095
54096
54097
54098
54099
54100
54101
54102
54103
54104
54105
54106
54107

54108
54109
54110
54111
54112
54113
54114

54115
54116
54117
54118
54119


54120
54121
54122
54123
54124
54125
54126
54127
54128
54129
54130
54131
54132
54133
54134
54135
54136
54137
54138
54139
54140
54141
54142
54143
54144
54145
54146
54147
54148
54149
54150
54151
54152
54153
54154
54155
54156
54157
54158
54159
54160
54161
54162
54163
54164
54165
54166
54167
54168
54169
54170
54171
54172
54173
54174
54175
54176
54177
54178
54179
54180
54181
54182
54183
54184
54185
54186
54187
54188
54189
54190
54191
54192
54193
54194
54195
54196
54197

54198
54199
54200
54201
54202
54203
54204
54205
54206
54207
54208
54209
54210
54211
54212
54213
54214
54215
54216
54217
54218
54219
54220
54221
54222
54223
54224
54225
54226
54227
54228
54229
54230
54231
54232
54233
54234
54235
54236
54237
54238
54239
54240
54241
54242
54243
54244
54245
54246
54247
54248
54249
54250
54251
54252
54253
54254
54255
54256
54257
54258
54259
54260
54261
54262
54263
54264
54265
54266
54267
54268
54269
54270
54271

54272
54273
54274
54275
54276
54277
54278
54279
54280
54281
54282
54283
54284
54285

54286


54287
54288
54289
54290
54291
54292
54293
54294
54295
54296
54297
54298
54299
54300
54301
54302
54303
54304
54305
54306
54307








54308
54309
54310
54311
54312
54313
54314
54315
54316
54317
54318
54319
54320
54321
54322
54323
54324
54325
54326
54327
54328
54329
54330
54331
54332
54333
54334
54335
54336
54337
54338
54339
54340
54341
54342
54343
54344
54345
54346
54347
54348
54349
54350
54351
54352
54353
54354
54355
54356





54357


























54358
54359
54360

54361
54362
54363
54364
54365
54366
54367
54368
54369
.....
54373
54374
54375
54376
54377
54378
54379
54380
54381
54382
54383
54384
54385
54386
54387
54388
54389
.....
54395
54396
54397
54398
54399
54400
54401
54402

54403
54404
54405
54406
54407
54408
54409
.....
56210
56211
56212
56213
56214
56215
56216
56217
56218
56219
56220
56221
56222
56223
56224
56225
56226
56227
56228
56229
56230
56231
56232
56233
56234
56235
56236
56237
56238
56239
56240
56241
56242
56243
56244
56245
56246
56247
56248
56249
56250
56251
56252
56253
56254
56255
56256
.....
56260
56261
56262
56263
56264
56265
56266
56267
56268
56269
56270
56271
56272
56273
56274
56275
56276
56277
56278
56279

56280
56281
56282
56283
56284
56285
56286
56287
56288
56289
56290
56291
56292
56293
56294
56295
56296
56297
56298
56299
56300
56301
56302
56303
56304
56305
.....
56307
56308
56309
56310
56311
56312
56313
56314
56315
56316
56317
56318
56319
56320
56321
56322
56323
56324
56325
56326
56327
56328
56329
56330
56331
.....
56410
56411
56412
56413
56414
56415
56416
56417
56418
56419
56420
56421
56422
56423
56424
    ServiceMethodIndex: integer;
    /// the JSON array of parameters for an the interface-based service
    // - Service member has already be retrieved from URI (so is not nil)
    ServiceParameters: PUTF8Char;
    /// the instance ID for interface-based services instance
    // - can be e.g. the client session ID for sicPerSession or the thread ID for
    // sicPerThread
    ServiceInstanceID: PtrUInt;
    /// the current execution context of an interface-based service
    // - maps to Service.fExecution[ServiceMethodIndex]
    ServiceExecution: PServiceFactoryExecution;
    /// force the interface-based service methods to return a JSON object
    // - default behavior is to follow Service.ResultAsJSONObject property value
    // (which own default is to return a more convenient JSON array)
    // - if set to TRUE, this execution context will FORCE the method to return
................................................................................
    // - vIsInFPR is used for floating point constant arguments
    ValueKindAsm: set of (vIsString, vPassedByReference, vIsObjArray, vIsInFPR);
    /// byte offset in the CPU stack of this argument
    // - may be -1 if pure register parameter with no backup on stack (x86)
    InStackOffset: integer;
    /// used to specify if the argument is passed as register
    // - contains 0 if parameter is not a register
    // - contains 1 for EAX, 2 for EDX and 3 for ECX registers for x86
    // - contains 1 for RCX, 2 for RDX, 3 for R8, and
    // 4 for R9, with a backing store on the stack for x64
    // - contains 1 for R0, 2 R1 ... 4 for R3, with a backing store on the stack for arm
    // - contains 1 for X0, 2 X1 ... 8 for X7, with a backing store on the stack for aarch64
    RegisterIdent: integer;
    /// used to specify if a floating-point argument is passed as register
    // - contains 0 for x86 (since the x87 FPU stack is used instead)
    // - contains 1 for XMM0, 2 for XMM1 ... 4 for XMM3 for x64
    // - contains 1 for D0, 2 D1 ... 8 for D7 for armhf
    // - contains 1 for V0, 2 V1 ... 8 for V7 for aarch64
    FPRegisterIdent: integer;
    /// size (in bytes) of this argument on the stack
    SizeInStack: integer;
    /// size (in bytes) of this smvv64 ordinal value
    // - e.g. depending of the associated kind of enumeration
    SizeInStorage: integer;
    /// index of the associated variable in the local array[ArgsUsedCount[]]
    // - for smdConst argument, contains -1 (no need to a local var: the value
................................................................................
    fServiceCustomAnswerHead: RawUTF8;
    fServiceCustomAnswerStatus: cardinal;
    fLastException: Exception;
    fInput: TDocVariantData;
    fOutput: TDocVariantData;
    fCurrentStep: TServiceMethodExecuteEventStep;
    procedure BeforeExecute;
    procedure RawExecute(const Instances: PPointerArray; InstancesLast: integer);
    procedure AfterExecute;
  public
    /// initialize the execution instance
    constructor Create(aMethod: PServiceMethod);
    /// finalize the execution instance
    destructor Destroy; override;
    /// allow to hook method execution
................................................................................
    // - if optInterceptInputOutput is defined in Options, then Sender.Input/Output
    // fields would contain the execution data context when Hook is called
    procedure AddInterceptor(const Hook: TServiceMethodExecuteEvent);
    /// execute the corresponding method of a given TInterfacedObject instance
    // - will retrieve a JSON array of parameters from Par
    // - will append a JSON array of results in Res, or set an Error message, or
    // a JSON object (with parameter names) in Res if ResultAsJSONObject is set
    function ExecuteJson(const Instances: array of pointer; Par: PUTF8Char;
      Res: TTextWriter; ResAsJSONObject: boolean=false): boolean;
    /// low-level direct access to the associated method information
    property Method: PServiceMethod read fMethod;
    /// low-level direct access to the current input/output parameter values
    // - you should not need to access this, but rather set
    // optInterceptInputOutput in Options, and read Input/Output content
    property Values: TPPointerDynArray read fValues;
................................................................................
    {$ifndef NOVARIANTS}
    fDocVariantOptions: TDocVariantOptions;
    {$endif}
    fFakeVTable: array of pointer;
    fFakeStub: PByteArray;
    fMethodIndexCallbackReleased: Integer;
    fMethodIndexCurrentFrameCallback: Integer;
    {$ifdef CPUAARCH64} 
    fDetectX0ResultMagic: cardinal; // alf: temporary hack for AARCH64
    {$endif}
    procedure AddMethodsFromTypeInfo(aInterface: PTypeInfo); virtual; abstract;
    function GetMethodsVirtualTable: pointer;
  public
    /// this is the main entry point to the global interface factory cache
    // - access to this method is thread-safe
    // - this method will also register the class to further retrieval
    class function Get(aInterface: PTypeInfo): TInterfaceFactory; overload;
................................................................................
  /// server-side service provider uses this to store one internal instance
  // - used by TServiceFactoryServer in sicClientDriven, sicPerSession,
  // sicPerUser or sicPerGroup mode
  TServiceFactoryServerInstance = {$ifndef ISDELPHI2010}object{$else}record{$endif}
  public
    /// the internal Instance ID, as remotely sent in "id":1
    // - is set to 0 when an entry in the array is free
    InstanceID: PtrUInt;
    /// GetTickCount64() time stamp corresponding to the last access of
    // this instance
    LastAccess64: Int64;
    /// the implementation instance itself
    Instance: TInterfacedObject;
    /// used to release the implementation instance
    // - direct FreeAndNil(Instance) may lead to A/V if self has been assigned
................................................................................
    inc(j,FieldCount);
  end;
  assert(n-1=fRowCount);
  // recalcultate Bits[]
  FillcharFast(Bits,(fRowCount shr 3)+1,0);
  for i := 0 to nSet-1 do
    SetBit(Bits,i); // slow but accurate
  {$ifdef FPC}
  Finalize(oldIDColumn); // alf: to circumvent FPC issues
  Finalize(oldResults);
  {$endif}
end;

function TSQLTable.IDColumnHide: boolean;
var FID,R,F: integer;
    S,D1,D2: PPUTF8Char;
begin
  // 1. check if possible
................................................................................

{$endif USETYPEINFO}


type
  TIntfFlag = (ifHasGuid,ifDispInterface,ifDispatch{$ifdef FPC},ifHasStrGUID{$endif});
  TIntfFlags = set of TIntfFlag;

  {$ifdef FPC}
  {$PACKRECORDS C}
  {$endif}

  PInterfaceTypeData = ^TInterfaceTypeData;
  TInterfaceTypeData =
    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif} record
    IntfParent: PPTypeInfo; // ancestor
    IntfFlags: TIntfFlags;
    IntfGuid: TGUID;
................................................................................
    RawIntfParent: PTypeInfo;
    RawIntfFlags : TIntfFlagsBase;
    IID: TGUID;
    RawIntfUnit: ShortString;
    IIDStr: ShortString;
  end;
  {$endif}

  {$ifdef FPC}
  {$PACKRECORDS DEFAULT}
  {$endif}


  TMethodKind = (mkProcedure, mkFunction, mkConstructor, mkDestructor,
    mkClassProcedure, mkClassFunction, { Obsolete } mkSafeProcedure, mkSafeFunction);

  TIntfMethodEntryTail =
    {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif} record
................................................................................
      result := sftUnknown;
      exit;
    end;
  end;
end;

function TTypeInfo.FloatType: TFloatType;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
var
  td: PTypeData;
{$endif}
begin
  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  td := GetTypeData(@Self);
  result := TFloatType(PByte(td)^);
  {$else}
  result := TFloatType(PByte(@Name[ord(Name[0])+1])^);
  {$endif}
end;

function TTypeInfo.OrdType: TOrdType;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
var
  td: PTypeData;
{$endif}
begin
  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  td := GetTypeData(@Self);
  result := TOrdType(PByte(td)^);
  {$else}
  result := TOrdType(PByte(@Name[ord(Name[0])+1])^);
  {$endif}
end;

function TTypeInfo.SetEnumType: PEnumType;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
var p: pointer;
begin
  if (@self=nil) or (Kind<>tkSet) then
    result := nil else begin
    p := pointer(GetTypeData(@Self));
    inc(p,sizeof(TOrdType));
    p := AlignToPtr(p);
    result := PPTypeInfo(PPointer(p)^)^.EnumBaseType;
  end;
{$else}
begin
  if (@self=nil) or (Kind<>tkSet) then
................................................................................
begin
  if @self=nil then
    result := 0 else
    DynArrayTypeInfoToRecordInfo(@self,@result);
end;

function TTypeInfo.AnsiStringCodePage: integer;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
var
  td: PTypeData;
{$endif}
begin
  {$ifdef HASCODEPAGE}
  if @self=TypeInfo(TSQLRawBlob) then
    result := CP_SQLRAWBLOB else
    if Kind in [{$ifdef FPC}tkAString,{$endif} tkLString] then
    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
    begin
      td := GetTypeData(@Self);
      result := PWORD(td)^;
    end else
    {$else}
      result := PWord(@Name[ord(Name[0])+1])^ else // from RTTI
    {$endif}
  {$else}
  if @self=TypeInfo(RawUTF8) then
    result := CP_UTF8 else
  if @self=TypeInfo(WinAnsiString) then
    result := CODEPAGE_US else
  if @self=TypeInfo(RawUnicode) then
    result := CP_UTF16 else
................................................................................
  if (@self=TypeInfo(AnsiString)) or IdemPropName(Name,'TCaption') then
    result := 0 else
  {$endif}
    result := CP_UTF8; // default is UTF-8
end;

function TTypeInfo.InterfaceGUID: PGUID;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
var
  td:PTypeData;
{$endif}
begin
  if (@self=nil) or (Kind<>tkInterface) then result := nil else
  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  begin
    td := GetTypeData(@Self);
    result := @td^.GUID;

  end;
  {$else}
    result := @PInterfaceTypeData(@Name[ord(Name[0])+1])^.IntfGuid;
  {$endif}
end;

function TTypeInfo.InterfaceUnitName: PShortString;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
var
  td: PTypeData;
{$endif}
begin
  if (@self=nil) or (Kind<>tkInterface) then
    result := @NULL_SHORTSTRING else
    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
    begin
      td := GetTypeData(@Self);
      result := @td^.IntfUnit;
    end;
    {$else}
      result := @PInterfaceTypeData(@Name[ord(Name[0])+1])^.IntfUnit;
    {$endif}
end;

function TTypeInfo.InterfaceAncestor: PTypeInfo;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
var
  td: PTypeData;
{$endif}
begin
  if (@self=nil) or (Kind<>tkInterface) then
    result := nil else
    begin
      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
      td := GetTypeData(@Self);
      with td^ do
      {$else}
      with PInterfaceTypeData(@Name[ord(Name[0])+1])^ do
      {$endif}
      if IntfParent=nil then
        result := nil else
          result := mORMot.PTypeInfo(IntfParent{$ifndef FPC}^{$endif});
    end;
end;

procedure TTypeInfo.InterfaceAncestors(out Ancestors: PTypeInfoDynArray;
  OnlyImplementedBy: TInterfacedObjectClass;
  out AncestorsImplementedEntry: TPointerDynArray);
var n: integer;
    nfo: PTypeInfo;
    typ: PInterfaceTypeData;
    entry: pointer;
begin
  if (@self=nil) or (Kind<>tkInterface) then
    exit;
  n := 0;
  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  typ := PInterfaceTypeData(GetTypeData(@Self));
  {$else}
  typ := @Name[ord(Name[0])+1];
  {$endif}
  repeat
    if typ^.IntfParent=nil then
      exit;
    nfo := typ^.IntfParent{$ifndef FPC}^{$endif};
    if nfo=TypeInfo(IInterface) then
      exit;
    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
    typ := PInterfaceTypeData(GetTypeData(@nfo));
    {$else}
    typ := @nfo^.Name[ord(nfo^.Name[0])+1];
    {$endif}
    if ifHasGuid in typ^.IntfFlags then begin
      if OnlyImplementedBy<>nil then begin
        entry := OnlyImplementedBy.GetInterfaceEntry(typ^.IntfGuid);
        if entry=nil then
          continue;
        Setlength(AncestorsImplementedEntry,n+1);
        AncestorsImplementedEntry[n] := entry;
................................................................................
  if n=0 then
    exit;
  SetLength(Objects,n*2+1);
  SetLength(ObjectsClass,n*2+1);
  Objects[0] := self;
  ObjectsClass[0] := PSQLRecordClass(self)^;
  SetLength(fFill.fTableMapRecordManyInstances,n);  // fFill.UnMap will release memory
  aSQLWhere := '';  // alf: to circumvent FPC issues
  aSQLFields := '';
  aSQLFrom := '';
  for f := 0 to n-1 do begin
    M := TSQLRecordMany(Props.ManyFields[f].GetInstance(self));
    if M=nil then
      raise EORMException.CreateUTF8('%.Create should have created %:% for EnginePrepareMany',
        [self,Props.ManyFields[f].Name,Props.ManyFields[f].ObjectClass]);
    fFill.fTableMapRecordManyInstances[f] := M;
    Objects[f*2+1] := M;
................................................................................
    ValidateRest: TSynValidateRest absolute Validate;
    wasTSynValidateRest: boolean;
begin
  result := '';
  if (self=nil) or IsZero(aFields) then
    // avoid GPF and handle case if no field was selected
    exit;
  Value := '';  // alf: to circumvent FPC issues
  with RecordProps do
  if Filters<>nil then
  for f := 0 to Fields.Count-1 do
  if Fields.List[f].SQLFieldType in COPIABLE_FIELDS then begin
    for i := 0 to length(Filters[f])-1 do begin
      Validate := TSynValidate(Filters[f,i]);
      if Validate.InheritsFrom(TSynValidate) then begin
................................................................................
  SetString(call.InBody,P,PtrInt(input^.cbData)-(P-input^.lpData));
  call.RestAccessRights := @SUPERVISOR_ACCESS_RIGHTS;
  // note: it's up to URI overridden method to implement access rights
  URI(call);
  Res.Magic := MAGIC_SYN;
  Res.Status := call.OutStatus;
  Res.InternalState := call.OutInternalState;
  {$ifdef FPC} // alf: to circumvent FPC issues
  ResStr := '';
  SetLength(ResStr,sizeof(Res)+Length(call.OutHead)+1+Length(call.OutBody));
  P := pointer(ResStr);
  System.Move(Pointer(@Res)^,P^,sizeof(Res));
  Inc(P,sizeof(Res));
  System.Move(pointer(call.OutHead)^,P^,Length(call.OutHead));
  Inc(P,Length(call.OutHead));
  PByte(P)^ := 1;
  Inc(P);
  System.Move(pointer(call.OutBody)^,P^,Length(call.OutBody));
  {$else}
  SetString(ResStr,PAnsiChar(@Res),sizeof(Res));
  ResStr := ResStr+call.OutHead+#1+call.OutBody;
  {$endif FPC}
  Data.dwData := fServerWindow;
  Data.cbData := length(ResStr);
  Data.lpData := pointer(ResStr);
  SendMessage(Msg.From,WM_COPYDATA,fServerWindow,PtrInt(@Data));
end;

function TSQLRestServer.CloseServerNamedPipe: boolean;
................................................................................
  if aStoredClass=nil then
    fStoredClass := TSQLMonitorUsage else
    fStoredClass := aStoredClass;
  fStorage := aStorage;
  for g := low(fStoredCache) to high(fStoredCache) do
    fStoredCache[g] := fStoredClass.Create;
  fProcessID := aProcessID;
  {$ifdef WITHLOG}
  fLog := fStorage.LogFamily;
  {$endif}
  inherited Create;
end;

destructor TSynMonitorUsageRest.Destroy;
var g: TSynMonitorUsageGranularity;
begin
  inherited Destroy; // would save pending changes
................................................................................
  end;
  if WhereValue[1]='"' then
    UnQuoteSQLStringVar(pointer(WhereValue),WhereValueString) else
    WhereValueString := WhereValue;
  // search indexes, then apply updates
  Where := TList.Create;
  StorageLock(true);
  SetValueJson := ''; // alf: to circumvent FPC issues
  try
    // find matching Where[]
    if FindWhereEqual(WhereFieldIndex,WhereValueString,AddIntegerDynArrayEvent,Where,0,0)=0 then
      exit; // Where.Count=0 -> nothing to update
    // check that all records can be updated
    for i := 0 to Where.Count-1 do
      if not RecordCanBeUpdated(fStoredClass,
................................................................................
  {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): longint;
{$else}
function TSQLRecordInterfaced.QueryInterface(const IID: TGUID; out Obj): HResult;
{$endif}
begin
  if GetInterface(IID,Obj) then
    result := 0 else
    result := {$ifdef FPC}longint{$endif}(E_NOINTERFACE);
end;

function TSQLRecordInterfaced._AddRef: {$ifdef FPC}longint{$else}integer{$endif};
begin
  result := InterlockedIncrement(fRefCount);
end;

................................................................................

function TSynValidateUniqueFields.Process(aFieldIndex: integer;
  const Value: RawUTF8; var ErrorMsg: string): boolean;
var where: RawUTF8;
    i: integer;
    aID: TID;
begin
  where := ''; // alf: to circumvent FPC issues
  if (fProcessRest=nil) or (fProcessRec=nil) or (fFieldNames=nil) then
    result := true else begin
    for i := 0 to high(fFieldNames) do begin
      if where<>'' then
        where := where+' AND ';
      where := where+fFieldNames[i]+'=:('+
        QuotedStr(fProcessRec.GetFieldValue(fFieldNames[i]),'''')+'):';
................................................................................

  // QueryInterface, _AddRef and _Release methods are hard-coded
  RESERVED_VTABLE_SLOTS = 3;

// see http://docwiki.embarcadero.com/RADStudio/en/Program_Control

{$ifdef CPU64}

  // maximum stack size at method execution must match .PARAMS 64 (minus 4 regs)
  MAX_EXECSTACK = 60*8;
{$else}
  // maximum stack size at method execution
  {$ifdef CPUARM}
  MAX_EXECSTACK = 60*4;
  {$else}
  MAX_EXECSTACK = 1024;
  {$endif}
{$endif CPU64}

{$ifdef CPUX64}
  {$ifdef LINUX}
  REGRDI = 1;
  REGRSI = 2;
  REGRDX = 3;
  REGRCX = 4;
  REGR8 = 5;
  REGR9 = 6;
  PARAMREG_FIRST = REGRDI;
  {$else}
  REGRCX = 1;
  REGRDX = 2;
  REGR8 = 3;
  REGR9 = 4;
  PARAMREG_FIRST = REGRCX;
  {$endif}

  PARAMREG_LAST = REGR9;

  REGXMM0 = 1;
  REGXMM1 = 2;
  REGXMM2 = 3;
  REGXMM3 = 4;
  {$ifdef LINUX}
  REGXMM4 = 5;
  REGXMM5 = 6;
  REGXMM6 = 7;
  REGXMM7 = 8;
  FPREG_LAST = REGXMM7;
  {$else}
  FPREG_LAST = REGXMM3;
  {$endif}

  FPREG_FIRST = REGXMM0;
{$endif CPUX64}







{$ifdef CPUX86}
  REGEAX = 1;
  REGEDX = 2;
  REGECX = 3;
  PARAMREG_FIRST = REGEAX;
  PARAMREG_LAST = REGECX;
  FPREG_FIRST = 0;
  FPREG_LAST = 0;
{$endif CPUX86}

{$ifdef UNIX}
{$ifdef CPUARM}
  // 32-bit param register
  REGR0 = 1;
  REGR1 = 2;
  REGR2 = 3;
  REGR3 = 4;
  // 64-bit fp register
  REGD0 = 1;
  REGD1 = 2;
  REGD2 = 3;
  REGD3 = 4;
  REGD4 = 5;
  REGD5 = 6;
  REGD6 = 7;
  REGD7 = 8;
  PARAMREG_FIRST = REGR0;
  PARAMREG_LAST = REGR3;
  FPREG_FIRST = REGD0;
  FPREG_LAST = REGD7;
{$endif CPUARM}

{$ifdef CPUAARCH64}
  REGX0 = 1;
  REGX1 = 2;
  REGX2 = 3;
  REGX3 = 4;
  REGX4 = 5;
  REGX5 = 6;
  REGX6 = 7;
  REGX7 = 8;
  REGD0 = 1; // REGV0
  REGD1 = 2; // REGV1
  REGD2 = 3; // REGV2
  REGD3 = 4; // REGV3
  REGD4 = 5; // REGV4
  REGD5 = 6; // REGV5
  REGD6 = 7; // REGV6
  REGD7 = 8; // REGV7
  PARAMREG_FIRST = REGX0;
  PARAMREG_LAST = REGX7;
  FPREG_FIRST = REGD0;
  FPREG_LAST = REGD7;
{$endif CPUAARCH64}
{$endif UNIX}

  PTRSIZ = sizeof(Pointer);
  PTRSHR = {$ifdef CPU64}3{$else}2{$endif};

  STACKOFFSET_NONE = -1;

  // ordinal values are stored within 64 bit buffer, and records in a RawUTF8
  CONST_ARGS_TO_VAR: array[TServiceMethodValueType] of TServiceMethodValueVar = (
    smvvNone, smvvSelf, smvv64, smvv64, smvv64, smvv64, smvv64, smvv64, smvv64,
    smvv64, smvv64,
    smvvRawUTF8, smvvString, smvvRawUTF8, smvvWideString, smvvRecord,
    {$ifndef NOVARIANTS}smvvRecord,{$endif} smvvObject, smvvRawUTF8,
    smvvDynArray, smvvInterface);

  // always aligned to 8 bytes boundaries for 64 bit
  CONST_ARGS_IN_STACK_SIZE: array[TServiceMethodValueType] of Cardinal = (
     0,  PTRSIZ,PTRSIZ, PTRSIZ,PTRSIZ,PTRSIZ, PTRSIZ,    8,     8,      8,
 // None, Self, Boolean, Enum, Set,  Integer, Cardinal, Int64, Double, DateTime,
     8,       PTRSIZ,  PTRSIZ, PTRSIZ,        PTRSIZ,     PTRSIZ,
 // Currency, RawUTF8, String, RawByteString, WideString, Record,
    {$ifndef NOVARIANTS}PTRSIZ,{$endif} // Variant
    PTRSIZ, PTRSIZ,  PTRSIZ, PTRSIZ);
................................................................................
  CONST_PSEUDO_RESULT_NAME: string[6] = 'Result';
  CONST_PSEUDO_SELF_NAME: string[4] = 'Self';
  CONST_INTEGER_NAME: string[7] = 'Integer';

type
  /// map the stack memory layout at TInterfacedObjectFake.FakeCall()
  TFakeCallStack = packed record
    {$ifdef CPUX86}
    EDX, ECX, MethodIndex, EBP, Ret: Cardinal;

    {$else}
    {$ifdef Linux}
    ParamRegs: packed array[PARAMREG_FIRST..PARAMREG_LAST] of pointer;
    {$endif}
    FPRegs: packed array[FPREG_FIRST..FPREG_LAST] of double;
    MethodIndex: PtrUInt;
    Frame: pointer;

    Ret: pointer;
    {$ifndef Linux}
    ParamRegs: packed array[PARAMREG_FIRST..PARAMREG_LAST] of pointer;
    {$endif}

    {$endif}
    {$ifdef CPUARM}
    // alf: on ARM, there is more on the stack than you would expect
    DummyStack: packed array[0..9] of pointer;
    {$endif}

    {$ifdef CPUAARCH64}
    // alf: on AArch64, there is more on the stack than you would expect
    DummyStack: pointer;
    {$endif}
    Stack: packed array[word] of byte;
  end;

  /// instances of this class will emulate a given interface
  // - as used by TInterfaceFactory.CreateFakeInstance
  TInterfacedObjectFake = class(TInterfacedObjectFromFactory)
  protected
    fVTable: PPointerArray;
    function FakeCall(var aCall: TFakeCallStack): Int64;
    {$ifdef FPC}
    {$ifdef CPUARM}
    // on ARM, the FakeStub needs to be here, otherwise the FakeCall cannot be found by the FakeStub
    procedure ArmFakeStub;
    {$endif}
    {$ifdef CPUAARCH64}
    // on Aarch64, the FakeStub needs to be here, otherwise the FakeCall cannot be found by the FakeStub
    procedure AArch64FakeStub;
    {$endif}
    function FakeQueryInterface(
      {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID;
      out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
    function Fake_AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
    function Fake_Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
    {$else}
    function FakeQueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
................................................................................

function TInterfacedObjectFake.SelfFromInterface: TInterfacedObjectFake;
{$ifdef PUREPASCAL}
begin
  result := pointer(PtrInt(self)-PtrInt(@TInterfacedObjectFake(nil).fVTable));
end;
{$else}
{$ifdef CPUINTEL}
asm
  sub eax,TInterfacedObjectFake.fVTable
end;
{$endif CPUINTEL}
{$endif}

function TInterfacedObjectFake.Fake_AddRef: {$ifdef FPC}longint{$else}integer{$endif};
begin
  result := SelfFromInterface._AddRef;
end;

................................................................................
  if IsEqualGUID(IID,fFactory.fInterfaceIID) then begin
    pointer(Obj) := @fVTable;
    _AddRef;
    result := NOERROR;
  end else
  if GetInterface(IID,Obj) then
    result := NOERROR else
    result := {$ifdef FPC}longint{$endif}(E_NOINTERFACE);
end;

procedure TInterfacedObjectFake.Get(out Obj);
begin
  pointer(Obj) := @fVTable;
  _AddRef;
end;
................................................................................
  if P<>nil then begin
    if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']);
    if P^=',' then inc(P);
  end;
end;

function TInterfacedObjectFake.FakeCall(var aCall: TFakeCallStack): Int64;





var method: ^TServiceMethod;
procedure RaiseError(const Format: RawUTF8; const Args: array of const);
var msg: RawUTF8;
begin
  msg := FormatUTF8(Format,Args);
  raise EInterfaceFactoryException.CreateUTF8('%.FakeCall(%.%) failed: %',
    [self,fFactory.fInterfaceTypeInfo^.Name,method^.URI,msg]);
................................................................................
    if ifoJsonAsExtended in fOptions then
      include(Params.fCustomOptions,twoForceJSONExtended) else
      include(Params.fCustomOptions,twoForceJSONStandard); // e.g. for AJAX
    FillcharFast(I64s,method^.ArgsUsedCount[smvv64]*sizeof(Int64),0);
    for arg := 1 to high(method^.Args) do
    with method^.Args[arg] do
    if ValueType>smvSelf then begin
      V := nil;
      {$ifndef CPUX86} // x64, arm, aarch64
      if (vIsInFPR in ValueKindAsm) and (FPRegisterIdent>0) then
        V := Pointer((PtrUInt(@aCall.FPRegs[FPREG_FIRST])+Sizeof(Double)*(FPRegisterIdent-1)));
      if (v=nil) and (RegisterIdent>0) then
        V := Pointer((PtrUInt(@aCall.ParamRegs[PARAMREG_FIRST])+Sizeof(pointer)*(RegisterIdent-1)));
      {$endif}
      {$ifndef CPUAARCH64} // on aarch64, reference result can be in PARAMREG_FIRST
      if RegisterIdent=PARAMREG_FIRST then
         RaiseError('unexpected self',[]);
      {$endif}
      {$ifdef CPUX86}
      case RegisterIdent of
        REGEAX: RaiseError('unexpected self',[]);
      REGEDX: V := @aCall.EDX;
      REGECX: V := @aCall.ECX;
      else
      {$endif}

      if V=nil then begin
        if (SizeInStack>0) and (InStackOffset<>STACKOFFSET_NONE) then
          V := @aCall.Stack[InStackOffset] else 
          V := @I64s[IndexVar]; // for results in CPU
      end;
      {$ifdef CPUX86}
      end;
      {$endif}
      if vPassedByReference in ValueKindAsm then
        V := PPointer(V)^;
      case ValueType of
      smvDynArray:
        DynArrays[IndexVar].Init(ArgTypeInfo,V^);
      end;
      Value[arg] := V;
................................................................................
    if method^.ArgsOutputValuesCount>0 then
      RaiseError('method returned value, but ResArray=''''',[]);
end;
begin
  // WELCOME ABOARD: you just landed in TInterfacedObjectFake.FakeCall() !
  // if your debugger reached here, you are executing a "fake" interface
  // forged to call a remote SOA server or mock/stub an interface

  self := SelfFromInterface;
  {$ifdef CPUAARCH64}
  // alf: on aarch64, the self is sometimes only available in x1, when we have a result pointer !
  // try to detect this ... although not very elegant, but I do not yet know how else to do this
  if (fFactory=nil) or (fFactory.fDetectX0ResultMagic<>$AAAAAAAA) then begin
    // aha, we have a reference result, placed in X0, so self is in X1 !!
    self := aCall.ParamRegs[REGX1];
    self := SelfFromInterface;
  end;
  {$endif}
  if aCall.MethodIndex>=fFactory.fMethodsCount then
    raise EInterfaceFactoryException.CreateUTF8(
      '%.FakeCall(%.%) failed: out of range method %>=%',
      [self,fFactory.fInterfaceTypeInfo^.Name,aCall.MethodIndex,fFactory.fMethodsCount]);
  method := @fFactory.fMethods[aCall.MethodIndex];
  if not Assigned(fInvoke)then
    RaiseError('fInvoke=nil',[]);
  result := 0;
  resultType := smvNone;
  InternalProcess; // use an inner proc to ensure direct fld/fild FPU ops
  case resultType of // al/ax/eax/eax:edx/rax already in result
  {$ifdef CPUINTEL}
  {$ifdef CPU64}
  smvDouble,smvDateTime: aCall.FPRegs[REGXMM0] := PDouble(@result)^;
  {$else}
  smvDouble,smvDateTime: asm fld  qword ptr [result] end;  // in st(0)
  smvCurrency:           asm fild qword ptr [result] end;  // in st(0)
  {$endif}
  {$endif CPUINTEL}
  {$ifdef CPUARM}
  smvDouble,smvDateTime: aCall.FPRegs[REGD0] := PDouble(@result)^;
  {$endif CPUARM}
  {$ifdef CPUAARCH64}
  smvDouble,smvDateTime: aCall.FPRegs[REGD0] := PDouble(@result)^;
  {$endif CPUARM}
  end;
end;


procedure TInterfacedObjectFake.InterfaceWrite(W: TJSONSerializer;
  const aMethod: TServiceMethod; const aParamInfo: TServiceMethodArgument;
  aParamValue: Pointer);
begin
  raise EInterfaceFactoryException.CreateUTF8('%: unhandled %.%(%: %) argument',
    [self,fFactory.fInterfaceTypeInfo^.Name,aMethod.URI,
................................................................................
class function TInterfaceFactory.GetUsedInterfaces: TObjectList;
begin
  result := InterfaceFactoryCache;
end;

constructor TInterfaceFactory.Create(aInterface: PTypeInfo);
var m,a,reg: integer;
    {$ifdef Linux}
    fpreg: integer;
    {$endif}
    WR: TTextWriter;
    C: TClass;
    ErrorMsg: RawUTF8;
    {$ifdef CPUARM}
    resultIsREGR1: boolean;
    {$endif}
    {$ifdef CPUAARCH64}
    resultIsREGX0: boolean;
    {$endif}
    {$ifdef CPUX64}
    {$ifdef Linux}
    resultIsRSI: boolean;
    {$else}
    resultIsRDX: boolean;
    {$endif}
    {$endif}
    {$ifdef CPUX86}
    offs: integer;
   {$endif}
label error;
begin
  if aInterface=nil then
    raise EInterfaceFactoryException.CreateUTF8('%.Create(nil)',[self]);
  if aInterface^.Kind<>tkInterface then
    raise EInterfaceFactoryException.CreateUTF8(
      '%.Create(%): % is not an interface',[self,aInterface^.Name,aInterface^.Name]);
  {$ifndef NOVARIANTS}
  fDocVariantOptions := JSON_OPTIONS_FAST;
  {$endif}
  {$ifdef CPUAARCH64}
  fDetectX0ResultMagic := $AAAAAAAA; // alf: see comment above
  {$endif}
  fInterfaceTypeInfo := aInterface;
  fInterfaceIID := aInterface^.InterfaceGUID^;
  if IsNullGUID(fInterfaceIID) then
    raise EInterfaceFactoryException.CreateUTF8(
      '%.Create: % has no GUID',[self,aInterface^.Name]);
  fInterfaceName := ToUTF8(fInterfaceTypeInfo^.Name);
  // retrieve all interface methods (recursively including ancestors)
................................................................................
            fMethodIndexCallbackReleased := m;
      end;
  end;
  // compute asm low-level layout of the parameters for each method
  for m := 0 to fMethodsCount-1 do
  with fMethods[m] do begin
    // prepare stack and register layout
    reg := PARAMREG_FIRST;
    {$ifdef Linux}
    fpreg := FPREG_FIRST;
    {$endif}
    {$ifdef CPUX64}
      {$ifdef Linux}
      resultIsRSI := (ArgsResultIndex>=0) and
        (Args[ArgsResultIndex].ValueType in CONST_ARGS_RESULT_BY_REF);
      {$else}
      resultIsRDX := (ArgsResultIndex>=0) and
        (Args[ArgsResultIndex].ValueType in CONST_ARGS_RESULT_BY_REF);
    {$endif}
    {$endif CPUX64}
    {$ifdef CPUARM}
    resultIsREGR1 := (ArgsResultIndex>=0) and
      (Args[ArgsResultIndex].ValueType in CONST_ARGS_RESULT_BY_REF);
    {$endif CPUARM}
    {$ifdef CPUAARCH64}
    resultIsREGX0 := (ArgsResultIndex>=0) and
      (Args[ArgsResultIndex].ValueType in CONST_ARGS_RESULT_BY_REF);
    // alf: self is now in REGX1 -  not sure if correct
    {$endif CPUARM}
    for a := 0 to high(Args) do
    with Args[a] do begin
      RegisterIdent := 0;
      FPRegisterIdent := 0;
      ValueVar := CONST_ARGS_TO_VAR[ValueType];
      IndexVar := ArgsUsedCount[ValueVar];
      inc(ArgsUsedCount[ValueVar]);
      include(ArgsUsed,ValueType);
      if (ValueType in [smvRecord{$ifndef NOVARIANTS},smvVariant{$endif}
          {$ifdef FPC},smvDynArray{$endif}]) or
         (ValueDirection in [smdVar,smdOut]) or
................................................................................
        Include(ValueKindAsm,vPassedByReference);
      case ValueType of
      smvRawUTF8..smvWideString:
        Include(ValueKindAsm,vIsString);
      smvDynArray:
        if ObjArraySerializers.Find(ArgTypeInfo)<>nil then
          Include(ValueKindAsm,vIsObjArray);
      {$ifndef CPUX86}
      smvDouble,smvDateTime:
           if (reg<=FPREG_LAST) and not (vPassedByReference in ValueKindAsm) then
             Include(ValueKindAsm,vIsInFPR);
      {$endif}
      end;
      case ValueType of
        smvBoolean:
          SizeInStorage := 1;
        smvInteger, smvCardinal:
          SizeInStorage := 4;
................................................................................
            SizeInStorage := PTRSIZ; // handle only records when passed by ref
        else
          SizeInStorage := PTRSIZ;
      end;
      if ValueDirection=smdResult then begin
        if not(ValueType in CONST_ARGS_RESULT_BY_REF) then
          continue; // ordinal/real/class results are returned in CPU/FPU registers
        {$ifdef CPUX64}
        InStackOffset := STACKOFFSET_NONE;
        {$ifdef Linux}
        RegisterIdent := REGRSI; // the result pointer is in rsi
        {$else}
        RegisterIdent := REGRDX; // the result pointer is in rdx
        {$endif}
        continue;
        {$endif}
        {$ifdef CPUARM}
        InStackOffset := STACKOFFSET_NONE;
        RegisterIdent := REGR1; // the result pointer is in r1
        continue;
        {$endif}
        {$ifdef CPUAARCH64} 
        // alf: FPC uses x0 to hold result pointer and self is stored in x1
        // -> very different from all other calling methods (fixme?)
        InStackOffset := STACKOFFSET_NONE;
        RegisterIdent := REGX0; // the result pointer is in x1
        continue;
        {$endif}
      end;
      {$ifdef CPU32}
      if ValueDirection=smdConst then
        SizeInStack := CONST_ARGS_IN_STACK_SIZE[ValueType] else
      {$endif}
        SizeInStack := PTRSIZ;
      if (reg>PARAMREG_LAST) or (SizeInStack<>PTRSIZ)
        // alf: TODO: fix smvDynArray as expected by fpc\compiler\i386\cpupara.pas
        {$ifdef FPC}or ((ValueType in [smvRecord,smvDynArray]) and
          not (vPassedByReference in ValueKindAsm)){$endif} then begin
        InStackOffset := ArgsSizeInStack;
        inc(ArgsSizeInStack,SizeInStack);
      end else begin
        InStackOffset := STACKOFFSET_NONE;
        {$ifdef CPUX64}
        {$ifdef Linux}
          if resultIsRSI and (reg=REGRSI) then
            inc(reg); // RSI is reserved for function result pointer
        {$else}
          if resultIsRDX and (reg=REGRDX) then
            inc(reg); // RDX is reserved for function result pointer
        {$endif Linux}
        {$endif CPUX64}
        {$ifdef CPUARM}
        if resultIsREGR1 and (reg=REGR1) then
          inc(reg); // REGR1 is reserved for function result pointer
        {$endif}
        {$ifdef CPUAARCH64}
        if resultIsREGX0 and (reg=REGX0) then
        begin
          inc(reg); // REGX0 is reserved for function result pointer
          // alf: not sure if this is needed (fixme?)
          inc(reg); // REGX1 is reserved for self
        end;
        {$endif}
        if vIsInFPR in ValueKindAsm then begin
          {$ifdef Linux}
          FPRegisterIdent := fpreg;
          inc(fpreg);
          {$else}
          FPRegisterIdent := reg;
        {$endif}
        end
        else begin
          {$ifdef CPUARM}
          // on ARM, ordinals>PTRSIZ are also placed in the normal registers
          // but they must be aligned on a even boundary
          if (SizeInStack>PTRSIZ) and ((reg and 1)=0) then
            inc(reg);
          // check if we are still able, after this increment, to put the parameter in the registers
          if (((PARAMREG_LAST-reg+1)*PTRSIZ)<SizeInStack) then begin
            // no space, put it on stack
            InStackOffset := ArgsSizeInStack;
            inc(ArgsSizeInStack,SizeInStack);
            // all other parameters following the current one, must also be placed on stack
            reg := PARAMREG_LAST+1;
            continue;
          end;
          {$endif}
          RegisterIdent := reg;
          {$ifdef Linux}
          inc(reg);
          {$ifdef CPUARM}
          // on ARM, ordinals>PTRSIZ are also placed in the normal registers
          // so we need double the registers
          if (SizeInStack>PTRSIZ) then
             inc(reg,(SizeInStack shr PTRSHR)-1);
          {$endif}
          {$endif}
        end;
        {$ifndef Linux}
        inc(reg);
        {$endif}
      end;
    end;
    if ArgsSizeInStack>MAX_EXECSTACK then
      raise EInterfaceFactoryException.CreateUTF8(
        '%.Create: Stack size % > % for %.% method',
        [self,ArgsSizeInStack,MAX_EXECSTACK,fInterfaceTypeInfo^.Name,URI]);
    {$ifdef CPUX86}
    // pascal/register convention are passed left-to-right -> reverse order
    offs := ArgsSizeInStack;
    for a := 0 to high(Args) do
    with Args[a] do
      if InStackOffset>=0 then begin
        dec(offs,SizeInStack);
        InStackOffset := offs;
................................................................................
    result := GetMethodName(aMethodIndex);
    if result = '' then
      result := fInterfaceName else
      result := fInterfaceName+'.'+result;
  end;
end;

{ low-level ASM for TInterfaceFactory.GetMethodsVirtualTable
  - all ARM, AARCH64 and Linux64 code below was provided by ALF! Thanks! :)  }
{$ifdef FPC}
{$ifdef CPUARM}
procedure TInterfacedObjectFake.ArmFakeStub;
var smetndx: pointer;
    sd7, sd6, sd5, sd4, sd3, sd2, sd1, sd0: double;
    sr3,sr2,sr1,sr0: pointer;
asm
  // get method index
  str  v1,smetndx
  // store registers
  vstr d0,sd0
  vstr d1,sd1
  vstr d2,sd2
  vstr d3,sd3
  vstr d4,sd4
  vstr d5,sd5
  vstr d6,sd6
  vstr d7,sd7
  str r0,sr0
  str r1,sr1
  str r2,sr2
  str r3,sr3
  // TFakeCallStack address as 2nd parameter
  // there is no lea equivalent instruction for ARM (AFAIK), so this is calculated by hand (by looking at assembler)
  sub r1, fp, #128
  // branch to the FakeCall function
  bl FakeCall
  // FakeCall should set Int64 result in method result, and float in aCall.FPRegs["sd0"]
  vstr d0,sd0
end;
{$endif}
{$ifdef CPUAARCH64}
procedure TInterfacedObjectFake.AArch64FakeStub;
var sx0, sx1, sx2, sx3, sx4, sx5, sx6, sx7: pointer;
    sd0, sd1, sd2, sd3, sd4, sd5, sd6, sd7: double;
    smetndx:pointer;
asm
  // get method index
  str  x9,smetndx
  // store registers
  str d0,sd0
  str d1,sd1
  str d2,sd2
  str d3,sd3
  str d4,sd4
  str d5,sd5
  str d6,sd6
  str d7,sd7
  str x0,sx0
  str x1,sx1
  str x2,sx2
  str x3,sx3
  str x4,sx4
  str x5,sx5
  str x6,sx6
  str x7,sx7
  // TFakeCallStack address as 2nd parameter
  // sx0 is at the stack pointer !
  // local variables are stored in reverse on the stack
  add x1, sp, #0
  // branch to the FakeCall function
  bl FakeCall
  // FakeCall should set Int64 result in method result, and float in aCall.FPRegs["sd0"]
  str d0,sd0
end;
{$endif}
{$endif}

{$ifdef CPUX64}
procedure x64FakeStub;
var
  smetndx,
  {$ifdef Linux}
  sxmm7, sxmm6, sxmm5, sxmm4,
  {$endif}
  sxmm3, sxmm2, sxmm1, sxmm0: pointer;
  {$ifdef Linux}
  sr9, sr8, srcx, srdx, srsi, srdi: pointer;
  {$endif}
asm // mov ax,{MethodIndex}; jmp x64FakeStub
  {$ifndef FPC}

  // FakeCall(self: TInterfacedObjectFake; var aCall: TFakeCallStack): Int64
  // So, make space for two variables (+shadow space)
  // adds $50 to stack, so rcx .. at rpb+$10+$50 = rpb+$60
  .params 2
  {$endif}
  and rax,$ffff
  movlpd sxmm0,xmm0
  movlpd sxmm1,xmm1
  movlpd sxmm2,xmm2
  movlpd sxmm3,xmm3
  {$ifdef LINUX}

  movlpd sxmm4,xmm4
  movlpd sxmm5,xmm5
  movlpd sxmm6,xmm6
  movlpd sxmm7,xmm7
  mov sr9,r9
  mov sr8,r8
  mov srcx,rcx
  mov srdx,rdx
  mov srsi,rsi
  mov srdi,rdi
  {$endif LINUX}



  mov smetndx,rax
  {$ifdef LINUX}

  lea rsi, srdi // TFakeCallStack address as 2nd parameter
  {$else}
  {$ifndef FPC}
  mov [rbp+$60],rcx
  mov [rbp+$68],rdx
  mov [rbp+$70],r8
  mov [rbp+$78],r9
  {$else}
  mov [rbp+$10],rcx
  mov [rbp+$18],rdx
  mov [rbp+$20],r8
  mov [rbp+$28],r9
  {$endif FPC}
  lea rdx, sxmm0 // TFakeCallStack address as 2nd parameter
  {$endif LINUX}
  call TInterfacedObjectFake.FakeCall
  // FakeCall should set Int64 result in method result, and float in aCall.FPRegs["XMM0"]
  movlpd xmm0,sxmm0
end;
{$endif CPUX64}

const
  STUB_SIZE = 65536; // 16*4 KB (4 KB = memory granularity)

{$ifdef FPC} // alf: multi platforms support
{$ifdef MSWINDOWS}
function AddrAllocMem(const Size, flProtect: DWORD): Pointer;
type
  PMEMORY_BASIC_INFORMATION64 = ^_MEMORY_BASIC_INFORMATION64;
  _MEMORY_BASIC_INFORMATION64 = record
     BaseAddress: ULONGLONG;
     AllocationBase: ULONGLONG;
     AllocationProtect: DWORD;
     __alignment1: DWORD;
     RegionSize: ULONGLONG;
     State: DWORD;
     Protect: DWORD;
     Type_: DWORD;
     __alignment2: DWORD;
  end;
var
  mbiold: TMemoryBasicInformation;
  {$ifdef CPUX64}
  mbi: _MEMORY_BASIC_INFORMATION64 absolute mbiold;
  {$else}
  mbi: TMemoryBasicInformation;
  {$endif}
  Info: TSystemInfo;
  P, Q: UInt64;
  PP: Pointer;
  error: DWORD;
  Addr: UInt64;
begin
  {$ifdef CPUX64}
  Addr := UInt64(@x64FakeStub);
  {$else}
  Addr := 0;
  {$endif}
  result := nil;
  if Addr = 0 then begin
    result := VirtualAlloc(nil,Size,MEM_COMMIT,flProtect);
    exit;
  end;
  P := UInt64(Addr);
  Q := UInt64(Addr);
  GetSystemInfo(Info);
  // Interval = [2GB ..P.. 2GB] = 4GB
  if Int64(P - (High(DWORD) div 2)) < 0 then
    P := 1 else
    P := UInt64(P - (High(DWORD) div 2)); // -2GB .
  if UInt64(Q + (High(DWORD) div 2)) > High( {$IFDEF CPUX64}UInt64{$ELSE}UInt{$ENDIF} ) then
    Q := High( {$IFDEF CPUX64}UInt64{$ELSE}UInt{$ENDIF} ) else
    Q := Q + (High(DWORD) div 2); // + 2GB

  while P < Q do begin
    PP := Pointer(P);
    if VirtualQuery(PP, mbiold, sizeof(_MEMORY_BASIC_INFORMATION64)) = 0 then
      break;
    if (mbi.State and MEM_FREE = MEM_FREE) and (UInt64(mbi.RegionSize) > Size) then
      // this memory block is usable
      if (UInt64(mbi.RegionSize) >= Info.dwAllocationGranularity) then begin
        { The RegionSize must be greater than the dwAllocationGranularity  }
        { The address (PP) must be multiple of the allocation granularity (dwAllocationGranularity) . }
        PP := Pointer(Info.dwAllocationGranularity *
          (UInt64(PP) div Info.dwAllocationGranularity) +
          Info.dwAllocationGranularity);
        // if PP is multiple of dwAllocationGranularity then alloc memory
        // if PP is not multiple of dwAllocationGranularity, VirtualAlloc will fail
        if UInt64(PP) mod Info.dwAllocationGranularity=0 then
          result := VirtualAlloc(PP, Size, MEM_COMMIT or MEM_RESERVE, flProtect);
        if result <> nil then
          exit;
      end;
    P := UInt64(mbi.BaseAddress) + UInt64(mbi.RegionSize); // Next region
  end;
end;
{$else}
function AddrAllocMem(const Size, flProtect: DWORD): Pointer;
var P, Q: UInt64;
    PP: Pointer;
    Addr: UInt64;
begin
  Addr := 0;
  {$ifdef CPUX64}
  Addr := UInt64(@x64FakeStub);
  {$endif}
  {$ifdef CPUARM}
  Addr := UInt64(@TInterfacedObjectFake.ArmFakeStub);
  {$endif}
  {$ifdef CPUAARCH64}
  Addr := UInt64(@TInterfacedObjectFake.AArch64FakeStub);
  {$endif}
  Result := nil;
  if Addr = 0 then begin
    Result := fpmmap(nil,STUB_SIZE,flProtect,MAP_PRIVATE OR MAP_ANONYMOUS,-1,0);
    Exit;
  end;
  P := UInt64(Addr);
  Q := UInt64(Addr);
  { Interval = [2GB ..P.. 2GB] = 4GB }
  if Int64(P - (High(DWORD) div 2)) < 0 then
    P := 1 else
    P := UInt64(P - (High(DWORD) div 2)); // -2GB .
  if UInt64(Q + (High(DWORD) div 2)) > High( {$IFDEF CPU64}UInt64{$ELSE}DWORD{$ENDIF} ) then
    Q := High( {$IFDEF CPU64}UInt64{$ELSE}DWORD{$ENDIF} ) else
    Q := Q + (High(DWORD) div 2); // + 2GB
  P := P AND $FFFFFFFFFFFF0000; //AND QWORD(-(STUB_SIZE-1));
  Q := Q AND $FFFFFFFFFFFF0000;
  while P < Q do begin
    P := P + (STUB_SIZE);
    PP := Pointer(P);
    Result := fpmmap(PP,STUB_SIZE,flProtect,MAP_PRIVATE or MAP_ANONYMOUS,-1,0);
    if (Result <> MAP_FAILED) then begin
      {$ifdef CPUARM}
      // are we close enough for a relative jump (24 bit signed)?
      if ((PtrUInt(Result)-Addr)<DWORD($7FFFFF)) or (Addr-(PtrUInt(Result))<DWORD($7FFFFF)) then 
        exit else 
        fpmunmap(Result,STUB_SIZE);
      {$else}
      // are we close enough for a relative jump (32 bit signed)?
      if ((PtrUInt(Result)-Addr)<Int64($7FFFFFFF)) or (Addr-(PtrUInt(Result))<Int64($7FFFFFFF)) then 
        exit else 
        fpmunmap(Result,STUB_SIZE);
      {$endif}
    end;
  end;
end;
{$endif}
{$endif}

type
  // internal memory buffer created with PAGE_EXECUTE_READWRITE flags
  TFakeStubBuffer = class
  protected
    fStub: PByteArray;
    fStubUsed: cardinal;
................................................................................

var
  CurrentFakeStubBuffer: TFakeStubBuffer;

constructor TFakeStubBuffer.Create;
begin
  {$ifdef MSWINDOWS}
  {$ifdef FPC}
  // alf: this is necessary, because a plain call to VirtualAlloc with FPC reserves a piece of memory too far away for a relative jump (on x64)
  fStub := AddrAllocMem(STUB_SIZE,PAGE_EXECUTE_READWRITE);
  {$else FPC}
  fStub := VirtualAlloc(nil,STUB_SIZE,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
  {$endif FPC}
  {$else MSWINDOWS}
  {$ifdef KYLIX3}
  fStub := mmap(nil,STUB_SIZE,PROT_READ OR PROT_WRITE OR PROT_EXEC,MAP_PRIVATE OR MAP_ANONYMOUS,-1,0);
  {$else}
  fStub := AddrAllocMem(STUB_SIZE,PROT_READ OR PROT_WRITE OR PROT_EXEC);
  {$endif}
  {$endif MSWINDOWS}
end;

destructor TFakeStubBuffer.Destroy;
begin
  {$ifdef MSWINDOWS}
  VirtualFree(fStub,0,MEM_RELEASE);
  {$else}
  {$ifdef KYLIX3}
  munmap(fStub,STUB_SIZE);
  {$else}
  fpmunmap(fStub,STUB_SIZE);
  {$endif}
  {$endif}
  inherited;
end;

class function TFakeStubBuffer.Reserve(size: Cardinal): pointer;
begin
  if size>STUB_SIZE then
................................................................................
  with CurrentFakeStubBuffer do begin
    result := @fStub[fStubUsed];
    inc(fStubUsed,size);
  end;
end;

function TInterfaceFactory.GetMethodsVirtualTable: pointer;
var i, tmp: cardinal;
    P: PCardinal;
begin
  if fFakeVTable=nil then begin
    InterfaceFactoryCache.Safe.Lock;
    try
      if fFakeVTable=nil then begin // avoid race condition error
        SetLength(fFakeVTable,fMethodsCount+RESERVED_VTABLE_SLOTS);
        fFakeVTable[0] := @TInterfacedObjectFake.FakeQueryInterface;
        fFakeVTable[1] := @TInterfacedObjectFake.Fake_AddRef;
        fFakeVTable[2] := @TInterfacedObjectFake.Fake_Release;
        if fMethodsCount=0 then begin
          result := pointer(fFakeVTable);
          exit;
        end;
        tmp := {$ifdef CPUX86}fMethodsCount*24{$endif}
             {$ifdef CPUX64}fMethodsCount*12{$endif}
             {$ifdef CPUARM}fMethodsCount*12{$endif}
             {$ifdef CPUAARCH64}($120 shr 2)+fMethodsCount*28{$endif};
        fFakeStub := TFakeStubBuffer.Reserve(tmp);
        PtrUInt(fFakeStub) := PtrUInt(fFakeStub){$ifdef CPUAARCH64} + $120{$endif};
        P := pointer(fFakeStub);
        for i := 0 to fMethodsCount-1 do begin
          fFakeVTable[i+RESERVED_VTABLE_SLOTS] := P;
          {$ifdef CPUX64}
          P^ := $b866+(i shl 16); inc(P);  // mov (r)ax,{MethodIndex}
          PByte(P)^ := $e9; inc(PByte(P)); // jmp x64FakeStub
          P^ := PtrUInt(@x64FakeStub)-PtrUInt(P)-4; inc(P);
          P^ := $909090;
          inc(PByte(P),3);
          {$endif CPUX64}
          {$ifdef CPUARM}
          P^ := ($e3a040 shl 8)+i;  inc(P); // mov r4 (v1),{MethodIndex} : store method index in register
          tmp := ((PtrUInt(@TInterfacedObjectFake.ArmFakeStub)-PtrUInt(P)) shr 2)-2;
          P^ := ($ea shl 24) + (tmp and $00FFFFFF); // branch ArmFakeStub (24bit relative, word aligned)
          inc(P);
          P^ := $e320f000; inc(P);
          {$endif CPUARM}
          {$ifdef CPUAARCH64}
          // store method index in register x9
          // $09 = r9 ... loop to $1F -> number shifted * $20
          P^ := ($d280 shl 16)+(i shl 5)+$09; inc(P);  // mov x9 ,{MethodIndex}
          // we are using a register branch here
          // fill register x10 with address
          tmp := (PtrUInt(@TInterfacedObjectFake.AArch64FakeStub) shr 0) AND $FFFF;
          P^ := ($d280 shl 16)+(tmp shl 5)+$0A; inc(P);
          tmp := (PtrUInt(@TInterfacedObjectFake.AArch64FakeStub) shr 16) AND $FFFF;
          P^ := ($f2a0 shl 16)+(tmp shl 5)+$0A; inc(P);
          tmp := (PtrUInt(@TInterfacedObjectFake.AArch64FakeStub) shr 32) AND $FFFF;
          P^ := ($f2c0 shl 16)+(tmp shl 5)+$0A; inc(P);
          tmp := (PtrUInt(@TInterfacedObjectFake.AArch64FakeStub) shr 48) AND $FFFF;
          P^ := ($f2e0 shl 16)+(tmp shl 5)+$0A; inc(P);
          // branch to address in x10 register
          P^ := ($d61f0140); inc(P);
          P^ := $d503201f; inc(P);
          {$endif CPUAARCH64}
          {$ifdef CPUX86}
          P^ := $68ec8b55; inc(P);                 // push ebp; mov ebp,esp
          P^ := i; inc(P);                         // push {MethodIndex}
          P^ := $e2895251; inc(P);                 // push ecx; push edx; mov edx,esp
          PByte(P)^ := $e8; inc(PByte(P));         // call FakeCall
          P^ := PtrUInt(@TInterfacedObjectFake.FakeCall)-PtrUInt(P)-4; inc(P);
          P^ := $c25dec89; inc(P);                 // mov esp,ebp; pop ebp
          P^ := fMethods[i].ArgsSizeInStack or $900000;  // ret {StackSize}; nop

          inc(PByte(P),3);
          {$endif CPUX86}
        end;
      end;
    finally
      InterfaceFactoryCache.Safe.UnLock;
    end;
  end;
  result := pointer(fFakeVTable);
................................................................................
  {$else}
  P := AlignToPtr(@PI^.IntfUnit[ord(PI^.IntfUnit[0])+1]);
  {$endif}
  n := PW^; inc(PW);
  if (PW^=$ffff) or (n=0) then
    exit; // no RTTI or no method at this level of interface
  inc(PW);
  p := aligntoptr(p);
  for m := fMethodsCount to fMethodsCount+n-1 do begin
    // retrieve method name, and add to the methods list (with hashing)
    SetString(aURI,PAnsiChar(@PS^[1]),ord(PS^[0]));
    with PServiceMethod(fMethod.AddUniqueName(aURI,
      '%.% method: duplicated name for %',[fInterfaceTypeInfo^.Name,aURI,self]))^ do begin
      HierarchyLevel := fAddMethodsLevel;
      {$ifdef FPC} // FPC has its own RTTI layout only since late 3.x
      inc(PB,ord(PS^[0])+1);
      inc(PB); // skip Version field (always 3)
      {$ifdef CPUINTEL}
      if PCallingConvention(P)^<>ccRegister then
         RaiseError('method shall use register calling convention',[]);
      {$endif CPUINTEL}
      inc(PB,sizeOf(TCallingConvention));
      P := AlignToPtr(P);// new Alignment
      aResultType := PTypeInfo(ppointer(P)^);
      inc(PP);
      inc(PW); // skip StackSize
      n := PB^;
      inc(PB);
................................................................................
end;


{ TServiceFactoryServer }

type
  PCallMethodArgs = ^TCallMethodArgs;
  {$ifdef FPC}
    {$PACKRECORDS 16}
  {$endif}
  TCallMethodArgs = record
    StackSize: integer;
    StackAddr, method: PtrInt;

    ParamRegs: packed array[PARAMREG_FIRST..PARAMREG_LAST] of PtrInt;
    {$ifndef CPUX86}
    FPRegs: packed array[FPREG_FIRST..FPREG_LAST] of Double;
    {$endif}
    res64: Int64Rec;
    resKind: TServiceMethodValueType;
  end;

  {$ifdef FPC}
    {$PACKRECORDS DEFAULT}
  {$endif}
procedure CallMethod(var Args: TCallMethodArgs);
{$ifdef CPUARM}


assembler; nostackframe;
label stack_loop,load_regs,asmcall_end,float_result;
asm
   //name  r#(normally, darwin can differ)
   //a1    0           argument 1 / integer result / scratch register
   //a2    1           argument 2 / scratch register
   //a3    2           argument 3 / scratch register
   //a4    3           argument 4 / scratch register
   //v1    4           register variable
   //v2    5           register variable
   //v3    6           register variable
   //v4    7           register variable
   //v5    8           register variable
   //sb    9           static base / register variable
   //sl    10          stack limit / stack chunk handle / reg. variable
   //fp    11          frame pointer
   //ip    12          scratch register / new-sb in inter-link-unit calls
   //sp    13          lower end of current stack frame
   //lr    14          link address / scratch register
   //pc    15          program counter

   // greatly inspired by pascalscript
   //prolog
   mov	 ip, sp // sp is the stack pointer ; ip is the Intra-Procedure-call scratch register
   stmfd sp!, {v1, v2, sb, sl, fp, ip, lr, pc}
   sub	 fp, ip, #4
   // make space on stack
   sub	 sp,sp,#MAX_EXECSTACK
   mov   v1,Args
   // copy (push) stack content (if any)
   ldr   a1, [v1,#TCallMethodArgs.StackSize]
   // if there is no stack content, do nothing
   cmp	 a1, #0
   beq	 load_regs
   // point a2 to bottom of stack.
   mov	 a2, sp
   // load a3 with CallMethod stack address
   ldr	 a3, [v1,#TCallMethodArgs.StackAddr]
stack_loop:
   // copy a3 to a4 and increment a3 (a3 = StackAddr)
   ldmia a3!, {a4}
   // copy a4 to a2 and increment a2 (a2 = StackPointer)
   stmia a2!, {a4}
   // decrement stacksize counter, with update of flags for loop
   subs	 a1, a1, #4
   bne	 stack_loop
load_regs:
   ldr r0,[v1,#TCallMethodArgs.ParamRegs+REGR0*4-4]
   ldr r1,[v1,#TCallMethodArgs.ParamRegs+REGR1*4-4]
   ldr r2,[v1,#TCallMethodArgs.ParamRegs+REGR2*4-4]
   ldr r3,[v1,#TCallMethodArgs.ParamRegs+REGR3*4-4]
   vldr d0,[v1,#TCallMethodArgs.FPRegs+REGD0*8-8]
   vldr d1,[v1,#TCallMethodArgs.FPRegs+REGD1*8-8]
   vldr d2,[v1,#TCallMethodArgs.FPRegs+REGD2*8-8]
   vldr d3,[v1,#TCallMethodArgs.FPRegs+REGD3*8-8]
   vldr d4,[v1,#TCallMethodArgs.FPRegs+REGD4*8-8]
   vldr d5,[v1,#TCallMethodArgs.FPRegs+REGD5*8-8]
   vldr d6,[v1,#TCallMethodArgs.FPRegs+REGD6*8-8]
   vldr d7,[v1,#TCallMethodArgs.FPRegs+REGD7*8-8]
   ldr v2, [v1,#TCallMethodArgs.method]
   blx v2
   str   a1,[v1,#TCallMethodArgs.res64.Lo]
   str   a2,[v1,#TCallMethodArgs.res64.Hi]
   ldr   a1,[v1,#TCallMethodArgs.resKind]
   cmp   a1,smvDouble
   beq   float_result
   cmp   a1,smvDateTime
   beq   float_result
   cmp   a1,smvCurrency
   bne   asmcall_end
   // store double result in res64
float_result:
   vstr   d0,[v1,#TCallMethodArgs.res64]
asmcall_end:
   // epilog
   ldmea fp, {v1, v2, sb, sl, fp, sp, pc}        ;
   // ldmfd sp!,{v1, v2, sb, sl, fp, ip, lr, pc} // pop non volatile registers ftom stack
end;

{$endif CPUARM}
{$ifdef CPUAARCH64}
assembler; nostackframe;
label stack_loop,load_regs,asmcall_end,float_result;
asm
   // inspired by pascal script
   // fp       x29
   // lr       x30
   // sp       sp
   stp	fp,lr,[sp, #-16]!
   stp	x19,x20,[sp, #-16]!
   mov	fp,sp
   // make space on stack
   sub	sp,sp,#MAX_EXECSTACK
   mov  x19,Args
   ldr  x20, [x19,#TCallMethodArgs.method]
   // prepare to copy (push) stack content (if any)
   ldr  x2, [x19,#TCallMethodArgs.StackSize]
   // if there is no stack content, do nothing
   cmp	x2, #0
   b.eq	load_regs
   // point x3 to bottom of stack.
   mov	x3, sp
   // load x4 with CallMethod stack address
   ldr	x4, [x19,#TCallMethodArgs.StackAddr]
stack_loop:
  // load x5 and x6 with stack contents
   ldr x5, [x4]
   ldr x6, [x4,#8]
   //store contents at "real" stack and decrement address counter
   stp	x5,x6,[x3],#16
   // decrement stacksize counter, with update of flags for loop
   subs	x2, x2, #16
   b.ne stack_loop
load_regs:
   ldr x0,[x19,#TCallMethodArgs.ParamRegs+REGX0*8-8]
   ldr x1,[x19,#TCallMethodArgs.ParamRegs+REGX1*8-8]
   ldr x2,[x19,#TCallMethodArgs.ParamRegs+REGX2*8-8]
   ldr x3,[x19,#TCallMethodArgs.ParamRegs+REGX3*8-8]
   ldr x4,[x19,#TCallMethodArgs.ParamRegs+REGX4*8-8]
   ldr x5,[x19,#TCallMethodArgs.ParamRegs+REGX5*8-8]
   ldr x6,[x19,#TCallMethodArgs.ParamRegs+REGX6*8-8]
   ldr x7,[x19,#TCallMethodArgs.ParamRegs+REGX7*8-8]
   ldr d0,[x19,#TCallMethodArgs.FPRegs+REGD0*8-8]
   ldr d1,[x19,#TCallMethodArgs.FPRegs+REGD1*8-8]
   ldr d2,[x19,#TCallMethodArgs.FPRegs+REGD2*8-8]
   ldr d3,[x19,#TCallMethodArgs.FPRegs+REGD3*8-8]
   ldr d4,[x19,#TCallMethodArgs.FPRegs+REGD4*8-8]
   ldr d5,[x19,#TCallMethodArgs.FPRegs+REGD5*8-8]
   ldr d6,[x19,#TCallMethodArgs.FPRegs+REGD6*8-8]
   ldr d7,[x19,#TCallMethodArgs.FPRegs+REGD7*8-8]
   // call TCallMethodArgs.method
   blr x20
   // store normal result
   str  x0,[x19,#TCallMethodArgs.res64]
   ldr  x20,[x19,#TCallMethodArgs.resKind]
   cmp  x20,smvDouble
   b.eq float_result
   cmp  x20,smvDateTime
   b.eq float_result
   cmp  x20,smvCurrency
   b.ne asmcall_end
   // store double result in res64
float_result:
   str  d0,[x19,#TCallMethodArgs.res64]
asmcall_end:
   // give back space on stack (add sp,sp,#MAX_EXECSTACK)
   mov	sp,fp
   ldp	x19,x20,[sp], #16
   ldp	fp,lr,[sp], #16
   ret
end;
{$endif CPUAARCH64}
{$ifdef CPUX64}

assembler;{$IFDEF FPC}nostackframe;{$ENDIF}
asm
    {$IFNDEF FPC}.noframe{$ENDIF}
    push rbp
    push r12
    mov rbp,rsp
    // simulate .params 60 ... size for 60 parameters
    lea rsp,[rsp-MAX_EXECSTACK]
    // align stack
    and rsp,-16
    // get Args
    mov r12,Args
    // copy (push) stack content (if any)
    mov ecx, [r12].TCallMethodArgs.StackSize

    mov rdx, [r12].TCallMethodArgs.StackAddr


    jmp @checkstack
@addstack:
    {$IFDEF FPC}
    push qword ptr [rdx]
    {$ELSE}
    push [rdx]
    {$ENDIF}
    dec ecx
    sub rdx,8
@checkstack:
    or ecx, ecx
    jnz @addstack
    // fill registers
    {$ifdef LINUX}
    // Linux/BSD System V AMD64 ABI
    mov RDI,[r12+TCallMethodArgs.ParamRegs+REGRDI*8-8]
    mov RSI,[r12+TCallMethodArgs.ParamRegs+REGRSI*8-8]
    mov RDX, [r12+TCallMethodArgs.ParamRegs+REGRDX *8-8]
    mov RCX, [r12+TCallMethodArgs.ParamRegs+REGRCX *8-8]
    mov R8,[r12+TCallMethodArgs.ParamRegs+REGR8*8-8]
    mov R9,[r12+TCallMethodArgs.ParamRegs+REGR9*8-8]








    movlpd xmm0,qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM0*8-8]
    movlpd xmm1,qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM1*8-8]
    movlpd xmm2,qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM2*8-8]
    movlpd xmm3,qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM3*8-8]
    movlpd xmm4,qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM4*8-8]
    movlpd xmm5,qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM5*8-8]
    movlpd xmm6,qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM6*8-8]
    movlpd xmm7,qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM7*8-8]
    {$else}
    // Win64 ABI
    mov rcx,[r12+TCallMethodArgs.ParamRegs+REGRCX*8-8]
    mov rdx,[r12+TCallMethodArgs.ParamRegs+REGRDX*8-8]
    mov r8, [r12+TCallMethodArgs.ParamRegs+REGR8 *8-8]
    mov r9, [r12+TCallMethodArgs.ParamRegs+REGR9 *8-8]
    {$ifdef FPC}
    movlpd xmm0, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM0*8-8]
    movlpd xmm1, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM1*8-8]
    movlpd xmm2, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM2*8-8]
    movlpd xmm3, qword ptr [r12+TCallMethodArgs.FPRegs+REGXMM3*8-8]
    {$else}
    movsd xmm0,[r12+TCallMethodArgs.FPRegs+REGXMM0*8-8]
    movsd xmm1,[r12+TCallMethodArgs.FPRegs+REGXMM1*8-8]
    movsd xmm2,[r12+TCallMethodArgs.FPRegs+REGXMM2*8-8]
    movsd xmm3,[r12+TCallMethodArgs.FPRegs+REGXMM3*8-8]
    {$endif FPC}
    {$endif LINUX}
    // alf: adjust for shadow-space (fixme?)
    // caller must ensure that there is space on the stack for the API
    // to store the parameters (RCX,RDX,R8 and R9)
    {$ifndef Linux}
    sub rsp, $20
    {$endif}
    // call method
    call [r12].TCallMethodArgs.method
    // undo the damage (shadow-space) done earlier
    {$ifndef Linux}
    add rsp, $20
    {$endif}
    // retrieve result
    mov [r12].TCallMethodArgs.res64,rax
    mov cl,[r12].TCallMethodArgs.resKind
    cmp cl,smvDouble
    je @d
    cmp cl,smvDateTime
    je @d
    cmp cl,smvCurrency
    jne @e
@d: movlpd qword ptr [r12].TCallMethodArgs.res64, xmm0
@e: mov rsp,rbp





    pop r12


























    pop rbp
end;
{$endif CPUX64}


{$ifdef CPUX86}
asm
    push esi
    push ebp
    mov ebp,esp
    mov esi,Args
    // copy stack content (if any)
    mov eax,[esi].TCallMethodArgs.StackSize
................................................................................
    jz @z
@n: sub edx,4
    mov ecx,[edx]
    push ecx
    dec eax
    jnz @n
    // call method
@z: mov eax,[esi+TCallMethodArgs.ParamRegs+REGEAX*4-4]
    mov edx,[esi+TCallMethodArgs.ParamRegs+REGEDX*4-4]
    mov ecx,[esi+TCallMethodArgs.ParamRegs+REGECX*4-4]
    call [esi].TCallMethodArgs.method
    // retrieve result
    mov cl,[esi].TCallMethodArgs.resKind
    cmp cl,smvDouble
    je @d
    cmp cl,smvDateTime
    je @d
................................................................................
    jmp @e
@i: mov [esi].TCallMethodArgs.res64.Lo,eax
    mov [esi].TCallMethodArgs.res64.Hi,edx
@e: mov esp,ebp
    pop ebp
    pop esi
end;
{$endif CPUX86}


procedure BackgroundExecuteProc(Call: pointer);
var synch: PBackgroundLauncher absolute Call;
    threadContext: PServiceRunningContext;
    backup: TServiceRunningContext;
begin
  threadContext := @ServiceContext; // faster to use a pointer than GetTls()
................................................................................
      Input.InitFast(ArgsInputValuesCount,dvObject);
      Output.InitFast(ArgsOutputValuesCount,dvObject);
    end;
  end;
  fAlreadyExecuted := true;
end;

procedure TServiceMethodExecute.RawExecute(const Instances: PPointerArray;
  InstancesLast: integer);
var Value: pointer;
    a,i,e: integer;
    call: TCallMethodArgs;
    Stack: packed array[0..MAX_EXECSTACK-1] of byte;
begin
  FillcharFast(call,SizeOf(call),0);
  with fMethod^ do begin
    // create the stack and register content
    {$ifdef CPUX86}
    call.StackAddr := PtrInt(@Stack[0]);
    call.StackSize := ArgsSizeInStack;
    {$else}
    {$ifdef CPUINTEL}
    call.StackSize := ArgsSizeInStack shr 3;
    // ensure stack aligned on 16 bytes (paranoid)
    if call.StackSize and 1 <> 0 then
      inc(call.StackSize);
    // stack is filled reversed (RTL)
    call.StackAddr := PtrInt(@Stack[call.StackSize*8-8]);
    {$else}
    // stack is filled normally (LTR)
    call.StackAddr := PtrInt(@Stack[0]);
    call.StackSize := ArgsSizeInStack;
    {$ifdef CPUAARCH64}
    // mandatory on aarch64: make stack aligned on 16 bytes
    // ab@alf: shouldn't it be "and 1", just for x64 above ?
    if call.StackSize and 15 <> 0 then
      inc(call.StackSize,16-(call.StackSize and 15));
    {$endif}
    {$endif CPUINTEL}
    {$endif CPUX86}
    for a := 1 to high(Args) do
    with Args[a] do begin
      case ValueVar of
      smvvSelf:       continue; // call.Regs[REG_FIRST] := Instance[i] below
      smvv64:         Value := @fInt64s[IndexVar];
      smvvRawUTF8:    Value := @fRawUTF8s[IndexVar];
      smvvString:     Value := @fStrings[IndexVar];
................................................................................
      smvvRecord:     Value := pointer(fRecords[IndexVar]);
      smvvDynArray:   Value := @fDynArrays[IndexVar].Value;
      else raise EInterfaceFactoryException.CreateUTF8(
        'Invalid % argument type = %',[ParamName^,ord(ValueType)]);
      end;
      fValues[a] := Value;
      if (ValueDirection<>smdConst) or
         (ValueType in [smvRecord{$ifndef NOVARIANTS},smvVariant{$endif}]) then begin
          // pass by reference
          if (RegisterIdent=0) and (FPRegisterIdent=0) and (SizeInStack>0) then
          MoveFast(Value,Stack[InStackOffset],SizeInStack) else begin
            if RegisterIdent>0 then
              call.ParamRegs[RegisterIdent] := PtrInt(Value);
            if FPRegisterIdent>0 then
              raise EInterfaceFactoryException.CreateUTF8('Unexpected % FPReg=%',
                [ParamName^,FPRegisterIdent]); // should never happen
          end;
        end
        else begin
          // pass by value

          if (RegisterIdent=0) AND (FPRegisterIdent=0) AND (SizeInStack>0) then
          MoveFast(Value^,Stack[InStackOffset],SizeInStack) else begin
            if (RegisterIdent>0) then begin
              call.ParamRegs[RegisterIdent] := PPtrInt(Value)^;
              {$ifdef CPUARM}
              // for e.g. INT64 on 32 bit ARM systems; these are also passed in the normal registers
              if SizeInStack>PTRSIZ then
                call.ParamRegs[RegisterIdent+1] := PPtrInt(Value+PTRSIZ)^;
              {$endif}
            end;
            {$ifndef CPUX86}
            if FPRegisterIdent>0 then
              call.FPRegs[FPRegisterIdent] := PDouble(Value)^;
            {$endif}
            if (RegisterIdent>0) and (FPRegisterIdent>0) then
              raise EInterfaceFactoryException.CreateUTF8('Unexpected % reg=% FP=%',
                [ParamName^,RegisterIdent,FPRegisterIdent]); // should never happen
          end;
        end;
    end;
    // execute the method
    for i := 0 to InstancesLast do begin
      // handle method execution interception
      fCurrentStep := smsBefore;
      if fOnExecute<>nil then begin
        if (Input.Count=0) and (optInterceptInputOutput in Options) then
................................................................................
        for e := 0 to length(fOnExecute)-1 do
        try
          fOnExecute[e](self,smsBefore);
        except // ignore any exception during interception
        end;
      end;
      // prepare the low-level call context for the asm stub
      {$ifndef CPUAARCH64}
      call.ParamRegs[PARAMREG_FIRST] := PtrInt(Instances[i]);
      {$else}
      // alf note for FPC on Linux aarch64:
      // the above is not true for aarch64, when a function result is a pointer 
      // the function result pointer is placed in REGX0 and self in REGX1
      // thus, in that case: call.ParamRegs[REGX1] := PtrInt(Instances[i]);
       if call.ParamRegs[PARAMREG_FIRST]=0 then
          call.ParamRegs[PARAMREG_FIRST] := PtrInt(Instances[i]) else
          call.ParamRegs[REGX1] := PtrInt(Instances[i]);
      {$endif}
      call.method := PPtrIntArray(PPointer(Instances[i])^)^[ExecutionMethodIndex];
      if ArgsResultIndex>=0 then
        call.resKind := Args[ArgsResultIndex].ValueType else
        call.resKind := smvNone;
      // launch the asm stub in the expected execution context
      try
        {$ifndef LVCL}
................................................................................
      end;
      {$endif}
      end;
    end;
  end;
end;

function TServiceMethodExecute.ExecuteJson(const Instances: array of pointer; Par: PUTF8Char;
  Res: TTextWriter; ResAsJSONObject: boolean): boolean;
var a,a1: integer;
    wasString, valid: boolean;
    Val: PUTF8Char;
    Name: PUTF8Char;
    NameLen: integer;
    EndOfObject: AnsiChar;

Changes to SQLite3/mORMotDDD.pas.

1209
1210
1211
1212
1213
1214
1215

1216
1217

1218
1219
1220
1221
1222
1223
1224
procedure TCQRSServiceSubscribe.CallbackReleased(const callback: IInvokable;
  const interfaceName: RawUTF8);
var i: integer;
begin
  fSafe.Lock;
  try

    fLog.SynLog.Log(sllTrace,'CallbackReleased(%,"%") callback=%',
      [callback,interfaceName,ObjectFromInterface(callback)],Self);

    for i := 0 to high(fSubscriber) do // try to release on ALL subscribers
      fSubscriber[i].CallbackReleased(callback, interfaceName);
  finally
    fSafe.UnLock;
  end;
end;







>


>







1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
procedure TCQRSServiceSubscribe.CallbackReleased(const callback: IInvokable;
  const interfaceName: RawUTF8);
var i: integer;
begin
  fSafe.Lock;
  try
    {$ifdef WITHLOG}
    fLog.SynLog.Log(sllTrace,'CallbackReleased(%,"%") callback=%',
      [callback,interfaceName,ObjectFromInterface(callback)],Self);
    {$endif}
    for i := 0 to high(fSubscriber) do // try to release on ALL subscribers
      fSubscriber[i].CallbackReleased(callback, interfaceName);
  finally
    fSafe.UnLock;
  end;
end;

Changes to SQLite3/mORMotHttpServer.pas.

1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
constructor TSQLHttpServer.Create(aServer: TSQLRestServer;
  aDefinition: TSQLHttpServerDefinition);
const AUTH: array[TSQLHttpServerRestAuthentication] of TSQLRestServerAuthenticationClass = (
  // adDefault, adHttpBasic, adWeak, adSSPI
  TSQLRestServerAuthenticationDefault, TSQLRestServerAuthenticationHttpBasic,
  TSQLRestServerAuthenticationNone,
  {$ifdef WINDOWS}TSQLRestServerAuthenticationSSPI{$else}nil{$endif});
var a: TSQLHttpServerRestAuthentication;
    kind: TSQLHttpServerOptions;
    thrdCnt: integer;
    websock: TWebSocketServerRest;
begin
  if aDefinition=nil then
    raise EHttpServerException.CreateUTF8('%.Create(aDefinition=nil)',[self]);
  if aDefinition.WebSocketPassword='' then
    kind := {$ifdef MSWINDOWS}useHttpApiRegisteringURI{$else}useHttpSocket{$endif} else
    kind := useBidirSocket;
  if aDefinition.ThreadCount=0 then
    thrdCnt := 32 else
    thrdCnt := aDefinition.ThreadCount;
  Create(aDefinition.BindPort,aServer,'+',kind,nil,thrdCnt,
    HTTPS_SECURITY[aDefinition.Https],'',aDefinition.HttpSysQueueName);
  if aDefinition.EnableCORS then






|








|







1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
constructor TSQLHttpServer.Create(aServer: TSQLRestServer;
  aDefinition: TSQLHttpServerDefinition);
const AUTH: array[TSQLHttpServerRestAuthentication] of TSQLRestServerAuthenticationClass = (
  // adDefault, adHttpBasic, adWeak, adSSPI
  TSQLRestServerAuthenticationDefault, TSQLRestServerAuthenticationHttpBasic,
  TSQLRestServerAuthenticationNone,
  {$ifdef MSWINDOWS}TSQLRestServerAuthenticationSSPI{$else}nil{$endif});
var a: TSQLHttpServerRestAuthentication;
    kind: TSQLHttpServerOptions;
    thrdCnt: integer;
    websock: TWebSocketServerRest;
begin
  if aDefinition=nil then
    raise EHttpServerException.CreateUTF8('%.Create(aDefinition=nil)',[self]);
  if aDefinition.WebSocketPassword='' then
    kind := HTTP_DEFAULT_MODE else
    kind := useBidirSocket;
  if aDefinition.ThreadCount=0 then
    thrdCnt := 32 else
    thrdCnt := aDefinition.ThreadCount;
  Create(aDefinition.BindPort,aServer,'+',kind,nil,thrdCnt,
    HTTPS_SECURITY[aDefinition.Https],'',aDefinition.HttpSysQueueName);
  if aDefinition.EnableCORS then

Changes to SQLite3/mORMotUI.pas.

214
215
216
217
218
219
220



221

222
223



224

225
226
227
228
229
230
231
...
400
401
402
403
404
405
406




407
408

409
410
411
412
413
414
415
...
436
437
438
439
440
441
442



443

444
445
446
447
448
449
450
...
537
538
539
540
541
542
543

544

545
546
547
548
549
550
551
...
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
...
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
....
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
  // - just call  TSQLTableToGrid.Create(Grid,Table)  to initiate the association
  // - the Table will be released when no longer necessary
  // - any former association by TSQLTableToGrid.Create() will be overridden
  // - handle unicode, column size, field sort, incremental key lookup, hide ID
  // - Ctrl + click on a cell to display its full unicode content
  TSQLTableToGrid = class(TComponent)
  private



    fOnSelectCell: TSelectCellEvent;

    fOnRightClickCell: TRightClickCellEvent;
    fClient: TSQLRestClientURI;



    fOnDrawCellBackground: TDrawCellEvent;

    fMarked: array of byte;
    fMarkAllowed: boolean;
    fMouseDownMarkedValue: (markNone,markOn,markOff);
    fTruncAsHint: Boolean;
    fHeaderCheckboxSelectsInsteadOfSort: Boolean;
    fOnSelectCellProcessing: boolean;
    fFieldIndexTimeLogForMark: integer;
................................................................................
    /// associated TSQLTable to be displayed
    property Table: TSQLTable read fTable;
    /// associated Client used to retrieved the Table data
    property Client: TSQLRestClientURI read fClient;
    /// used to display some hint text
    property Hint: THintWindowDelayed read fHint;
    /// assign an event here to customize the background drawing of a cell




    property OnDrawCellBackground: TDrawCellEvent read fOnDrawCellBackground
      write fOnDrawCellBackground;

    /// true if Marked[] is available (add checkboxes at the left side of every row)
    property MarkAllowed: boolean read fMarkAllowed;
    /// true if any Marked[] is checked
    property MarkAvailable: boolean read GetMarkAvailable;
    /// true if only one entry is in Marked[], and it is the current one
    property MarkedIsOnlyCurrrent: boolean read GetMarkedIsOnlyCurrrent;
    /// returns the number of item marked or selected
................................................................................
    property HeaderCheckboxSelectsInsteadOfSort: boolean
      read fHeaderCheckboxSelectsInsteadOfSort write fHeaderCheckboxSelectsInsteadOfSort;
    /// override this event to customize the text display in the table
    property OnValueText: TValueTextEvent read fOnValueText write fOnValueText;
    /// override this event to customize the Ctrl+Mouse click popup text
    property OnHintText: THintTextEvent read fOnHintText write fOnHintText;
    /// override this event to customize the Mouse click on a data cell



    property OnSelectCell: TSelectCellEvent read fOnSelectCell write fOnSelectCell;

    /// override this event to customize the Mouse right click on a data cell
    property OnRightClickCell: TRightClickCellEvent read fOnRightClickCell write fOnRightClickCell;
    /// override this event to be notified when the content is sorted
    property OnSort: TNotifyEvent read fOnsort write fOnsort;
  end;

type
................................................................................

resourcestring
  SErrorFieldNotValid = 'Field "%s"'#13'does not contain a valid %s value';
  SErrorFieldTooSmall = 'Field "%s"'#13'is too small, value must be >= %s';
  SErrorFieldTooLarge = 'Field "%s"'#13'is too large, value must be <= %s';
  SMinMaxValue = 'Min. Value: %s, Max. Value: %s';


{$define VISTAFORM}


{$ifdef VISTAFORM}

{$R SQLite3UI.RES}

type
  /// Vista-enabled TForm descendant
................................................................................
function THintWindowDelayed.CalcHintRect(MaxWidth: Integer;
  const AHint: RawUTF8; AData: Pointer): TRect;
var U: RawUnicode; // faster than a WideString
begin // unicode version
  Result := Rect(0, 0, MaxWidth, 0);
  U := Utf8DecodeToRawUnicode(AHint);
  DrawTextW(Canvas.Handle, pointer(U), length(U) shr 1, Result, DT_CALCRECT or DT_LEFT or
    DT_WORDBREAK or DT_NOPREFIX or DrawTextBiDiModeFlagsReadingOnly);
  Inc(Result.Right, 6);
  Inc(Result.Bottom, 2);
end;

procedure THintWindowDelayed.Paint;
var R: TRect;
    U: RawUnicode; // faster than a WideString
................................................................................
begin // unicode version
  R := ClientRect;
  Inc(R.Left, 2);
  Inc(R.Top, 2);
  Canvas.Font.Color := fFontColor;
  U := Utf8DecodeToRawUnicodeUI(fUTF8Text);
  DrawTextW(Canvas.Handle, pointer(U), -1, R, DT_LEFT or DT_NOPREFIX or
    DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly);
end;

procedure THintWindowDelayed.VisibleChanging;
begin
  try
    if fTimerEnabled and Visible then begin // are we in a Hide process?
      KillTimer(Handle,1);
................................................................................
    exit;
  if Assigned(OnDrawCellBackground) then
    OnDrawCellBackground(Owner,ACol,ARow,Rect,State);
  if (cardinal(ARow)>cardinal(Table.RowCount)) or
    (cardinal(ACol)>=cardinal(Table.FieldCount)) then // avoid any possible GPF
    exit;
  with TDrawGrid(Owner).Canvas do begin
    Options := ETO_CLIPPED or TextFlags;
    if Brush.Style <> bsClear then
      Options := Options or ETO_OPAQUE;
    WithMark := fMarkAllowed and (ACol=0);
    if ARow=0 then begin
      // 1. 1st row = field name: bold + centered translated text, with sort indicator
      if not Assigned(OnValueText) or
         not OnValueText(Table,ACol,0,StringValue) then






>
>
>

>


>
>
>

>







 







>
>
>
>


>







 







>
>
>

>







 







>

>







 







|







 







|







 







|







214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
...
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
...
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
...
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
...
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
...
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
....
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
  // - just call  TSQLTableToGrid.Create(Grid,Table)  to initiate the association
  // - the Table will be released when no longer necessary
  // - any former association by TSQLTableToGrid.Create() will be overridden
  // - handle unicode, column size, field sort, incremental key lookup, hide ID
  // - Ctrl + click on a cell to display its full unicode content
  TSQLTableToGrid = class(TComponent)
  private
    {$ifdef FPC}
    fOnSelectCell: TOnSelectCellEvent;
    {$else}
    fOnSelectCell: TSelectCellEvent;
    {$endif}
    fOnRightClickCell: TRightClickCellEvent;
    fClient: TSQLRestClientURI;
    {$ifdef FPC}
    fOnDrawCellBackground: TOnDrawCell;
    {$else}
    fOnDrawCellBackground: TDrawCellEvent;
    {$endif}
    fMarked: array of byte;
    fMarkAllowed: boolean;
    fMouseDownMarkedValue: (markNone,markOn,markOff);
    fTruncAsHint: Boolean;
    fHeaderCheckboxSelectsInsteadOfSort: Boolean;
    fOnSelectCellProcessing: boolean;
    fFieldIndexTimeLogForMark: integer;
................................................................................
    /// associated TSQLTable to be displayed
    property Table: TSQLTable read fTable;
    /// associated Client used to retrieved the Table data
    property Client: TSQLRestClientURI read fClient;
    /// used to display some hint text
    property Hint: THintWindowDelayed read fHint;
    /// assign an event here to customize the background drawing of a cell
    {$ifdef FPC}
    property OnDrawCellBackground: TOnDrawCell read fOnDrawCellBackground
      write fOnDrawCellBackground;
    {$else}
    property OnDrawCellBackground: TDrawCellEvent read fOnDrawCellBackground
      write fOnDrawCellBackground;
    {$endif}
    /// true if Marked[] is available (add checkboxes at the left side of every row)
    property MarkAllowed: boolean read fMarkAllowed;
    /// true if any Marked[] is checked
    property MarkAvailable: boolean read GetMarkAvailable;
    /// true if only one entry is in Marked[], and it is the current one
    property MarkedIsOnlyCurrrent: boolean read GetMarkedIsOnlyCurrrent;
    /// returns the number of item marked or selected
................................................................................
    property HeaderCheckboxSelectsInsteadOfSort: boolean
      read fHeaderCheckboxSelectsInsteadOfSort write fHeaderCheckboxSelectsInsteadOfSort;
    /// override this event to customize the text display in the table
    property OnValueText: TValueTextEvent read fOnValueText write fOnValueText;
    /// override this event to customize the Ctrl+Mouse click popup text
    property OnHintText: THintTextEvent read fOnHintText write fOnHintText;
    /// override this event to customize the Mouse click on a data cell
    {$ifdef FPC}
    property OnSelectCell: TOnSelectCellEvent read fOnSelectCell write fOnSelectCell;
    {$else}
    property OnSelectCell: TSelectCellEvent read fOnSelectCell write fOnSelectCell;
    {$endif}
    /// override this event to customize the Mouse right click on a data cell
    property OnRightClickCell: TRightClickCellEvent read fOnRightClickCell write fOnRightClickCell;
    /// override this event to be notified when the content is sorted
    property OnSort: TNotifyEvent read fOnsort write fOnsort;
  end;

type
................................................................................

resourcestring
  SErrorFieldNotValid = 'Field "%s"'#13'does not contain a valid %s value';
  SErrorFieldTooSmall = 'Field "%s"'#13'is too small, value must be >= %s';
  SErrorFieldTooLarge = 'Field "%s"'#13'is too large, value must be <= %s';
  SMinMaxValue = 'Min. Value: %s, Max. Value: %s';

{$ifndef FPC}
{$define VISTAFORM}
{$endif}

{$ifdef VISTAFORM}

{$R SQLite3UI.RES}

type
  /// Vista-enabled TForm descendant
................................................................................
function THintWindowDelayed.CalcHintRect(MaxWidth: Integer;
  const AHint: RawUTF8; AData: Pointer): TRect;
var U: RawUnicode; // faster than a WideString
begin // unicode version
  Result := Rect(0, 0, MaxWidth, 0);
  U := Utf8DecodeToRawUnicode(AHint);
  DrawTextW(Canvas.Handle, pointer(U), length(U) shr 1, Result, DT_CALCRECT or DT_LEFT or
    DT_WORDBREAK or DT_NOPREFIX {$ifndef FPC}or DrawTextBiDiModeFlagsReadingOnly{$endif});
  Inc(Result.Right, 6);
  Inc(Result.Bottom, 2);
end;

procedure THintWindowDelayed.Paint;
var R: TRect;
    U: RawUnicode; // faster than a WideString
................................................................................
begin // unicode version
  R := ClientRect;
  Inc(R.Left, 2);
  Inc(R.Top, 2);
  Canvas.Font.Color := fFontColor;
  U := Utf8DecodeToRawUnicodeUI(fUTF8Text);
  DrawTextW(Canvas.Handle, pointer(U), -1, R, DT_LEFT or DT_NOPREFIX or
    DT_WORDBREAK {$ifndef FPC}or DrawTextBiDiModeFlagsReadingOnly{$endif});
end;

procedure THintWindowDelayed.VisibleChanging;
begin
  try
    if fTimerEnabled and Visible then begin // are we in a Hide process?
      KillTimer(Handle,1);
................................................................................
    exit;
  if Assigned(OnDrawCellBackground) then
    OnDrawCellBackground(Owner,ACol,ARow,Rect,State);
  if (cardinal(ARow)>cardinal(Table.RowCount)) or
    (cardinal(ACol)>=cardinal(Table.FieldCount)) then // avoid any possible GPF
    exit;
  with TDrawGrid(Owner).Canvas do begin
    Options := ETO_CLIPPED {$ifndef FPC}or TextFlags{$endif};
    if Brush.Style <> bsClear then
      Options := Options or ETO_OPAQUE;
    WithMark := fMarkAllowed and (ACol=0);
    if ARow=0 then begin
      // 1. 1st row = field name: bold + centered translated text, with sort indicator
      if not Assigned(OnValueText) or
         not OnValueText(Table,ACol,0,StringValue) then

Changes to SQLite3/mORMotUILogin.pas.

82
83
84
85
86
87
88
89



90
91
92
93
94
95
96
97
*)

interface

{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64

uses
  Windows, Messages, SysUtils, Classes, Graphics, Consts,



  Controls, Forms, StdCtrls, ExtCtrls, Buttons, PsAPI,
{$ifdef USETMSPACK}
  AdvGlowButton, TaskDialog, TaskDialogEx, AdvToolBarStylers, AdvToolBar,
{$endif USETMSPACK}
  SynTaskDialog, SynGdiPlus, SynCommons, mORMot, mORMotUI;


type






|
>
>
>
|







82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
*)

interface

{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64

uses
  Windows, PsAPI, Messages, SysUtils, Classes, Graphics,
  {$ifndef FPC}
  Consts,
  {$endif}
  Controls, Forms, StdCtrls, ExtCtrls, Buttons,
{$ifdef USETMSPACK}
  AdvGlowButton, TaskDialog, TaskDialogEx, AdvToolBarStylers, AdvToolBar,
{$endif USETMSPACK}
  SynTaskDialog, SynGdiPlus, SynCommons, mORMot, mORMotUI;


type

Changes to SynBigTable.pas.

1916
1917
1918
1919
1920
1921
1922

1923
1924
1925
1926
1927
1928
1929
....
2016
2017
2018
2019
2020
2021
2022
2023

2024
2025
2026

2027
2028
2029
2030
2031
2032
2033
2034
2035


2036
2037
2038

2039
2040
2041
2042
2043
2044
2045
    DataLen: integer;
    aTempData: RawByteString;
    stopper, S: TStopper;
    next: array[deleted..alias] of integer;
    stop: array[deleted..alias] of cardinal;
    GetID: PInteger absolute Opaque;
    Physical: PIterateGetDynArrayIntegerOpaque absolute Opaque;

label CallBack;
begin
  if self=nil then
    exit;
{$ifdef THREADSAFE}
  fLock.BeginRead;
  try
................................................................................
            // physical: ignore update, ID: callback expects updated data
            if Order=ioID then
            if DontRetrieveData then begin
              if not aCallBack(self,Opaque,aID,0,nil,0) then
                exit; // forced iteration break
            end else begin
              index := IDToIndex(fAliasReal[next[updated]],false);
              if index>=0 then

CallBack:       if not aCallBack(self,Opaque,aID,index,
                   GetPointerFromIndex(index,aTempData,@DataLen),DataLen) then
                  exit; // forced iteration break

              end;
            end;
          inc(next[stopper]); // find next fDeleted[] or fAlias*[]
          break; // we reached StopID -> get next udpated or deleted ID
        end else
        if DontRetrieveData then begin
          if not aCallBack(self,Opaque,aID,0,nil,0) then
            exit; // forced iteration break
        end else


        if not aCallBack(self,Opaque,aID,i,
           GetPointerFromIndex(i,aTempData,@DataLen),DataLen) then
          exit; // forced iteration break

      end;
      end; // case Order of
    end;
    assert(j=n);
{$ifdef THREADSAFE}
  finally
    fLock.EndRead;






>







 







|
>
|
<

>









>
>
|
<
|
>







1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
....
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026

2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040

2041
2042
2043
2044
2045
2046
2047
2048
2049
    DataLen: integer;
    aTempData: RawByteString;
    stopper, S: TStopper;
    next: array[deleted..alias] of integer;
    stop: array[deleted..alias] of cardinal;
    GetID: PInteger absolute Opaque;
    Physical: PIterateGetDynArrayIntegerOpaque absolute Opaque;
    p: pointer; // alf: to circumvent FPC issues
label CallBack;
begin
  if self=nil then
    exit;
{$ifdef THREADSAFE}
  fLock.BeginRead;
  try
................................................................................
            // physical: ignore update, ID: callback expects updated data
            if Order=ioID then
            if DontRetrieveData then begin
              if not aCallBack(self,Opaque,aID,0,nil,0) then
                exit; // forced iteration break
            end else begin
              index := IDToIndex(fAliasReal[next[updated]],false);
              if index>=0 then begin
CallBack:       p := GetPointerFromIndex(index,aTempData,PInteger(@DataLen));
                if not aCallBack(self,Opaque,aID,index,p,DataLen) then

                  exit; // forced iteration break
              end;
              end;
            end;
          inc(next[stopper]); // find next fDeleted[] or fAlias*[]
          break; // we reached StopID -> get next udpated or deleted ID
        end else
        if DontRetrieveData then begin
          if not aCallBack(self,Opaque,aID,0,nil,0) then
            exit; // forced iteration break
        end else
        begin
          p := GetPointerFromIndex(i,aTempData,PInteger(@DataLen));
          if not aCallBack(self,Opaque,aID,i,p,DataLen) then

            exit; // forced iteration break
      end;
      end;
      end; // case Order of
    end;
    assert(j=n);
{$ifdef THREADSAFE}
  finally
    fLock.EndRead;

Changes to SynCommons.pas.

11210
11211
11212
11213
11214
11215
11216
11217
11218
11219
11220
11221
11222
11223
11224
11225
.....
17922
17923
17924
17925
17926
17927
17928



17929
17930
17931
17932

17933
17934
17935
17936
17937
17938
17939
.....
18418
18419
18420
18421
18422
18423
18424
18425
18426
18427
18428
18429
18430
18431
18432
.....
19019
19020
19021
19022
19023
19024
19025
19026
19027
19028
19029
19030
19031
19032
19033
.....
19060
19061
19062
19063
19064
19065
19066
19067
19068
19069
19070
19071
19072
19073
19074
.....
19078
19079
19080
19081
19082
19083
19084
19085
19086
19087
19088
19089
19090
19091
19092
.....
19124
19125
19126
19127
19128
19129
19130
19131
19132
19133
19134
19135
19136
19137
19138
.....
21913
21914
21915
21916
21917
21918
21919



21920
21921
21922
21923
21924
21925
21926
.....
21994
21995
21996
21997
21998
21999
22000





22001
22002
22003
22004
22005
22006
22007
.....
31736
31737
31738
31739
31740
31741
31742
31743
31744
31745
31746
31747
31748
31749
31750
    // - return "string" type, i.e. UnicodeString for Delphi 2009+
    Main: string;
    /// retrieve application version from exe file name
    // - DefaultVersion32 is used if no information Version was included into
    // the executable resources (on compilation time)
    // - you should not have to use this constructor, but rather access the
    // ExeVersion global variable
    constructor Create(const aFileName: TFileName;
      aMajor,aMinor,aRelease,aBuild: integer);
    /// retrieve the version as a 32 bits integer with Major.Minor.Release
    // - following Major shl 16+Minor shl 8+Release bit pattern
    function Version32: integer;
    /// build date and time of this exe file, as plain text
    function BuildDateTimeString: string;
    /// returns the version information of a specified exe file as text
    // - includes Detailed and BuildDateTime
................................................................................
    vtPChar: begin
      Res.Text := V.VPointer;
      Res.Len := StrLen(V.VPointer);
      result := Res.Len;
      exit;
    end;
    vtChar: begin



      Res.Text := @V.VChar;
      Res.Len := 1;
      result := 1;
      exit;

    end;
    vtPWideChar:
      RawUnicodeToUtf8(V.VPWideChar,StrLenW(V.VPWideChar),tmpStr);
    vtWideChar:
      RawUnicodeToUtf8(@V.VWideChar,1,tmpStr);
    vtBoolean: begin
      Res.Temp[0] := AnsiChar(ord(V.VBoolean)+48);
................................................................................
    ret
@3: lea rax,[rcx-1]
    or dl,'0'
    mov [rax],dl
end;
{$else}
{$ifdef PUREPASCAL}
var c100: cardinal;
begin // this code is faster than the Borland's original str() or IntToStr()
  repeat
    if val<10 then begin
      dec(P);
      P^ := AnsiChar(val+ord('0'));
      break;
    end else
................................................................................
  tmp.wr(i,1);
  {$else}
  tmp.wr(k,sizeof(k));
  {$endif}
  tmp.wr(rtti^.NameLen,rtti^.NameLen+1);
  inc(PByte(rtti),rtti^.NameLen);
  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  rtti := align(rtti);
  {$endif}
  with rtti^ do
  case k of
  tkChar, tkWChar, tkLString, tkWString, tkVariant, tkInt64
  {$ifdef UNICODE}, tkUString{$endif}:
    ; // no additional RTTI needed for those types
  tkDynArray: begin
................................................................................
  tkClass: begin
    wrtype(ParentInfo);
    tmp.wrint(PropCount);
    tmp.wr(UnitNameLen,UnitNameLen+1);
    n := @UnitNameLen;
    inc(n,UnitNameLen+1);
    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
    n := align(n);
    {$endif}
    for i := 1 to PropCount do begin
      wrtype(np^.PropType);
      offs := np^.GetProc;
      {$ifndef FPC}
      if offs and {$ifdef CPU64}$ff00000000000000{$else}$ff000000{$endif}<>0 then
        raise ESynException.CreateUTF8('TypeInfoSave no getter for %',
................................................................................
      tmp.wrb(np^.StoredProc);
      tmp.wrint(np^.Index);
      tmp.wrint(np^.Default);
      tmp.wrw(np^.NameIndex);
      tmp.wr(np^.NameLen,np^.NameLen+1);
      n := PAnsiChar(@np^.NameLen)+np^.NameLen+1;
      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
      n := align(n);
      {$endif}
    end;
  end;
  else
    raise ESynException.CreateUTF8('TypeInfoSave(%) unsupported',[ToText(k)^]);
  end;
  SetLength(rttitypes,result+1);
................................................................................
  procedure wrss;
  var len: integer;
  begin
    len := PByte(n)^+1;
    tmp.wr(n^,len); // copy whole shortstring at once
    inc(n,len);
    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
    n := align(n);
    {$endif}
  end;
  function wrtype: pointer;
  var index,off,ti: integer;
  begin
    result := tmp.pos;
    index := nw;
................................................................................
  result := '';
  tmpN := 0;
  FillcharFast(inlin,SizeOf(inlin),0);
  L := 0;
  A := 0;
  P := 0;
  F := pointer(Format);



  while F^<>#0 do begin
    if F^<>'%' then begin
      FDeb := F;
      while not (F^ in [#0,'%','?']) do inc(F);
Txt:  len := F-FDeb;
      if len>0 then begin
        inc(L,len);
................................................................................
    MoveFast(pointer(tmp[i])^,F^,L);
    inc(F,L);
    if i in inlin then begin
      PWord(F)^ := ord(')')+ord(':')shl 8;
      inc(F,2);
    end;
  end;





end;

function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString;
var i, L: integer;
    P: PAnsiChar;
begin
  L := 0;
................................................................................
begin
  result := '';
  if GetEnumInfo(TypeInfo(TIntelCpuFeature),MaxValue,List) then
    for f := low(f) to high(f) do begin
      if (f in aIntelCPUFeatures) and (List^[3]<>'_') then begin
        if result<>'' then
          result := result+Sep;
        result := result+copy(List^,3,10);
      end;
      inc(PByte(List),ord(List^[0])+1); // next short string
    end;
end;

function SystemInfoJson: RawUTF8;
begin






|
|







 







>
>
>




>







 







|







 







|







 







|







 







|







 







|







 







>
>
>







 







>
>
>
>
>







 







|







11210
11211
11212
11213
11214
11215
11216
11217
11218
11219
11220
11221
11222
11223
11224
11225
.....
17922
17923
17924
17925
17926
17927
17928
17929
17930
17931
17932
17933
17934
17935
17936
17937
17938
17939
17940
17941
17942
17943
.....
18422
18423
18424
18425
18426
18427
18428
18429
18430
18431
18432
18433
18434
18435
18436
.....
19023
19024
19025
19026
19027
19028
19029
19030
19031
19032
19033
19034
19035
19036
19037
.....
19064
19065
19066
19067
19068
19069
19070
19071
19072
19073
19074
19075
19076
19077
19078
.....
19082
19083
19084
19085
19086
19087
19088
19089
19090
19091
19092
19093
19094
19095
19096
.....
19128
19129
19130
19131
19132
19133
19134
19135
19136
19137
19138
19139
19140
19141
19142
.....
21917
21918
21919
21920
21921
21922
21923
21924
21925
21926
21927
21928
21929
21930
21931
21932
21933
.....
22001
22002
22003
22004
22005
22006
22007
22008
22009
22010
22011
22012
22013
22014
22015
22016
22017
22018
22019
.....
31748
31749
31750
31751
31752
31753
31754
31755
31756
31757
31758
31759
31760
31761
31762
    // - return "string" type, i.e. UnicodeString for Delphi 2009+
    Main: string;
    /// retrieve application version from exe file name
    // - DefaultVersion32 is used if no information Version was included into
    // the executable resources (on compilation time)
    // - you should not have to use this constructor, but rather access the
    // ExeVersion global variable
    constructor Create(const aFileName: TFileName; aMajor: integer=0;
      aMinor: integer=0; aRelease: integer=0; aBuild: integer=0);
    /// retrieve the version as a 32 bits integer with Major.Minor.Release
    // - following Major shl 16+Minor shl 8+Release bit pattern
    function Version32: integer;
    /// build date and time of this exe file, as plain text
    function BuildDateTimeString: string;
    /// returns the version information of a specified exe file as text
    // - includes Detailed and BuildDateTime
................................................................................
    vtPChar: begin
      Res.Text := V.VPointer;
      Res.Len := StrLen(V.VPointer);
      result := Res.Len;
      exit;
    end;
    vtChar: begin
      {$ifdef FPC} // alf: to circumvent FPC issues
      RawUnicodeToUtf8(@V.VChar,1,tmpStr);
      {$else}
      Res.Text := @V.VChar;
      Res.Len := 1;
      result := 1;
      exit;
      {$endif}
    end;
    vtPWideChar:
      RawUnicodeToUtf8(V.VPWideChar,StrLenW(V.VPWideChar),tmpStr);
    vtWideChar:
      RawUnicodeToUtf8(@V.VWideChar,1,tmpStr);
    vtBoolean: begin
      Res.Temp[0] := AnsiChar(ord(V.VBoolean)+48);
................................................................................
    ret
@3: lea rax,[rcx-1]
    or dl,'0'
    mov [rax],dl
end;
{$else}
{$ifdef PUREPASCAL}
var c100: PtrUInt;
begin // this code is faster than the Borland's original str() or IntToStr()
  repeat
    if val<10 then begin
      dec(P);
      P^ := AnsiChar(val+ord('0'));
      break;
    end else
................................................................................
  tmp.wr(i,1);
  {$else}
  tmp.wr(k,sizeof(k));
  {$endif}
  tmp.wr(rtti^.NameLen,rtti^.NameLen+1);
  inc(PByte(rtti),rtti^.NameLen);
  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  rtti := align(rtti,sizeof(rtti));
  {$endif}
  with rtti^ do
  case k of
  tkChar, tkWChar, tkLString, tkWString, tkVariant, tkInt64
  {$ifdef UNICODE}, tkUString{$endif}:
    ; // no additional RTTI needed for those types
  tkDynArray: begin
................................................................................
  tkClass: begin
    wrtype(ParentInfo);
    tmp.wrint(PropCount);
    tmp.wr(UnitNameLen,UnitNameLen+1);
    n := @UnitNameLen;
    inc(n,UnitNameLen+1);
    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
    n := align(n,sizeof(n));
    {$endif}
    for i := 1 to PropCount do begin
      wrtype(np^.PropType);
      offs := np^.GetProc;
      {$ifndef FPC}
      if offs and {$ifdef CPU64}$ff00000000000000{$else}$ff000000{$endif}<>0 then
        raise ESynException.CreateUTF8('TypeInfoSave no getter for %',
................................................................................
      tmp.wrb(np^.StoredProc);
      tmp.wrint(np^.Index);
      tmp.wrint(np^.Default);
      tmp.wrw(np^.NameIndex);
      tmp.wr(np^.NameLen,np^.NameLen+1);
      n := PAnsiChar(@np^.NameLen)+np^.NameLen+1;
      {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
      n := align(n,sizeof(n));
      {$endif}
    end;
  end;
  else
    raise ESynException.CreateUTF8('TypeInfoSave(%) unsupported',[ToText(k)^]);
  end;
  SetLength(rttitypes,result+1);
................................................................................
  procedure wrss;
  var len: integer;
  begin
    len := PByte(n)^+1;
    tmp.wr(n^,len); // copy whole shortstring at once
    inc(n,len);
    {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
    n := align(n,sizeof(n));
    {$endif}
  end;
  function wrtype: pointer;
  var index,off,ti: integer;
  begin
    result := tmp.pos;
    index := nw;
................................................................................
  result := '';
  tmpN := 0;
  FillcharFast(inlin,SizeOf(inlin),0);
  L := 0;
  A := 0;
  P := 0;
  F := pointer(Format);
  {$ifdef FPC}
  try // alf: to circumvent FPC issues
  {$endif}
  while F^<>#0 do begin
    if F^<>'%' then begin
      FDeb := F;
      while not (F^ in [#0,'%','?']) do inc(F);
Txt:  len := F-FDeb;
      if len>0 then begin
        inc(L,len);
................................................................................
    MoveFast(pointer(tmp[i])^,F^,L);
    inc(F,L);
    if i in inlin then begin
      PWord(F)^ := ord(')')+ord(':')shl 8;
      inc(F,2);
    end;
  end;
  {$ifdef FPC}
  finally
    finalize(tmp);
  end;
  {$endif}
end;

function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString;
var i, L: integer;
    P: PAnsiChar;
begin
  L := 0;
................................................................................
begin
  result := '';
  if GetEnumInfo(TypeInfo(TIntelCpuFeature),MaxValue,List) then
    for f := low(f) to high(f) do begin
      if (f in aIntelCPUFeatures) and (List^[3]<>'_') then begin
        if result<>'' then
          result := result+Sep;
        result := result+RawUTF8(copy(List^,3,10));
      end;
      inc(PByte(List),ord(List^[0])+1); // next short string
    end;
end;

function SystemInfoJson: RawUTF8;
begin

Changes to SynCrtSock.pas.

3235
3236
3237
3238
3239
3240
3241

3242
3243
3244
3245
3246
3247
3248
....
3256
3257
3258
3259
3260
3261
3262

3263
3264
3265
3266
3267
3268
3269
  fillchar(SockIn^,sizeof(TTextRec),0);
  with TTextRec(SockIn^) do begin
    PCrtSocket(@UserData)^ := self;
    Mode := fmClosed;
    BufSize := InputBufferSize;
    BufPtr := pointer(PAnsiChar(SockIn)+sizeof(TTextRec)); // ignore Buffer[] (Delphi 2009+)
    OpenFunc := @OpenSock;

  end;
  {$ifndef DELPHI5OROLDER}
  SetLineBreakStyle(SockIn^,LineBreak); // http does break lines with #13#10
  {$endif}
  Reset(SockIn^);
end;

................................................................................
  fillchar(SockOut^,sizeof(TTextRec),0);
  with TTextRec(SockOut^) do begin
    PCrtSocket(@UserData)^ := self;
    Mode := fmClosed;
    BufSize := OutputBufferSize;
    BufPtr := pointer(PAnsiChar(SockIn)+sizeof(TTextRec)); // ignore Buffer[] (Delphi 2009+)
    OpenFunc := @OpenSock;

  end;
  {$ifndef DELPHI5OROLDER}
  SetLineBreakStyle(SockOut^,tlbsCRLF); // force e.g. for Linux platforms
  {$endif}
  Rewrite(SockOut^);
end;







>







 







>







3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
....
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
  fillchar(SockIn^,sizeof(TTextRec),0);
  with TTextRec(SockIn^) do begin
    PCrtSocket(@UserData)^ := self;
    Mode := fmClosed;
    BufSize := InputBufferSize;
    BufPtr := pointer(PAnsiChar(SockIn)+sizeof(TTextRec)); // ignore Buffer[] (Delphi 2009+)
    OpenFunc := @OpenSock;
    Handle := -1;
  end;
  {$ifndef DELPHI5OROLDER}
  SetLineBreakStyle(SockIn^,LineBreak); // http does break lines with #13#10
  {$endif}
  Reset(SockIn^);
end;

................................................................................
  fillchar(SockOut^,sizeof(TTextRec),0);
  with TTextRec(SockOut^) do begin
    PCrtSocket(@UserData)^ := self;
    Mode := fmClosed;
    BufSize := OutputBufferSize;
    BufPtr := pointer(PAnsiChar(SockIn)+sizeof(TTextRec)); // ignore Buffer[] (Delphi 2009+)
    OpenFunc := @OpenSock;
    Handle := -1;
  end;
  {$ifndef DELPHI5OROLDER}
  SetLineBreakStyle(SockOut^,tlbsCRLF); // force e.g. for Linux platforms
  {$endif}
  Rewrite(SockOut^);
end;

Changes to SynSelfTests.pas.

1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
....
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
.....
10541
10542
10543
10544
10545
10546
10547
10548
10549
10550
10551
10552
10553
10554
10555
.....
12265
12266
12267
12268
12269
12270
12271
12272
12273
12274
12275
12276
12277
12278
12279
.....
12511
12512
12513
12514
12515
12516
12517
12518
12519
12520
12521
12522
12523
12524
12525
.....
12559
12560
12561
12562
12563
12564
12565

12566
12567
12568
12569
12570
12571
12572
.....
12580
12581
12582
12583
12584
12585
12586

12587
12588
12589
12590
12591
12592
12593
12594
.....
12644
12645
12646
12647
12648
12649
12650

12651
12652
12653
12654
12655
12656
12657
12658
12659
12660
12661
12662
12663
12664

12665
12666


12667
12668
12669
12670
12671
12672
12673
.....
12779
12780
12781
12782
12783
12784
12785


12786
12787
12788

12789
12790
12791
12792
12793
12794
12795
12796
12797
12798
12799
12800
12801
12802
12803
12804
12805
.....
14660
14661
14662
14663
14664
14665
14666
14667
14668
14669
14670
14671
14672
14673
14674
.....
14752
14753
14754
14755
14756
14757
14758
14759
14760
14761
14762
14763
14764
14765
14766
    ['{5237A687-C0B2-46BA-9F39-BEEA7C3AA6A9}']
  end;

  /// a test interface, used by TTestServiceOrientedArchitecture
  // - to test threading implementation pattern
  ITestPerThread = interface(IInvokable)
    ['{202B6C9F-FCCB-488D-A425-5472554FD9B1}']
    function GetContextServiceInstanceID: cardinal;
    function GetThreadIDAtCreation: TThreadID;
    function GetCurrentThreadID: TThreadID;
    function GetCurrentRunningThreadID: TThreadID;
  end;

  /// a test value object, used by IUserRepository/ISmsSender interfaces
  // - to test stubing/mocking implementation pattern
................................................................................
  RecordLoadJSON(JA,pointer(U),TypeInfo(TTestCustomJSONArrayWithoutF));
  Check(length(JA.E)=2);
  Check(JA.D='1234');
  TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONArrayWithoutF),'');

  discogsJson := StringFromFile(discogsFileName);
  if discogsJson='' then begin
    discogsJson := HttpGet('http://api.discogs.com/artists/45/releases?page=1&per_page=100');
    FileFromString(discogsJson,discogsFileName);
  end;
  zendframeworkJson := StringFromFile(zendframeworkFileName);
  if zendframeworkJson='' then begin
    zendframeworkJson := HttpGet('https://api.github.com/users/zendframework/repos');
    FileFromString(zendframeworkJson,zendframeworkFileName);
  end;
................................................................................
    DoTests;
  finally
    if proxy<>Props then
      proxy.Free;
  end;
end;
var Server: TSQLDBServerAbstract;
const ADDR='localhost:'+HTTP_DEFAULTPORT;
begin
  Props := TSQLDBSQLite3ConnectionProperties.Create('test.db3','','','');
  try
    DoTest(Props,'raw Props');
    DoTest(TSQLDBRemoteConnectionPropertiesTest.Create(
      Props,'user','pass',TSQLDBProxyConnectionProtocol),'proxy test');
    DoTest(TSQLDBRemoteConnectionPropertiesTest.Create(
................................................................................
  end;

  TServicePerThread = class(TInterfacedObjectWithCustomCreate,ITestPerThread)
  protected
    fThreadIDAtCreation: TThreadID;
  public
    constructor Create; override;
    function GetContextServiceInstanceID: cardinal;
    function GetThreadIDAtCreation: TThreadID;
    function GetCurrentThreadID: TThreadID;
    function GetCurrentRunningThreadID: TThreadID;
  end;


function TServiceCalculator.Add(n1, n2: integer): integer;
................................................................................
end;

function TServicePerThread.GetThreadIDAtCreation: TThreadID;
begin
  result := fThreadIDAtCreation;
end;

function TServicePerThread.GetContextServiceInstanceID: cardinal;
begin
  with PServiceRunningContext(@ServiceContext)^ do
    if Request=nil then
      result := 0 else begin
      result := Request.ServiceInstanceID;
      if result<>PtrUInt(GetThreadID) then
        raise Exception.Create('Unexpected ThreadID');
................................................................................
    o: TSynTableFieldOptions;
    Ints: TIntegerDynArray;
    Strs1: TRawUTF8DynArray;
    Str2: TWideStringDynArray;
    Rec1: TVirtualTableModuleProperties;
    Rec2, RecRes: TSQLRestCacheEntryValue;
    s: RawUTF8;

begin
  Setlength(Ints,2);
  CSVToRawUTF8DynArray('one,two,three',Strs1);
  for t := 1 to Iterations do begin
    i1 := Random(MaxInt)-Random(MaxInt);
    i2 := Random(MaxInt)-i1;
    Check(I.Add(i1,i2)=i1+i2);
................................................................................
    CheckSame(s2,n2);
    I.Swap(s1,s2);
    CheckSame(s1,n2);
    CheckSame(s2,n1);
    cu := i1*0.01;
    I.ToText(cu,s);
    Check(s=Curr64ToStr(PInt64(@cu)^));

    Check(I.ToTextFunc(n1)=DoubleToString(n1));
    o := [tfoIndex,tfoCaseInsensitive];
    i3 := i1;
    c := cardinal(i2);
    Check(I.SpecialCall(s,i3,c,
      [tftDouble],[tftWinAnsi,tftVarInt64],o)=
      [tftWinAnsi,tftVarInt64,tftDouble]);
    Check(i3=i1+length(s));
................................................................................
    cust: TServiceCustomAnswer;
    c: cardinal;
    n1,n2: double;
    C1,C2,C3: TComplexNumber;
    Item: TCollTest;
    List,Copy: TCollTestsI;
    j: integer;

{$endif}
{$ifndef NOVARIANTS}
    V1,V2,V3: variant;
{$endif}
{$ifdef UNICODE}
    Nav: TConsultaNav;
{$endif}
begin
  Check(Inst.I.Add(1,2)=3);
  Check(Inst.I.Multiply(2,3)=6);
  CheckSame(Inst.I.Subtract(23,20),3);
  Inst.I.ToText(3.14,s);
  Check(s='3.14');
  Check(Inst.I.ToTextFunc(777)='777');

  if GlobalInterfaceTestMode<>itmHttp then
    Check(Inst.CT.GetCurrentThreadID=Inst.CT.GetThreadIDAtCreation);


  case GlobalInterfaceTestMode of
  itmMainThread:
    Check(Inst.CC.GetCurrentThreadID=MainThreadID);
  itmPerInterfaceThread,itmLocked:
    Check(Inst.CC.GetCurrentThreadID<>MainThreadID);
  end;
  TestCalculator(Inst.I);
................................................................................
  {$endif}
  Inst.CN.Assign(3.14,1.05946);
  CheckSame(Inst.CN.Real,3.14);
  CheckSame(Inst.CN.Imaginary,1.05946);
  Check(Inst.CU.GetContextSessionID=Inst.ExpectedSessionID);
  Check(Inst.CG.GetContextSessionGroup=Inst.ExpectedGroupID);
  Check(Inst.CS.GetContextSessionUser=Inst.ExpectedUserID);


  case GlobalInterfaceTestMode of
  itmDirect: begin
    Check(Inst.CT.GetCurrentThreadID=Inst.CT.GetThreadIDAtCreation);

    Check(PtrUInt(Inst.CT.GetCurrentRunningThreadID)=0);
    Check(Inst.CT.GetContextServiceInstanceID=0);
  end;
  itmClient, itmPerInterfaceThread: begin
    Check(Inst.CT.GetCurrentThreadID=Inst.CT.GetThreadIDAtCreation);
    Check(PtrUInt(Inst.CT.GetCurrentRunningThreadID)=0);
    Check(Inst.CT.GetContextServiceInstanceID<>0);
  end;
  itmLocked, itmMainThread: begin
    Check(Inst.CT.GetCurrentThreadID=Inst.CT.GetThreadIDAtCreation);
    Check(PtrUInt(Inst.CT.GetCurrentRunningThreadID)<>0);
    Check(Inst.CT.GetContextServiceInstanceID<>0);
  end;
  itmHttp: begin
    Check(Inst.CT.GetCurrentRunningThreadID<>0);
    Check(PtrUInt(Inst.CT.GetCurrentThreadID)<>MainThreadID);
    Check(Inst.CT.GetContextServiceInstanceID<>0);
................................................................................
var
  HttpClient: TDDDThreadsHttpClient;
  test: TDDDTest;
  i: integer;
const
  MAX = 1000;
begin
  HttpClient := TDDDThreadsHttpClient.Create('localhost', HTTP_DEFAULTPORT);
  try
    Check(HttpClient.SetUser('Admin', 'synopse'));
    test := TDDDTest.Create;
    try
      for i := 0 to MAX - 1 do begin
        test.Description := FormatUTF8('test-%', [i]);
        Check(HttpClient.MyCommand.Add(test) = cqrsSuccess);
................................................................................

constructor TDDDThreadsThread.Create(const aID, aRequestCount: integer);
begin
  inherited Create(true);
  fRequestCount := aRequestCount;
  fId := aId;
  fIsError := false;
  fHttpClient := TDDDThreadsHttpClient.Create('localhost', HTTP_DEFAULTPORT);
  fHttpClient.SetUser('Admin', 'synopse');
end;

destructor TDDDThreadsThread.Destroy;
begin
  fHttpClient.Free;
  inherited;






|







 







|







 







|







 







|







 







|







 







>







 







>
|







 







>









|




>
|
|
>
>







 







>
>


<
>




|




|







 







|







 







|







1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
....
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
.....
10541
10542
10543
10544
10545
10546
10547
10548
10549
10550
10551
10552
10553
10554
10555
.....
12265
12266
12267
12268
12269
12270
12271
12272
12273
12274
12275
12276
12277
12278
12279
.....
12511
12512
12513
12514
12515
12516
12517
12518
12519
12520
12521
12522
12523
12524
12525
.....
12559
12560
12561
12562
12563
12564
12565
12566
12567
12568
12569
12570
12571
12572
12573
.....
12581
12582
12583
12584
12585
12586
12587
12588
12589
12590
12591
12592
12593
12594
12595
12596
.....
12646
12647
12648
12649
12650
12651
12652
12653
12654
12655
12656
12657
12658
12659
12660
12661
12662
12663
12664
12665
12666
12667
12668
12669
12670
12671
12672
12673
12674
12675
12676
12677
12678
12679
.....
12785
12786
12787
12788
12789
12790
12791
12792
12793
12794
12795

12796
12797
12798
12799
12800
12801
12802
12803
12804
12805
12806
12807
12808
12809
12810
12811
12812
12813
.....
14668
14669
14670
14671
14672
14673
14674
14675
14676
14677
14678
14679
14680
14681
14682
.....
14760
14761
14762
14763
14764
14765
14766
14767
14768
14769
14770
14771
14772
14773
14774
    ['{5237A687-C0B2-46BA-9F39-BEEA7C3AA6A9}']
  end;

  /// a test interface, used by TTestServiceOrientedArchitecture
  // - to test threading implementation pattern
  ITestPerThread = interface(IInvokable)
    ['{202B6C9F-FCCB-488D-A425-5472554FD9B1}']
    function GetContextServiceInstanceID: PtrUInt;
    function GetThreadIDAtCreation: TThreadID;
    function GetCurrentThreadID: TThreadID;
    function GetCurrentRunningThreadID: TThreadID;
  end;

  /// a test value object, used by IUserRepository/ISmsSender interfaces
  // - to test stubing/mocking implementation pattern
................................................................................
  RecordLoadJSON(JA,pointer(U),TypeInfo(TTestCustomJSONArrayWithoutF));
  Check(length(JA.E)=2);
  Check(JA.D='1234');
  TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONArrayWithoutF),'');

  discogsJson := StringFromFile(discogsFileName);
  if discogsJson='' then begin
    discogsJson := HttpGet('https://api.discogs.com/artists/45/releases?page=1&per_page=100');
    FileFromString(discogsJson,discogsFileName);
  end;
  zendframeworkJson := StringFromFile(zendframeworkFileName);
  if zendframeworkJson='' then begin
    zendframeworkJson := HttpGet('https://api.github.com/users/zendframework/repos');
    FileFromString(zendframeworkJson,zendframeworkFileName);
  end;
................................................................................
    DoTests;
  finally
    if proxy<>Props then
      proxy.Free;
  end;
end;
var Server: TSQLDBServerAbstract;
const ADDR='127.0.0.1:'+HTTP_DEFAULTPORT;
begin
  Props := TSQLDBSQLite3ConnectionProperties.Create('test.db3','','','');
  try
    DoTest(Props,'raw Props');
    DoTest(TSQLDBRemoteConnectionPropertiesTest.Create(
      Props,'user','pass',TSQLDBProxyConnectionProtocol),'proxy test');
    DoTest(TSQLDBRemoteConnectionPropertiesTest.Create(
................................................................................
  end;

  TServicePerThread = class(TInterfacedObjectWithCustomCreate,ITestPerThread)
  protected
    fThreadIDAtCreation: TThreadID;
  public
    constructor Create; override;
    function GetContextServiceInstanceID: PtrUInt;
    function GetThreadIDAtCreation: TThreadID;
    function GetCurrentThreadID: TThreadID;
    function GetCurrentRunningThreadID: TThreadID;
  end;


function TServiceCalculator.Add(n1, n2: integer): integer;
................................................................................
end;

function TServicePerThread.GetThreadIDAtCreation: TThreadID;
begin
  result := fThreadIDAtCreation;
end;

function TServicePerThread.GetContextServiceInstanceID: PtrUInt;
begin
  with PServiceRunningContext(@ServiceContext)^ do
    if Request=nil then
      result := 0 else begin
      result := Request.ServiceInstanceID;
      if result<>PtrUInt(GetThreadID) then
        raise Exception.Create('Unexpected ThreadID');
................................................................................
    o: TSynTableFieldOptions;
    Ints: TIntegerDynArray;
    Strs1: TRawUTF8DynArray;
    Str2: TWideStringDynArray;
    Rec1: TVirtualTableModuleProperties;
    Rec2, RecRes: TSQLRestCacheEntryValue;
    s: RawUTF8;
    r: string;
begin
  Setlength(Ints,2);
  CSVToRawUTF8DynArray('one,two,three',Strs1);
  for t := 1 to Iterations do begin
    i1 := Random(MaxInt)-Random(MaxInt);
    i2 := Random(MaxInt)-i1;
    Check(I.Add(i1,i2)=i1+i2);
................................................................................
    CheckSame(s2,n2);
    I.Swap(s1,s2);
    CheckSame(s1,n2);
    CheckSame(s2,n1);
    cu := i1*0.01;
    I.ToText(cu,s);
    Check(s=Curr64ToStr(PInt64(@cu)^));
    r := DoubleToString(n1);
    Check(I.ToTextFunc(n1)=r);
    o := [tfoIndex,tfoCaseInsensitive];
    i3 := i1;
    c := cardinal(i2);
    Check(I.SpecialCall(s,i3,c,
      [tftDouble],[tftWinAnsi,tftVarInt64],o)=
      [tftWinAnsi,tftVarInt64,tftDouble]);
    Check(i3=i1+length(s));
................................................................................
    cust: TServiceCustomAnswer;
    c: cardinal;
    n1,n2: double;
    C1,C2,C3: TComplexNumber;
    Item: TCollTest;
    List,Copy: TCollTestsI;
    j: integer;
    x,y: PtrUInt; // alf: to help debugging
{$endif}
{$ifndef NOVARIANTS}
    V1,V2,V3: variant;
{$endif}
{$ifdef UNICODE}
    Nav: TConsultaNav;
{$endif}
begin
  Check(Inst.I.Add(1,2)=3);
  Check(Inst.I.Multiply($1111333344445555,$2222666677778888)=$e26accccbf257d28);
  CheckSame(Inst.I.Subtract(23,20),3);
  Inst.I.ToText(3.14,s);
  Check(s='3.14');
  Check(Inst.I.ToTextFunc(777)='777');
  x := Inst.CT.GetCurrentThreadID;
  if GlobalInterfaceTestMode<>itmHttp then begin
    y := Inst.CT.GetThreadIDAtCreation;
    Check(x=y);
  end;
  case GlobalInterfaceTestMode of
  itmMainThread:
    Check(Inst.CC.GetCurrentThreadID=MainThreadID);
  itmPerInterfaceThread,itmLocked:
    Check(Inst.CC.GetCurrentThreadID<>MainThreadID);
  end;
  TestCalculator(Inst.I);
................................................................................
  {$endif}
  Inst.CN.Assign(3.14,1.05946);
  CheckSame(Inst.CN.Real,3.14);
  CheckSame(Inst.CN.Imaginary,1.05946);
  Check(Inst.CU.GetContextSessionID=Inst.ExpectedSessionID);
  Check(Inst.CG.GetContextSessionGroup=Inst.ExpectedGroupID);
  Check(Inst.CS.GetContextSessionUser=Inst.ExpectedUserID);
  x := Inst.CT.GetCurrentThreadID;
  y := Inst.CT.GetThreadIDAtCreation;
  case GlobalInterfaceTestMode of
  itmDirect: begin

    Check(x=y);
    Check(PtrUInt(Inst.CT.GetCurrentRunningThreadID)=0);
    Check(Inst.CT.GetContextServiceInstanceID=0);
  end;
  itmClient, itmPerInterfaceThread: begin
    Check(x=y);
    Check(PtrUInt(Inst.CT.GetCurrentRunningThreadID)=0);
    Check(Inst.CT.GetContextServiceInstanceID<>0);
  end;
  itmLocked, itmMainThread: begin
    Check(x=y);
    Check(PtrUInt(Inst.CT.GetCurrentRunningThreadID)<>0);
    Check(Inst.CT.GetContextServiceInstanceID<>0);
  end;
  itmHttp: begin
    Check(Inst.CT.GetCurrentRunningThreadID<>0);
    Check(PtrUInt(Inst.CT.GetCurrentThreadID)<>MainThreadID);
    Check(Inst.CT.GetContextServiceInstanceID<>0);
................................................................................
var
  HttpClient: TDDDThreadsHttpClient;
  test: TDDDTest;
  i: integer;
const
  MAX = 1000;
begin
  HttpClient := TDDDThreadsHttpClient.Create('127.0.0.1', HTTP_DEFAULTPORT);
  try
    Check(HttpClient.SetUser('Admin', 'synopse'));
    test := TDDDTest.Create;
    try
      for i := 0 to MAX - 1 do begin
        test.Description := FormatUTF8('test-%', [i]);
        Check(HttpClient.MyCommand.Add(test) = cqrsSuccess);
................................................................................

constructor TDDDThreadsThread.Create(const aID, aRequestCount: integer);
begin
  inherited Create(true);
  fRequestCount := aRequestCount;
  fId := aId;
  fIsError := false;
  fHttpClient := TDDDThreadsHttpClient.Create('127.0.0.1', HTTP_DEFAULTPORT);
  fHttpClient.SetUser('Admin', 'synopse');
end;

destructor TDDDThreadsThread.Destroy;
begin
  fHttpClient.Free;
  inherited;

Changes to SynWinSock.pas.

99
100
101
102
103
104
105



106
107
108
109

110

111
112
113
114
115
116
117
118
119
120
121
122
123
...
124
125
126
127
128
129
130

131
132
133
134
135
136
137
type
  u_char = AnsiChar;
  u_short = Word;
  u_int = Integer;
  u_long = Longint;
  pu_long = ^u_long;
  pu_short = ^u_short;



  {$ifdef UNICODE}
  TSocket = NativeInt;
  {$else}
  TSocket = integer;

  {$endif}


const
  {$IFDEF WINSOCK1}
    DLLStackName: PChar = 'wsock32.dll';
  {$ELSE}
    DLLStackName: PChar = 'ws2_32.dll';
  {$ENDIF}
  DLLwship6: PChar = 'wship6.dll';

  cLocalhost = '127.0.0.1';
  cAnyHost = '0.0.0.0';
  cBroadcast = '255.255.255.255';
  c6Localhost = '::1';
................................................................................
  c6AnyHost = '::0';
  c6Broadcast = 'ffff::1';
  cAnyPort = '0';


const
  FD_SETSIZE     =   64;

type
  PFDSet = ^TFDSet;
  TFDSet = record
    fd_count: u_int;
    fd_array: array[0..FD_SETSIZE-1] of TSocket;
  end;







>
>
>
|
|
|
|
>

>



|

|







 







>







99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
...
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
type
  u_char = AnsiChar;
  u_short = Word;
  u_int = Integer;
  u_long = Longint;
  pu_long = ^u_long;
  pu_short = ^u_short;
  {$ifdef FPC}
  TSocket = PtrInt;
  {$else}
    {$ifdef UNICODE}
    TSocket = NativeInt;
    {$else}
    TSocket = integer;
    {$endif UNICODE}
  {$endif}


const
  {$IFDEF WINSOCK1}
  DLLStackName: PChar = 'wsock32.dll';
  {$ELSE}
  DLLStackName: PChar = 'ws2_32.dll';
  {$ENDIF}
  DLLwship6: PChar = 'wship6.dll';

  cLocalhost = '127.0.0.1';
  cAnyHost = '0.0.0.0';
  cBroadcast = '255.255.255.255';
  c6Localhost = '::1';
................................................................................
  c6AnyHost = '::0';
  c6Broadcast = 'ffff::1';
  cAnyPort = '0';


const
  FD_SETSIZE     =   64;

type
  PFDSet = ^TFDSet;
  TFDSet = record
    fd_count: u_int;
    fd_array: array[0..FD_SETSIZE-1] of TSocket;
  end;

Changes to Synopse.inc.

201
202
203
204
205
206
207
208
209
210
211
212
213









214
215
216
217

218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235

236
237
238
239
240
241
242
243
244
245
246
247


248

249
250
251
252
253
254
255
...
270
271
272
273
274
275
276



277
278
279
280
281
282
283
  {$define NODELPHIASM}   // ignore low-level System.@LStrFromPCharLen calls
  {$define HASAESNI}
  {$define HASTTHREADSTART}
  {$define HASINTERFACEASTOBJECT}
  {$define FPC_OR_UNICODE}
  {$define FPC_ENUMHASINNER}

  {$define FPCSQLITE3STATIC}
  // allow static linking of the SQlite3 engine (including crypto) to the project
  // -> enabled to support static-linked SQLite3 engine, after retrieval of
  // the needed .o files from http://synopse.info/files/sqlite3fpc.7z
  // -> could be disabled to force external .so/.dll linking
  // -> only available for Win32 and Linux32 platforms by now










  {$ifdef ANDROID}
    {$define LINUX}
  {$endif}

  {$ifdef DARWIN}
    {$define LINUX}
    {$define PUREPASCAL} // e.g. low-level stack layout differs
  {$endif}

  {$ifdef CPU64}
    {$define PUREPASCAL}
    {$ifdef CPUX64}
    {$define CPUINTEL}
    {$ASMMODE INTEL} // as Delphi expects, and I use to write
    {$endif CPUX64}
  {$else}
    {$ifdef CPUARM}
    {$define PUREPASCAL}
    {$endif CPUARM}
    {$ifdef CPUX86}
    {$ASMMODE INTEL} // as Delphi expects, and I use to write
    {$define CPUINTEL}

    {$endif CPUX86}
  {$endif CPU64}

  // FPC has its own RTTI layout only since late 3.x
  // when http://bugs.freepascal.org/view.php?id=26774 has been fixed
  {$ifdef FPC_HAS_EXTENDEDINTERFACERTTI} // use dedicated trunk conditional
    {$ifdef CPUINTEL}
    {$define HASINTERFACERTTI}
  {$endif}
    {$ifdef CPUARM}
      {$define HASINTERFACERTTI}
    {$endif}


  {$endif}


  {$define FPC_OR_PUREPASCAL}
  {$define FPC_OR_KYLIX}
  // exceptions interception code in FPC differs from Delphi
  {$define NOEXCEPTIONINTERCEPT}

  // $if FPC_FULLVERSION>20700 breaks Delphi 6-7 and SynProject :(
................................................................................
    {$define ISFPC271}
    {$define HASVARUSTRING}
    {$define HASVARUSTRARG}
    // defined if the http://mantis.freepascal.org/view.php?id=26773 bug is fixed
    // you should use 2.7.1/trunk branch in revision 28995 from 2014-11-05T22:17:54
    // => this will change the TInvokeableVariantType.SetProperty() signature
    {$define FPC_VARIANTSETVAR}



  {$endif}

{$else FPC}

  {$ifndef PUREPASCAL} // if PUREPASCAL is forced, ignore any x86/x64 asm
    {$define CPUINTEL} // no NextGen support yet
  {$endif}






|





>
>
>
>
>
>
>
>
>




>

|




|

|
|



|


<
|
>





|

|
|



>
>
|
>







 







>
>
>







201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243

244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
...
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
  {$define NODELPHIASM}   // ignore low-level System.@LStrFromPCharLen calls
  {$define HASAESNI}
  {$define HASTTHREADSTART}
  {$define HASINTERFACEASTOBJECT}
  {$define FPC_OR_UNICODE}
  {$define FPC_ENUMHASINNER}

  {.$define FPCSQLITE3STATIC}
  // allow static linking of the SQlite3 engine (including crypto) to the project
  // -> enabled to support static-linked SQLite3 engine, after retrieval of
  // the needed .o files from http://synopse.info/files/sqlite3fpc.7z
  // -> could be disabled to force external .so/.dll linking
  // -> only available for Win32 and Linux32 platforms by now

  {$ifdef MSWINDOWS}
    {$define FPCSQLITE3STATIC} // we supply Win32 and Win64 .obj
  {$endif}
  {$ifdef LINUX}
    {$ifdef CPUX86}
      {$define FPCSQLITE3STATIC} // we supply Linux 32-bit x86 .o
    {$endif} 
  {$endif} 

  {$ifdef ANDROID}
    {$define LINUX}
  {$endif}

  {$ifdef DARWIN}
    {$define LINUX} // not true, but a POSIX/BSD system
    {$define PUREPASCAL} // e.g. low-level stack layout differs
  {$endif}

  {$ifdef CPU64}
    {$define PUREPASCAL} // e.g. x64, AARCH64
    {$ifdef CPUX64}
      {$define CPUINTEL}
      {$ASMMODE INTEL} // as Delphi expects
    {$endif CPUX64}
  {$else}
    {$ifdef CPUARM}
      {$define PUREPASCAL} // ARM32
    {$endif CPUARM}
    {$ifdef CPUX86}

      {$define CPUINTEL}
      {$ASMMODE INTEL} // as Delphi expects
    {$endif CPUX86}
  {$endif CPU64}

  // FPC has its own RTTI layout only since late 3.x
  // when http://bugs.freepascal.org/view.php?id=26774 has been fixed
  {$ifdef FPC_HAS_EXTENDEDINTERFACERTTI} // use dedicated branch conditional
    {$ifdef CPUINTEL}
      {$define HASINTERFACERTTI}
    {$endif}
    {$ifdef CPUARM}
      {$define HASINTERFACERTTI}
    {$endif}
    {$ifdef CPUAARCH64}
      {$define HASINTERFACERTTI}
    {$endif}
  {$endif FPC_HAS_EXTENDEDINTERFACERTTI}

  {$define FPC_OR_PUREPASCAL}
  {$define FPC_OR_KYLIX}
  // exceptions interception code in FPC differs from Delphi
  {$define NOEXCEPTIONINTERCEPT}

  // $if FPC_FULLVERSION>20700 breaks Delphi 6-7 and SynProject :(
................................................................................
    {$define ISFPC271}
    {$define HASVARUSTRING}
    {$define HASVARUSTRARG}
    // defined if the http://mantis.freepascal.org/view.php?id=26773 bug is fixed
    // you should use 2.7.1/trunk branch in revision 28995 from 2014-11-05T22:17:54
    // => this will change the TInvokeableVariantType.SetProperty() signature
    {$define FPC_VARIANTSETVAR}
  {$endif}
  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
    {$define FPC_ENUMHASINNER}
  {$endif}

{$else FPC}

  {$ifndef PUREPASCAL} // if PUREPASCAL is forced, ignore any x86/x64 asm
    {$define CPUINTEL} // no NextGen support yet
  {$endif}

Changes to SynopseCommit.inc.

1
'1.18.2696'
|
1
'1.18.2697'