Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
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: |
9408c0ea832c5662af9895559f7c90ea |
User & Date: | ab 2016-05-28 15:39:17 |
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 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'
|